Commit f7df4134 authored by Peter Achten's avatar Peter Achten
Browse files

(PA) modifications for Clean 2.0 compatibility.

parent 73c7be70
......@@ -52,6 +52,7 @@ where
splitWalls = splitWallsInBarrel barrel
initLocal = {talkTo=you,barrel=barrel,balls=balls}
initIO :: Bounce -> Bounce
initIO pst
# (error,pst) = openWindow undef window pst
| error<>NoError
......@@ -67,8 +68,8 @@ where
= abort "bounce could not open receiver."
| otherwise
= pst
// window defines the window that displays the barrel and the current balls.
where
// window defines the window that displays the barrel and the current balls.
window = Window name NilLS
[ WindowId wId
, WindowLook False (updateBalls initLocal)
......@@ -76,30 +77,14 @@ where
, WindowPos (itemLoc,NoOffset)
]
updateBalls :: Local SelectState UpdateState *Picture -> *Picture
updateBalls {balls,barrel} _ {oldFrame,newFrame,updArea} picture
# picture = drawBarrel area scale barrel picture
# picture = seq (map (drawBall scale domain.corner1) balls) picture
= picture
where
domain = barrel.bDomain
windowSize = rectangleSize newFrame
barrelSize = rectangleSize domain
scale = scaleSize windowSize barrelSize
area = if (oldFrame==newFrame) updArea [newFrame]
// menu defines the bounce menu. It contains only the quit command to terminate the application.
// menu defines the bounce menu. It contains only the quit command to terminate the application.
menu = Menu name
( MenuItem "About Bounce..." [MenuFunction (noLS bounceHelp)]
:+: MenuSeparator []
:+: MenuItem "Quit" [MenuFunction (noLS quit),MenuShortKey 'q']
) []
quit :: Bounce -> Bounce
quit bounce=:{ls={talkTo}}
= closeProcess (snd (syncSend talkTo QuitBounce bounce))
// timer defines the timer that will calculate the movements of the current balls as often as possible.
// timer defines the timer that will calculate the movements of the current balls as often as possible.
timer = Timer 0 NilLS
[ TimerId tId
, TimerFunction (noLS1 (bounceBalls splitWalls))
......@@ -125,7 +110,7 @@ where
barrelSize = rectangleSize domain
(ins,outs) = splitBallsInBarrel domain ballsMoved
// receiver defines the receiver that will receive new balls and termination requests.
// receiver defines the receiver that will receive new balls and termination requests.
receiver :: *Receiver Message .ls Bounce
receiver = Receiver me (noLS1 (receive splitWalls)) []
where
......@@ -146,6 +131,22 @@ where
receive _ QuitBounce bounce
= closeProcess bounce
updateBalls :: Local SelectState UpdateState *Picture -> *Picture
updateBalls {balls,barrel} _ {oldFrame,newFrame,updArea} picture
# picture = drawBarrel area scale barrel picture
# picture = seq (map (drawBall scale domain.corner1) balls) picture
= picture
where
domain = barrel.bDomain
windowSize = rectangleSize newFrame
barrelSize = rectangleSize domain
scale = scaleSize windowSize barrelSize
area = if (oldFrame==newFrame) updArea [newFrame]
quit :: Bounce -> Bounce
quit bounce=:{ls={talkTo}}
= closeProcess (snd (syncSend talkTo QuitBounce bounce))
// bounceHelp opens a dialog that tells something about this application.
bounceHelp :: Bounce -> Bounce
bounceHelp bounce
......
......@@ -8,7 +8,7 @@ definition module Help
//
// **************************************************************************************************
from StdString import String
import StdString
from StdPSt import PSt, IOSt
showAbout :: String String (PSt .l) -> PSt .l
......
......@@ -199,13 +199,13 @@ where
= (({w=maxx,h=maxy},[]),pState)
centerInfoLine :: Font Int InfoLine (PSt .l) -> (InfoLine,PSt .l)
centerInfoLine nft maxx info=:(inft=:NoFont centered,x,y,line) pState
centerInfoLine nft maxx info=:(inft=:(NoFont centered),x,y,line) pState
| not centered
= (info,pState)
| otherwise
# (width,pState) = accPIO (accScreenPicture (getFontStringWidth nft line)) pState
= ((inft,(maxx-width)/2,y,line),pState)
centerInfoLine nft maxx info=:(inft=:InfoFont font centered,x,y,line) pState
centerInfoLine nft maxx info=:(inft=:(InfoFont font centered),x,y,line) pState
| not centered
= (info,pState)
| otherwise
......
......@@ -8,8 +8,8 @@ definition module Highscore
//
// **************************************************************************************************
from StdFile import FileSystem
from StdString import String
import StdString
from StdFile import FileSystem, Files
from StdPSt import PSt, IOSt
from StdId import Id
......
......@@ -2,7 +2,7 @@ implementation module Random
import StdInt, StdClass
from StdTime import getCurrentTime, Time
import StdTime
:: RandomSeed :== Int
......
definition module language
import StdList, StdArray, _SystemArray, StdEnum
import StdList, StdArray, /*_SystemArray,*/ StdEnum
import StdIOCommon, StdSystem, StdTime
import board
......
implementation module language
import StdBool, StdList, StdArray, _SystemArray, StdEnum
import StdBool, StdList, StdArray, /*_SystemArray,*/ StdEnum
import StdIOCommon, StdSystem, StdTime
import types
......
......@@ -12,9 +12,6 @@ import StdPictureDef
// Font information:
//font size :== snd (SelectFont "MS Sans Serif" [] 8)
//letterfont :== snd (SelectFont "Times" ["Bold"] 9)
//smallfont :== snd (SelectFont "Small Fonts" [] 6)
font size :== {SansSerifFontDef & fSize=8}
letterfont :== { SerifFontDef & fSize=9,fStyles=[BoldStyle]}
smallfont :== { SmallFontDef & fSize=6}
......
definition module board
from StdString import String
import StdString
import StdClass, StdFile
import types
......
......@@ -206,7 +206,7 @@ where
# (ls,possible,lwrds,wwrds) = tryaddtoline ls word p (n-1)
= ([l:ls],possible,lwrds,wwrds)
hdtl :: ![.x] -> (.x,[.x])
hdtl :: !v:[u:x] -> v:(u:x,v:[u:x]), [v<=u]
hdtl [x:xs] = (x,xs)
tryaddtolines [r:rs] w p j
# (rs,possible,scorenewletters,worddoubling) = tryaddtolines rs w p (j-1)
......
module scrabble
/* Original program written by Paul de Mast in the functional programming language Amanda.
This program is the translated and adapted version to Clean 1.3.2, using the 1.2 object I/O library.
*/
// **************************************************************************************************
//
// This program implements the Scrabble game (without blank letters).
// Original program written by Paul de Mast in the functional programming language Amanda.
// This program is the translated and adapted version to Clean 1.3.2.
// It uses the Clean Standard Object I/O library 1.2.
//
// **************************************************************************************************
import StdEnv, StdIO
......
......@@ -125,7 +125,7 @@ where
# (lines,f) = readlines f
length = size line
| length>1
= ([fromString (line%(0,length-2)):lines],f) // remove '\n'
= ([line%(0,length-2):lines],f) // remove '\n'
| otherwise
= (lines,f)
......
......@@ -717,7 +717,7 @@ moveinlist src dest l // should be in StdList
where
(beforedest,atdest) = splitAt dest l
splitby :: a !.[a] -> [.[a]] | == a
splitby :: a !.[a] -> [.[a]] | Eq a
splitby x ys
= case rest of [] -> [firstpart]; [r:rs] -> [firstpart:splitby x rs]
where
......
implementation module showtm
import StdArray, StdClass, StdInt
import StdArray, StdBool, StdClass, StdInt
from StdString import length, %
from StdChar import toString
from StdBool import &&, otherwise
import StdPicture
import tm
......@@ -43,9 +42,9 @@ where
# pic = DrawCellBorders x y1 y2 pic
= pic
where
x = Offset-4
y1 = TapeY -13
y2 = TapeY +5
x = Offset - 4
y1 = TapeY - 13
y2 = TapeY + 5
DrawCellBorders :: !Int Int Int !*Picture -> *Picture
DrawCellBorders x y1 y2 pic
......@@ -128,9 +127,9 @@ ShowTapePart {content,head} start end pic
# pic = DrawHeadRect (HeadPos head) Red pic
= pic
where
x = Offset-4
y1 = TapeY -13
y2 = TapeY +5
x = Offset - 4
y1 = TapeY - 13
y2 = TapeY + 5
ShowContPart :: Int Int !Int String Int !Int !*Picture -> *Picture
ShowContPart i l x s f t pic
......
definition module tm
from StdString import String
import StdString
:: TmState
= { turing :: !Turing
......
definition module tmfile
from StdString import String
from StdFile import FileSystem
import StdString
from StdFile import FileSystem, Files
from tm import Turing, Transition, Tape, State, Head
WriteTuringToFile :: Turing !String !*env -> (!Bool,!*env) | FileSystem env
......
......@@ -54,8 +54,8 @@ where
# (error,pst) = openReceiver False receiver pst
| error<>NoError = abort "monitor could not open receiver."
| otherwise = pst
// window is the single document of the monitor process.
where
// window is the single document of the monitor process.
window = Window "Monitor" NilLS
[ WindowId wId
, WindowPos pos
......@@ -66,6 +66,18 @@ where
pDomain = {corner1=zero,corner2={x=WindowWidth,y=WindowHeight}}
// The timer gathers per second the number of good and bad key hits.
// The monitor window is updated by drawing only the new diagram bars.
timer = Timer ticksPerSecond NilLS
[ TimerId tId
, TimerSelectState Unable
, TimerFunction (noLS1 (showKeyHits False))
]
// The receiver is the interface of the monitor process to the typist process.
receiver :: *Receiver MonitorMessage Bool (PSt Monitor)
receiver= Receiver monitorId receive []
// monitorlook defines the look of the monitor window.
monitorlook :: Monitor SelectState UpdateState *Picture -> *Picture
monitorlook {counts,tracking} _ _ picture
......@@ -76,14 +88,6 @@ where
| tracking = picture
| otherwise = drawTotalAndAverage font metrics counts picture
// The timer gathers per second the number of good and bad key hits.
// The monitor window is updated by drawing only the new diagram bars.
timer = Timer ticksPerSecond NilLS
[ TimerId tId
, TimerSelectState Unable
, TimerFunction (noLS1 (showKeyHits False))
]
showKeyHits :: Bool NrOfIntervals (PSt Monitor) -> PSt Monitor
showKeyHits final dt monitor=:{ls=local=:{count,counts,time},io}
# io = appWindowPicture wId (seq drawfs) io
......@@ -95,10 +99,6 @@ where
newlocal = {local & count=initcount,counts=counts++newcounts,time=time+dt}
drawfs = snd (smap drawKeyHitColumn (time,newcounts))
// The receiver is the interface of the monitor process to the typist process.
receiver :: *Receiver MonitorMessage Bool (PSt Monitor)
receiver= Receiver monitorId receive []
receive :: MonitorMessage (Bool,PSt Monitor) -> (Bool,PSt Monitor)
// Starting a tracking session enables the timer and clears all previous tracking information.
......@@ -114,8 +114,8 @@ where
where
incCount :: Char Monitor -> Monitor
incCount c local=:{count}
| c=='\b' = {local & count={count & bads=count.bads+1}}
| otherwise = {local & count={count & oks =count.oks +1}}
| c=='\b' = {local & count={count & bads=count.bads + 1}}
| otherwise = {local & count={count & oks =count.oks + 1}}
// Ending a session disables the timer and presents the number and average of key hits.
receive EndSession (firstkeyreceived,monitor=:{ls=local=:{time}})
......
......@@ -76,23 +76,23 @@ where
# pict = setPenFont font pict
= pict
filemenu = Menu "File"
( MenuItem "Play" [MenuId playID,MenuShortKey 'r',MenuFunction (noLS Play)]
:+: MenuItem "Halt" [MenuId haltID,MenuShortKey '.',MenuFunction (noLS Halt),MenuSelectState Unable]
filemenu = Menu "&File"
( MenuItem "&Play" [MenuId playID,MenuShortKey 'r',MenuFunction (noLS Play)]
:+: MenuItem "&Halt" [MenuId haltID,MenuShortKey '.',MenuFunction (noLS Halt),MenuSelectState Unable]
:+: MenuSeparator []
:+: MenuItem "About Worm..." [MenuFunction (noLS (showAbout "Worm" HelpFile))]
:+: MenuItem "Help" [MenuFunction (noLS (showHelp HelpFile))]
:+: MenuItem "&About Worm..." [MenuFunction (noLS (showAbout "Worm" HelpFile))]
:+: MenuItem "H&elp" [MenuFunction (noLS (showHelp HelpFile))]
:+: MenuSeparator []
:+: MenuItem "Quit" [MenuId quitID,MenuShortKey 'q',MenuFunction (noLS Quit)]
:+: MenuItem "&Quit" [MenuId quitID,MenuShortKey 'q',MenuFunction (noLS Quit)]
) [MenuId fileID]
optionsmenu = Menu "Options"
optionsmenu = Menu "&Options"
( RadioMenu
[ ("Slow" ,Nothing,Just '1',noLS (SetSpeed EasySpeed) )
, ("Medium",Nothing,Just '2',noLS (SetSpeed MediumSpeed))
, ("Fast" ,Nothing,Just '3',noLS (SetSpeed HardSpeed) )
[ ("&Slow" ,Nothing,Just '1',noLS (SetSpeed EasySpeed) )
, ("&Medium",Nothing,Just '2',noLS (SetSpeed MediumSpeed))
, ("&Fast" ,Nothing,Just '3',noLS (SetSpeed HardSpeed) )
] 1 []
:+: MenuSeparator []
:+: MenuItem "High Scores" [MenuShortKey 'h',MenuFunction (noLS ShowBest)]
:+: MenuItem "&High Scores" [MenuShortKey 'h',MenuFunction (noLS ShowBest)]
)
[ MenuId levelID
]
......
......@@ -20,9 +20,6 @@ CR :== '\xD' // carriage return
}
:: *PState :== PSt LS
:: NoState
= NoState // The singleton data type
Start :: *World -> *World
Start world
= startIO SDI { sndChan=undef, nickname=""} initialize [ProcessWindowSize zero] world
......@@ -49,10 +46,10 @@ initialize ps
ControlFunction (noLS1 ok (dialogId, nicknameId, rmtsiteId)),
ControlPos (Right, zero)]
) [WindowId dialogId, WindowOk buttonId]
# ((errReport, _), ps) = openModalDialog NoState dDef ps
# ((errReport, _), ps) = openModalDialog Void dDef ps
| errReport<>NoError
= abort "can't open modal dialog"
# (_, ps) = openWindow NoState (Window "dummy" NilLS [WindowViewSize {w=100,h=30}]) ps
# (_, ps) = openWindow Void (Window "dummy" NilLS [WindowViewSize {w=100,h=30}]) ps
= ps
where
ok (dialogId, nicknameId, rmtsiteId) ps
......@@ -97,7 +94,7 @@ initialize ps
, MenuFunction (noLS quit)
]
) []
# (errReport,ps) = openMenu NoState menu ps
# (errReport,ps) = openMenu Void menu ps
| errReport<>NoError
= abort "chat could not open menu."
......@@ -106,7 +103,7 @@ initialize ps
// open send notifier to eventually flush the send channels buffer
# (errReport, sChannel, ps)
= openSendNotifier NoState
= openSendNotifier Void
(SendNotifier sChannel (noLS1 sReceiver) []) ps
| errReport<>NoError
= abort "chat could not open receiver."
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment