home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / gofer230.zip / Progs / Gofer / Demos / Luc / horse1.gs < prev   
Text File  |  1994-06-23  |  4KB  |  188 lines
  1. -- Graphical Knights-Tour program : --------------------------------------------
  2. --
  3. --
  4. -- author : Luc Duponcheel
  5. --
  6.  
  7. --
  8. -- when typing
  9. --
  10. -- ? showHorses ""
  11. --
  12. -- the program should produce on your terminal something like :
  13. --
  14.  
  15.  
  16. --     01  64  53  58  03  60  51  34
  17.  
  18. --     54  57  02  61  52  35  04  49
  19.  
  20. --     63  30  55  46  59  50  33  22
  21.  
  22. --     56  43  62  31  36  21  48  05
  23.  
  24. --     29  14  45  42  47  32  23  20
  25.  
  26. --     44  41  28  15  18  37  06  09
  27.  
  28. --     13  16  39  26  11  08  19  24
  29.  
  30. --     40  27  12  17  38  25  10  07
  31.  
  32. -- (93975 reductions, 179126 cells)
  33.  
  34.  
  35. --
  36. -- (with odd numbers in inverse-video)
  37. --
  38.  
  39.  
  40. --
  41. -- On a Sun SPARC the program has to run in a shell tool 
  42. --                                            ^^^^^
  43.  
  44. --
  45. -- On my Amiga I can also experiment with colours ...
  46. --
  47.  
  48. --
  49. -- The following well known strategy is used :
  50. --
  51. --     choose a move is which is such that, 
  52. --     after having done the move, 
  53. --     a minimal number of next moves is possible.
  54. --
  55. --
  56. -- If your computer is `slow enough' then you will notice that finding such a 
  57. -- move takes longer in the beginning than at the end of the move sequence.
  58. -- 
  59.  
  60. --
  61. -- all attempts to find a faster solution are encouraged
  62. --                        ^^^^^^
  63.  
  64. --
  65. -- PS:
  66. --
  67. -- if you want to avoid that your boss can see that you are
  68. -- playing silly games at work, then you can always type in
  69. --
  70. -- ? clearscreen "" 
  71. --
  72.  
  73. --------------------------------------------------------------------------------
  74.  
  75. --
  76. -- the general purpose function 
  77. -- revcomp 
  78. -- composes a list of functions in reverse order
  79. --
  80.  
  81. revcomp       :: [a -> a] -> a -> a
  82. revcomp []     = id
  83. revcomp (f:fs) = revcomp fs . f
  84.  
  85.  
  86. --
  87. -- some screen oriented functions 
  88. -- it is possible that you'll have to
  89. -- redefine them if you do not work with
  90. -- an ANSI-compliant terminal.
  91. --
  92.  
  93. escape = showChar '\ESC' . showChar '['
  94.  
  95. inverse = escape . showString "7m"
  96. normal  = escape . showString "m"
  97.  
  98. goto x y = escape . shows y . showChar ';' . shows x . showChar 'H'
  99.  
  100. clearscreen = showString "\ESC[2J"  -- ANSI version
  101. clearscreen = showChar '\^L'        -- Sun window
  102.  
  103. continue = normal . goto 0 20
  104.  
  105.  
  106. -- main types
  107.  
  108. type Horse  = (Int,Int)
  109. type Horses = [Horse]
  110.  
  111. type PartOfBoard = [(Int,Int)]
  112.  
  113.  
  114. -- all possible moves from (u,v) to (x,y)
  115.  
  116. (|-->) :: Horse -> Horse -> Bool
  117. (u,v) |--> (x,y) = (x == u+1) && (y == v-2) ||  
  118.                    (x == u-2) && (y == v-1) ||
  119.                    (x == u-2) && (y == v+1) || 
  120.                    (x == u+2) && (y == v-1) || 
  121.                    (x == u+2) && (y == v+1) || 
  122.                    (x == u+1) && (y == v+2) || 
  123.                    (x == u-1) && (y == v+2)    
  124.  
  125. {-
  126.                    (x == u-1) && (y == v-2)    --  NOT used!
  127. -}
  128.  
  129. horsesOn    :: PartOfBoard -> Horse -> Horses
  130. horsesOn pb h = [ h' | h' <- pb, h |--> h' ]
  131.  
  132.  
  133. -- strategy 
  134.  
  135. (>>)            :: [a] -> [b] -> Bool
  136. _      >> [_]    = True
  137. [_]    >> _      = False
  138. (_:ms) >> (_:ns) = ms >> ns
  139.  
  140. minimalize         :: (a -> [b]) -> [a] -> (a,[b])
  141. minimalize f [h]    = (h,f h)
  142. minimalize f (h:hs) = let (k,ms) = minimalize f hs ; ns = f h in 
  143.                        if ns >> ms then (k,ms) else (h,ns)
  144.  
  145.  
  146. -- how to find all horses (  -: stands for `minus`  )
  147.  
  148. (-:)        :: Eq a => [a] -> a -> [a]
  149. (x:xs) -: y 
  150.  | x == y    = xs
  151.  | otherwise = x : (xs -: y)
  152. []     -: x  = []
  153.  
  154.  
  155. horses :: Horses
  156. horses = fst (moves 64)
  157.           where
  158.            moves 1     = ([(1,1)],[ (i,j) | i <- [1..8], j <- [1..8] ] -: (1,1))
  159.            moves (n+1) = let 
  160.                            (hs@(hn:_),b) = moves n
  161.                            f = horsesOn b
  162.                            (h,_) = minimalize f (f hn)
  163.                           in
  164.                            (h:hs,b-:h)
  165.  
  166.  
  167.  
  168. -- How to show a move
  169.  
  170. showMove (x,y) n = g (x,y) . f n 
  171.                     where g1 (x,y) = goto (2+4*x) (2+2*y)
  172.                           g (x,y) 
  173.                               | even (x+y) = g1 (x,y) . inverse 
  174.                               | otherwise  = g1 (x,y) . normal 
  175.                           f1 n 
  176.                               | n < 10     = showChar '0'  
  177.                               | otherwise  = id
  178.                           f n = let m = 65 - n in f1 m . shows m
  179.  
  180. -- How to show all horses
  181.  
  182. showHorses 
  183.  = clearscreen . revcomp (zipWith showMove horses [1..]) . continue 
  184.  
  185.  
  186. --------------------------------------------------------------------------------
  187.  
  188.