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 ...@@ -52,6 +52,7 @@ where
splitWalls = splitWallsInBarrel barrel splitWalls = splitWallsInBarrel barrel
initLocal = {talkTo=you,barrel=barrel,balls=balls} initLocal = {talkTo=you,barrel=barrel,balls=balls}
initIO :: Bounce -> Bounce
initIO pst initIO pst
# (error,pst) = openWindow undef window pst # (error,pst) = openWindow undef window pst
| error<>NoError | error<>NoError
...@@ -67,14 +68,68 @@ where ...@@ -67,14 +68,68 @@ where
= abort "bounce could not open receiver." = abort "bounce could not open receiver."
| otherwise | otherwise
= pst = pst
where
// window defines the window that displays the barrel and the current balls. // window defines the window that displays the barrel and the current balls.
window = Window name NilLS window = Window name NilLS
[ WindowId wId [ WindowId wId
, WindowLook False (updateBalls initLocal) , WindowLook False (updateBalls initLocal)
, WindowViewSize windowSize , WindowViewSize windowSize
, WindowPos (itemLoc,NoOffset) , WindowPos (itemLoc,NoOffset)
]
// 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']
) []
// 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))
] ]
where
bounceBalls :: !(![SingleWall],![SingleWall]) NrOfIntervals Bounce -> Bounce
bounceBalls splitWalls _ bounce=:{ls=local=:{talkTo,balls,barrel},io}
# (windowSize,io) = getWindowViewSize wId io
scale = scaleSize windowSize barrelSize
eraseOld = map (eraseBall scale base) balls
drawNew = map (drawBall scale base) ins
local = {local & balls=ins}
# io = appWindowPicture wId (seq (eraseOld++drawNew)) io
# io = setWindowLook wId False (False,updateBalls local) io
# bounce = {bounce & ls=local,io=io}
| isEmpty outs = bounce
| otherwise = snd (syncSend talkTo (BallsArrive outs) bounce)
where
nextBallPos = nextBallPositions splitWalls balls
ballsMoved = map moveBall nextBallPos
domain = barrel.bDomain
base = domain.corner1
barrelSize = rectangleSize domain
(ins,outs) = splitBallsInBarrel domain ballsMoved
// receiver defines the receiver that will receive new balls and termination requests.
receiver :: *Receiver Message .ls Bounce
receiver = Receiver me (noLS1 (receive splitWalls)) []
where
receive :: !(![SingleWall],![SingleWall]) !Message !Bounce -> Bounce
receive (horizontal,vertical) (BallsArrive newBalls) bounce=:{ls}
#! newBalls = map correctBall newBalls
= {bounce & ls={ls & balls=newBalls++ls.balls}}
where
correctBall :: !Ball -> Ball
correctBall ball=:{bCenter,bSpeed}
# ball = {ball & bCenter=movePoint (~bSpeed) bCenter}
# ball = checkVerticalWalls vertical ball
# ball = checkHorizontalWalls horizontal ball
# ball = moveBall ball
= ball
receive _ BounceOpened bounce
= appPIO (enableTimer tId) bounce
receive _ QuitBounce bounce
= closeProcess bounce
updateBalls :: Local SelectState UpdateState *Picture -> *Picture updateBalls :: Local SelectState UpdateState *Picture -> *Picture
updateBalls {balls,barrel} _ {oldFrame,newFrame,updArea} picture updateBalls {balls,barrel} _ {oldFrame,newFrame,updArea} picture
...@@ -88,64 +143,10 @@ where ...@@ -88,64 +143,10 @@ where
scale = scaleSize windowSize barrelSize scale = scaleSize windowSize barrelSize
area = if (oldFrame==newFrame) updArea [newFrame] area = if (oldFrame==newFrame) updArea [newFrame]
// 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 -> Bounce
quit bounce=:{ls={talkTo}} quit bounce=:{ls={talkTo}}
= closeProcess (snd (syncSend talkTo QuitBounce bounce)) = closeProcess (snd (syncSend talkTo QuitBounce bounce))
// 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))
]
where
bounceBalls :: !(![SingleWall],![SingleWall]) NrOfIntervals Bounce -> Bounce
bounceBalls splitWalls _ bounce=:{ls=local=:{talkTo,balls,barrel},io}
# (windowSize,io) = getWindowViewSize wId io
scale = scaleSize windowSize barrelSize
eraseOld = map (eraseBall scale base) balls
drawNew = map (drawBall scale base) ins
local = {local & balls=ins}
# io = appWindowPicture wId (seq (eraseOld++drawNew)) io
# io = setWindowLook wId False (False,updateBalls local) io
# bounce = {bounce & ls=local,io=io}
| isEmpty outs = bounce
| otherwise = snd (syncSend talkTo (BallsArrive outs) bounce)
where
nextBallPos = nextBallPositions splitWalls balls
ballsMoved = map moveBall nextBallPos
domain = barrel.bDomain
base = domain.corner1
barrelSize = rectangleSize domain
(ins,outs) = splitBallsInBarrel domain ballsMoved
// receiver defines the receiver that will receive new balls and termination requests.
receiver :: *Receiver Message .ls Bounce
receiver = Receiver me (noLS1 (receive splitWalls)) []
where
receive :: !(![SingleWall],![SingleWall]) !Message !Bounce -> Bounce
receive (horizontal,vertical) (BallsArrive newBalls) bounce=:{ls}
#! newBalls = map correctBall newBalls
= {bounce & ls={ls & balls=newBalls++ls.balls}}
where
correctBall :: !Ball -> Ball
correctBall ball=:{bCenter,bSpeed}
# ball = {ball & bCenter=movePoint (~bSpeed) bCenter}
# ball = checkVerticalWalls vertical ball
# ball = checkHorizontalWalls horizontal ball
# ball = moveBall ball
= ball
receive _ BounceOpened bounce
= appPIO (enableTimer tId) bounce
receive _ QuitBounce bounce
= closeProcess bounce
// bounceHelp opens a dialog that tells something about this application. // bounceHelp opens a dialog that tells something about this application.
bounceHelp :: Bounce -> Bounce bounceHelp :: Bounce -> Bounce
bounceHelp bounce bounceHelp bounce
......
...@@ -50,7 +50,7 @@ where ...@@ -50,7 +50,7 @@ where
where where
compare :: (PSt Local) -> PSt Local compare :: (PSt Local) -> PSt Local
compare pst compare pst
# (maybeFirstFile,pst) = selectInputFile pst # (maybeFirstFile,pst) = selectInputFile pst
| isNothing maybeFirstFile | isNothing maybeFirstFile
= {pst & ls=noFilesSelected} = {pst & ls=noFilesSelected}
# (maybeSecondFile,pst) = selectInputFile pst # (maybeSecondFile,pst) = selectInputFile pst
......
...@@ -8,8 +8,8 @@ definition module Help ...@@ -8,8 +8,8 @@ definition module Help
// //
// ************************************************************************************************** // **************************************************************************************************
from StdString import String import StdString
from StdPSt import PSt, IOSt from StdPSt import PSt, IOSt
showAbout :: String String (PSt .l) -> PSt .l showAbout :: String String (PSt .l) -> PSt .l
/* showAbout opens a window: /* showAbout opens a window:
......
...@@ -199,13 +199,13 @@ where ...@@ -199,13 +199,13 @@ where
= (({w=maxx,h=maxy},[]),pState) = (({w=maxx,h=maxy},[]),pState)
centerInfoLine :: Font Int InfoLine (PSt .l) -> (InfoLine,PSt .l) 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 | not centered
= (info,pState) = (info,pState)
| otherwise | otherwise
# (width,pState) = accPIO (accScreenPicture (getFontStringWidth nft line)) pState # (width,pState) = accPIO (accScreenPicture (getFontStringWidth nft line)) pState
= ((inft,(maxx-width)/2,y,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 | not centered
= (info,pState) = (info,pState)
| otherwise | otherwise
......
...@@ -8,10 +8,10 @@ definition module Highscore ...@@ -8,10 +8,10 @@ definition module Highscore
// //
// ************************************************************************************************** // **************************************************************************************************
from StdFile import FileSystem import StdString
from StdString import String from StdFile import FileSystem, Files
from StdPSt import PSt, IOSt from StdPSt import PSt, IOSt
from StdId import Id from StdId import Id
:: HiScores :: HiScores
:== [HiScore] :== [HiScore]
......
...@@ -2,7 +2,7 @@ implementation module Random ...@@ -2,7 +2,7 @@ implementation module Random
import StdInt, StdClass import StdInt, StdClass
from StdTime import getCurrentTime, Time import StdTime
:: RandomSeed :== Int :: RandomSeed :== Int
......
definition module language definition module language
import StdList, StdArray, _SystemArray, StdEnum import StdList, StdArray, /*_SystemArray,*/ StdEnum
import StdIOCommon, StdSystem, StdTime import StdIOCommon, StdSystem, StdTime
import board import board
......
implementation module language implementation module language
import StdBool, StdList, StdArray, _SystemArray, StdEnum import StdBool, StdList, StdArray, /*_SystemArray,*/ StdEnum
import StdIOCommon, StdSystem, StdTime import StdIOCommon, StdSystem, StdTime
import types import types
......
...@@ -12,9 +12,6 @@ import StdPictureDef ...@@ -12,9 +12,6 @@ import StdPictureDef
// Font information: // 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} font size :== {SansSerifFontDef & fSize=8}
letterfont :== { SerifFontDef & fSize=9,fStyles=[BoldStyle]} letterfont :== { SerifFontDef & fSize=9,fStyles=[BoldStyle]}
smallfont :== { SmallFontDef & fSize=6} smallfont :== { SmallFontDef & fSize=6}
......
definition module board definition module board
from StdString import String import StdString
import StdClass, StdFile import StdClass, StdFile
import types import types
......
...@@ -206,7 +206,7 @@ where ...@@ -206,7 +206,7 @@ where
# (ls,possible,lwrds,wwrds) = tryaddtoline ls word p (n-1) # (ls,possible,lwrds,wwrds) = tryaddtoline ls word p (n-1)
= ([l:ls],possible,lwrds,wwrds) = ([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) hdtl [x:xs] = (x,xs)
tryaddtolines [r:rs] w p j tryaddtolines [r:rs] w p j
# (rs,possible,scorenewletters,worddoubling) = tryaddtolines rs w p (j-1) # (rs,possible,scorenewletters,worddoubling) = tryaddtolines rs w p (j-1)
......
module scrabble 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 import StdEnv, StdIO
......
...@@ -125,7 +125,7 @@ where ...@@ -125,7 +125,7 @@ where
# (lines,f) = readlines f # (lines,f) = readlines f
length = size line length = size line
| length>1 | length>1
= ([fromString (line%(0,length-2)):lines],f) // remove '\n' = ([line%(0,length-2):lines],f) // remove '\n'
| otherwise | otherwise
= (lines,f) = (lines,f)
......
...@@ -717,7 +717,7 @@ moveinlist src dest l // should be in StdList ...@@ -717,7 +717,7 @@ moveinlist src dest l // should be in StdList
where where
(beforedest,atdest) = splitAt dest l (beforedest,atdest) = splitAt dest l
splitby :: a !.[a] -> [.[a]] | == a splitby :: a !.[a] -> [.[a]] | Eq a
splitby x ys splitby x ys
= case rest of [] -> [firstpart]; [r:rs] -> [firstpart:splitby x rs] = case rest of [] -> [firstpart]; [r:rs] -> [firstpart:splitby x rs]
where where
......
implementation module showtm implementation module showtm
import StdArray, StdClass, StdInt import StdArray, StdBool, StdClass, StdInt
from StdString import length, % from StdString import length, %
from StdChar import toString from StdChar import toString
from StdBool import &&, otherwise
import StdPicture import StdPicture
import tm import tm
...@@ -43,9 +42,9 @@ where ...@@ -43,9 +42,9 @@ where
# pic = DrawCellBorders x y1 y2 pic # pic = DrawCellBorders x y1 y2 pic
= pic = pic
where where
x = Offset-4 x = Offset - 4
y1 = TapeY -13 y1 = TapeY - 13
y2 = TapeY +5 y2 = TapeY + 5
DrawCellBorders :: !Int Int Int !*Picture -> *Picture DrawCellBorders :: !Int Int Int !*Picture -> *Picture
DrawCellBorders x y1 y2 pic DrawCellBorders x y1 y2 pic
...@@ -128,9 +127,9 @@ ShowTapePart {content,head} start end pic ...@@ -128,9 +127,9 @@ ShowTapePart {content,head} start end pic
# pic = DrawHeadRect (HeadPos head) Red pic # pic = DrawHeadRect (HeadPos head) Red pic
= pic = pic
where where
x = Offset-4 x = Offset - 4
y1 = TapeY -13 y1 = TapeY - 13
y2 = TapeY +5 y2 = TapeY + 5
ShowContPart :: Int Int !Int String Int !Int !*Picture -> *Picture ShowContPart :: Int Int !Int String Int !Int !*Picture -> *Picture
ShowContPart i l x s f t pic ShowContPart i l x s f t pic
......
definition module tm definition module tm
from StdString import String import StdString
:: TmState :: TmState
= { turing :: !Turing = { turing :: !Turing
......
definition module tmfile definition module tmfile
from StdString import String import StdString
from StdFile import FileSystem from StdFile import FileSystem, Files
from tm import Turing, Transition, Tape, State, Head from tm import Turing, Transition, Tape, State, Head
WriteTuringToFile :: Turing !String !*env -> (!Bool,!*env) | FileSystem env WriteTuringToFile :: Turing !String !*env -> (!Bool,!*env) | FileSystem env
......
...@@ -54,17 +54,29 @@ where ...@@ -54,17 +54,29 @@ where
# (error,pst) = openReceiver False receiver pst # (error,pst) = openReceiver False receiver pst
| error<>NoError = abort "monitor could not open receiver." | error<>NoError = abort "monitor could not open receiver."
| otherwise = pst | otherwise = pst
where
// window is the single document of the monitor process.
window = Window "Monitor" NilLS
[ WindowId wId
, WindowPos pos
, WindowViewDomain pDomain
, WindowLook True (monitorlook initLocal)
, WindowInit (noLS (appPIO (appWindowPicture wId (setPenFont font))))
]
pDomain = {corner1=zero,corner2={x=WindowWidth,y=WindowHeight}}
// window is the single document of the monitor process. // The timer gathers per second the number of good and bad key hits.
window = Window "Monitor" NilLS // The monitor window is updated by drawing only the new diagram bars.
[ WindowId wId timer = Timer ticksPerSecond NilLS
, WindowPos pos [ TimerId tId
, WindowViewDomain pDomain , TimerSelectState Unable
, WindowLook True (monitorlook initLocal) , TimerFunction (noLS1 (showKeyHits False))
, WindowInit (noLS (appPIO (appWindowPicture wId (setPenFont font)))) ]
]
// The receiver is the interface of the monitor process to the typist process.
pDomain = {corner1=zero,corner2={x=WindowWidth,y=WindowHeight}} receiver :: *Receiver MonitorMessage Bool (PSt Monitor)
receiver= Receiver monitorId receive []
// monitorlook defines the look of the monitor window. // monitorlook defines the look of the monitor window.
monitorlook :: Monitor SelectState UpdateState *Picture -> *Picture monitorlook :: Monitor SelectState UpdateState *Picture -> *Picture
...@@ -75,14 +87,6 @@ where ...@@ -75,14 +87,6 @@ where
# picture = seq (snd (smap drawKeyHitColumn (0,counts))) picture # picture = seq (snd (smap drawKeyHitColumn (0,counts))) picture
| tracking = picture | tracking = picture
| otherwise = drawTotalAndAverage font metrics counts 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 :: Bool NrOfIntervals (PSt Monitor) -> PSt Monitor
showKeyHits final dt monitor=:{ls=local=:{count,counts,time},io} showKeyHits final dt monitor=:{ls=local=:{count,counts,time},io}
...@@ -95,10 +99,6 @@ where ...@@ -95,10 +99,6 @@ where
newlocal = {local & count=initcount,counts=counts++newcounts,time=time+dt} newlocal = {local & count=initcount,counts=counts++newcounts,time=time+dt}
drawfs = snd (smap drawKeyHitColumn (time,newcounts)) 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) receive :: MonitorMessage (Bool,PSt Monitor) -> (Bool,PSt Monitor)
// Starting a tracking session enables the timer and clears all previous tracking information. // Starting a tracking session enables the timer and clears all previous tracking information.
...@@ -114,8 +114,8 @@ where ...@@ -114,8 +114,8 @@ where
where where
incCount :: Char Monitor -> Monitor incCount :: Char Monitor -> Monitor
incCount c local=:{count} incCount c local=:{count}
| c=='\b' = {local & count={count & bads=count.bads+1}} | c=='\b' = {local & count={count & bads=count.bads + 1}}
| otherwise = {local & count={count & oks =count.oks +1}} | otherwise = {local & count={count & oks =count.oks + 1}}
// Ending a session disables the timer and presents the number and average of key hits. // Ending a session disables the timer and presents the number and average of key hits.
receive EndSession (firstkeyreceived,monitor=:{ls=local=:{time}}) receive EndSession (firstkeyreceived,monitor=:{ls=local=:{time}})
......