module Hanoi // ************************************************************************************************** // // This program shows the Towers of Hanoi algorithm graphically. // // The program has been written in Clean 2.0 and uses the Clean Standard Object I/O library 1.2.2 // // ************************************************************************************************** import StdEnv, StdIO :: Tower :== [Int] :: Moves :== [Int] :: Towers = { moves :: !Moves , tower1 :: !Tower , tower2 :: !Tower , tower3 :: !Tower } :: TowerPos = { pos :: Int , tower :: Tower } ViewDomain :== {corner1={x=50,y=0},corner2={x=480,y=180}} Speed1 :== ticksPerSecond / 2 Speed2 :== ticksPerSecond / 3 Speed3 :== ticksPerSecond / 6 Speed4 :== ticksPerSecond / 12 Speed5 :== 0 MinDisks :== 2 MaxDisks :== 10 XOffs :== inc MaxDisks * 10 // Starting the program Start :: *World -> *World Start world = startHanoi (openIds 5 world) startHanoi :: ([Id],*World) -> *World startHanoi ([runID,haltID,contID,timerID,windowID:_],world) = startIO SDI (initTowers 0) // The initial local process state initialise // The initialisation action [ProcessClose closeProcess] // Only default process attributes world where initialise :: (PSt Towers) -> PSt Towers initialise pst # (error,pst) = openWindow undef window pst | error<>NoError = abort "Hanoi could not open window." # (error,pst) = openMenu undef menu pst | error<>NoError = abort "Hanoi could not open menu." # (error,pst) = openTimer undef timer pst | error<>NoError = abort "Hanoi could not open timer." | otherwise = pst where menu = Menu "&Hanoi" ( SubMenu "&Run (nr disks)" ( RadioMenu [ ("&"+++toString i,Nothing,Nothing,noLS (run i)) \\ i<-[MinDisks..MaxDisks] ] 1 [] ) [ MenuId runID ] :+: MenuItem "Halt" [ MenuId haltID , MenuShortKey '.' , MenuSelectState Unable , MenuFunction (noLS halt) ] :+: MenuItem "Continue" [ MenuId contID , MenuShortKey ',' , MenuSelectState Unable , MenuFunction (noLS continue) ] :+: SubMenu "&Speed" ( RadioMenu [ ("V&ery Slow", Nothing, Just 'A', noLS (setSpeed Speed1)) , ("&Slow" , Nothing, Just 'S', noLS (setSpeed Speed2)) , ("&Normal" , Nothing, Just 'D', noLS (setSpeed Speed3)) , ("&Fast" , Nothing, Just 'F', noLS (setSpeed Speed4)) , ("&Very Fast", Nothing, Just 'G', noLS (setSpeed Speed5)) ] 3 [] ) [] :+: MenuSeparator [] :+: MenuItem "&Quit" [MenuShortKey 'q', MenuFunction (noLS closeProcess)] ) [] window = Window "Hanoi" NilLS [ WindowId windowID , WindowViewDomain ViewDomain , WindowLook True (look (initTowers 0)) ] timer = Timer Speed3 NilLS [ TimerId timerID , TimerSelectState Unable , TimerFunction (noLS1 stepHanoi) ] // The function for the Run command. run :: Int (PSt Towers) -> PSt Towers run nr_disks hanoi=:{io} # io = disableMenuElements [runID,contID] io # io = enableMenuElements [haltID] io # io = enableTimer timerID io # io = setWindowLook windowID True (True,look towers) io = {hanoi & ls=towers,io=io} where towers = initTowers nr_disks // The function for the Halt command. halt :: (PSt Towers) -> PSt Towers halt hanoi=:{io} # io = enableMenuElements [runID,contID] io # io = disableMenuElements [haltID] io # io = disableTimer timerID io = {hanoi & io=io} // The function for the Continue command. continue :: (PSt Towers) -> PSt Towers continue hanoi=:{io} # io = disableMenuElements [runID,contID] io # io = enableMenuElements [haltID] io # io = enableTimer timerID io = {hanoi & io=io} // Set the speed of a (possibly running) Hanoi simulation. setSpeed :: Int (PSt Towers) -> PSt Towers setSpeed speed hanoi=:{io} # io = setTimerInterval timerID speed io = {hanoi & io=io} // The timer function: take a move from the list of all moves and show it in the window. stepHanoi :: NrOfIntervals (PSt Towers) -> PSt Towers stepHanoi _ hanoi=:{ls={moves=[]},io} # io = enableMenuElements [runID] io # io = disableMenuElements [haltID] io # io = disableTimer timerID io = {hanoi & io=io} stepHanoi _ hanoi=:{ls,io} # (drawf,towers) = changeTowers ls # io = appWindowPicture windowID drawf io # io = setWindowLook windowID False (True,look towers) io = {hanoi & ls=towers,io=io} where changeTowers :: Towers -> (IdFun *Picture,Towers) changeTowers towers=:{moves=[1,2:moves],tower1=[f1:r1],tower2=t2} = (drawMove 1 2 f1 (length r1) (length t2),{towers & moves=moves,tower1=r1,tower2=[f1:t2]}) changeTowers towers=:{moves=[1,3:moves],tower1=[f1:r1],tower3=t3} = (drawMove 1 3 f1 (length r1) (length t3),{towers & moves=moves,tower1=r1,tower3=[f1:t3]}) changeTowers towers=:{moves=[2,1:moves],tower2=[f2:r2],tower1=t1} = (drawMove 2 1 f2 (length r2) (length t1),{towers & moves=moves,tower2=r2,tower1=[f2:t1]}) changeTowers towers=:{moves=[2,3:moves],tower2=[f2:r2],tower3=t3} = (drawMove 2 3 f2 (length r2) (length t3),{towers & moves=moves,tower2=r2,tower3=[f2:t3]}) changeTowers towers=:{moves=[3,1:moves],tower3=[f3:r3],tower1=t1} = (drawMove 3 1 f3 (length r3) (length t1),{towers & moves=moves,tower3=r3,tower1=[f3:t1]}) changeTowers towers=:{moves=[3,2:moves],tower3=[f3:r3],tower2=t2} = (drawMove 3 2 f3 (length r3) (length t2),{towers & moves=moves,tower3=r3,tower2=[f3:t2]}) drawMove :: Int Int Int Int Int *Picture -> *Picture drawMove start end disk lenfr lento picture # picture = eraseDisk {corner1={x=fx-w,y=fy},corner2={x=fx+w,y=fy+10}} picture # picture = drawDisk {corner1={x=tx-w,y=ty},corner2={x=tx+w,y=ty+10}} picture = picture where tx = end *XOffs; ty = 10+10*(MaxDisks-lento) fx = start*XOffs; fy = 10+10*(MaxDisks-lenfr) w = disk *5 // The initial Towers value, given the number of disks initTowers :: Int -> Towers initTowers nr_disks = { moves = hanoi nr_disks 1 2 3 , tower1 = [1..nr_disks] , tower2 = [] , tower3 = [] } where hanoi :: Int Int Int Int -> Moves // The function that calculates the list of disk moves hanoi n start end via | n==0 = [] | otherwise = hanoi m start via end ++ [start,end : hanoi m via end start] where m = n-1 // The update function: erase the window and redraw the towers look :: Towers SelectState UpdateState *Picture -> *Picture look {tower1,tower2,tower3} _ {newFrame} picture # picture = unfill newFrame picture # picture = draw {pos=1,tower=tower1} picture # picture = draw {pos=2,tower=tower2} picture # picture = draw {pos=3,tower=tower3} picture = picture instance Drawables TowerPos where draw :: !TowerPos !*Picture -> *Picture draw {pos,tower} picture = drawName pos (drawTower pos (MaxDisks-length tower) tower picture) where drawTower :: !Int !Int !Tower !*Picture -> *Picture drawTower nr i [f:r] picture = drawTower nr (i+1) r (drawDisk {corner1={x=x-w,y=y},corner2={x=x+w,y=y+10}} picture) where x = nr*XOffs w = f *5 y = 20+10*i drawTower _ _ _ picture = picture drawName :: !Int !*Picture -> *Picture drawName nr picture | nr==1 = draw "from" (setPenPos {x= XOffs-14,y=y} picture) | nr==2 = draw "to" (setPenPos {x=2*XOffs-6, y=y} picture) | nr==3 = draw "via" (setPenPos {x=3*XOffs-9, y=y} picture) where y = 35+10*MaxDisks drawAt :: !Point2 !TowerPos !*Picture -> *Picture drawAt _ tower picture = draw tower picture undraw :: !TowerPos !*Picture -> *Picture undraw {pos,tower} picture = unfill {corner1={x=x-w/2,y=0},corner2={x=x+w/2,y=35+10*MaxDisks}} picture where x = pos*XOffs w = 10*MaxDisks undrawAt :: !Point2 !TowerPos !*Picture -> *Picture undrawAt _ tower picture = undraw tower picture eraseDisk :: Rectangle *Picture -> *Picture eraseDisk rectangle picture = unfill rectangle picture drawDisk :: Rectangle *Picture -> *Picture drawDisk rectangle picture # picture = setPenColour (RGB {r=MaxRGB/2,g=MaxRGB*3/5,b=MaxRGB*7/10}) picture # picture = fill rectangle picture # picture = setPenColour Black picture # picture = draw rectangle picture = picture