home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / demo / X11 / gobang / utilities.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  11.8 KB  |  302 lines  |  [TEXT/YHS2]
  1. module Utilities where
  2.  
  3. import Xlib
  4. import Weights
  5. import Redraw
  6. import Misc
  7.  
  8. data XInfo = XInfo XDisplay XWindow XGcontext XGcontext XGcontext
  9. data GameState = GameState (XMArray String) (XMArray String) (XMArray Int)
  10.                            (XMArray Int) (XMArray Int) (XMArray Int) 
  11.                            (XMArray Integer) (XMArray Int)
  12.                            (XMArray String) (XMArray Int)
  13.  
  14. type GameCont = XInfo -> GameState -> IO ()
  15.  
  16. xMArrayToList :: XMArray a -> IO [a]
  17. xMArrayToList a = 
  18.    let la = xMArrayLength a
  19.        loop i a = if i == la then return []
  20.                   else xMArrayLookup a i >>= \ x ->
  21.                        loop (i+1) a >>= \ xs ->
  22.                        return (x:xs)
  23.    in
  24.    loop 0 a
  25.  
  26.  
  27. readGameState str =
  28.   let
  29.     [(board_lst, r1)] = reads str
  30.     [(weight1_lst, r2)] = reads r1
  31.     [(weight2_lst, r3)] = reads r2
  32.     [(steps_lst, r4)] = reads r3
  33.     [(player1_lst, r5)] = reads r4
  34.     [(player2_lst, r6)] = reads r5
  35.     [(time_lst, r7)] = reads r6
  36.     [(numbersteps_lst, r8)] = reads r7
  37.     [(promptString_lst, r9)] = reads r8
  38.     [(next_player_lst, [])] = reads r9
  39.   in
  40.   xMArrayCreate board_lst >>= \ board ->
  41.   xMArrayCreate weight1_lst >>= \ weight1 ->
  42.   xMArrayCreate weight2_lst >>= \ weight2 ->
  43.   xMArrayCreate steps_lst >>= \ steps ->
  44.   xMArrayCreate player1_lst >>= \ player1 ->
  45.   xMArrayCreate player2_lst >>= \ player2 ->
  46.   xMArrayCreate time_lst >>=  \ time ->
  47.   xMArrayCreate numbersteps_lst >>= \ numbersteps ->
  48.   xMArrayCreate promptString_lst >>= \ promptString ->
  49.   xMArrayCreate next_player_lst >>= \ next_player ->
  50.   return (GameState player1 player2 board steps weight1 weight2 time
  51.                       numbersteps promptString next_player)
  52.  
  53. showGameState (GameState player1 player2 board steps weight1 weight2 time
  54.                       numbersteps promptString next_player) =
  55.   xMArrayToList board >>= \ board_lst ->
  56.   xMArrayToList weight1 >>= \ weight1_lst ->
  57.   xMArrayToList weight2 >>= \ weight2_lst ->
  58.   xMArrayToList steps >>= \ steps_lst ->
  59.   xMArrayToList player1 >>= \ player1_lst ->
  60.   xMArrayToList player2 >>= \ player2_lst ->
  61.   xMArrayToList time >>=  \ time_lst ->
  62.   xMArrayToList numbersteps >>= \ numbersteps_lst ->
  63.   xMArrayToList promptString >>= \ promptString_lst ->
  64.   xMArrayToList next_player >>= \ next_player_lst ->
  65.   let
  66.     str =(shows board_lst .
  67.           shows weight1_lst .
  68.           shows weight2_lst .
  69.           shows steps_lst .
  70.           shows player1_lst .
  71.           shows player2_lst .
  72.           shows time_lst .
  73.           shows numbersteps_lst .
  74.           shows promptString_lst .
  75.           shows next_player_lst) []
  76.   in
  77.   return str
  78.  
  79.                    
  80. xMod      :: Int -> Int -> Int
  81. xMod x y | x >= y      = xMod (x-y) y 
  82.          | otherwise   = x
  83.  
  84. xRes      :: Int -> Int -> Int -> Int
  85. xRes x y z | x >= y     = xRes (x-y) y (z+1) 
  86.            | otherwise = z
  87.  
  88. drawCmd :: String -> XInfo -> GameState -> IO ()
  89. drawCmd a (XInfo display window gcontext gcontext2 gcontextp)
  90.           (GameState _ _ _ _ _ _ _ _ str _)
  91.            = xDrawRectangle (XDrawWindow window) gcontext2
  92.                 (XRect 616 536 248 28) True >>= \ () ->
  93.              xDrawGlyphs (XDrawWindow window) gcontext 
  94.                          (XPoint 620 550) a  >>
  95.              xMArrayUpdate str 0 a >>
  96.              xDisplayForceOutput display
  97.  
  98. clearCmd :: XInfo -> GameState -> IO ()
  99. clearCmd (XInfo display window gcontext gcontext2 gcontextp)
  100.          (GameState _ _ _ _ _ _ _ _ str _)
  101.           = xDrawRectangle (XDrawWindow window) gcontext2
  102.                 (XRect 616 536 248 28) True >>= \() ->
  103.             xMArrayUpdate str 0 "" >>
  104.             xDisplayForceOutput display 
  105.  
  106. xPosition :: Int -> XPoint
  107. xPosition  a = (XPoint (xRes a 19 1) (1+ (xMod a 19)))
  108.  
  109. initArray :: XMArray a -> Int -> Int -> a -> IO ()
  110. initArray mary x y z | x<y       = xMArrayUpdate mary x z >>= \() ->
  111.                                    initArray mary (x+1) y z
  112.                      | otherwise = return ()
  113.  
  114. getposition :: Int -> Int -> XMaybe (Int, Int)
  115. getposition x y = let x1 = round ((fromIntegral x) / 30.0)
  116.                       y1 = round ((fromIntegral y) / 30.0)
  117.                   in
  118.                   if (x1 < 1 || x1 > 19 || y1 < 1 || y1 > 19) then XNull
  119.                   else XSome (x1, y1)
  120.  
  121. addZero :: Int -> String
  122. addZero a | a < 10    = "0"
  123.           | otherwise =  ""
  124.  
  125. printTime :: Int -> Int -> [Int] -> XInfo -> IO()
  126. printTime x y zs (XInfo display window gcontext gcontext2 gcontextp)
  127.            = let s = head zs
  128.                  m = head (tail zs)
  129.                  h = head (tail (tail zs))
  130.              in  xDrawRectangle (XDrawWindow window) gcontext2 
  131.                      (XRect (x-4) (y-24) 88 28) True >>= \() ->
  132.                  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint x y)
  133.                     ((addZero h)++(show h)++":"++(addZero m)++(show m)++
  134.                           ":"++(addZero s)++(show s)) >>
  135.                  xDisplayForceOutput display
  136.  
  137. showtime :: Int -> Int -> Integer -> XInfo -> IO()
  138. showtime x y z a = 
  139.   let (curtm, c) = (decodeTime z (WestOfGMT 0))
  140.   in  printTime x y curtm a
  141.  
  142. helpButton :: XInfo -> IO ()
  143. helpButton (XInfo display window  gcontext gcontext2 gcontextp) = 
  144.         xDrawRectangle (XDrawWindow window) gcontext (XRect 800 420 70 70)
  145.                        False >>
  146.         xDrawRectangle (XDrawWindow window) gcontext (XRect 802 422 66 66)
  147.                        False >>
  148.         xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 810 450) "About" 
  149.         >>
  150.         xDrawGlyphs (XDrawWindow window) gcontext (XPoint 820 470) "Gobang" 
  151.         >>
  152.         return ()
  153.  
  154. ishelp :: Int -> Int -> Bool
  155. ishelp x y = (x > 800 && x < 870 && y > 420 && y < 490)
  156.  
  157. button :: Int -> Int -> String -> XInfo -> IO()
  158. button x y a (XInfo display window  gcontext gcontext2 gcontextp) = 
  159.         xDrawArc (XDrawWindow window) gcontext 
  160.           (XArc (x-40) (y-10) 20 20 1.5708 4.7124) True  >>= \() ->
  161.         xDrawRectangle (XDrawWindow window) gcontext 
  162.           (XRect (x-30) (y-10) 60 20) True  >>= \() ->
  163.         xDrawArc (XDrawWindow window) gcontext
  164.           (XArc (x+20) (y-10) 20 20 (-1.0) 6.283) True >>= \() ->
  165.         xDrawGlyphs (XDrawWindow window) gcontext2 
  166.           (XPoint (x-(length a * 3)) (y+4)) a   >>
  167.         xDisplayForceOutput display
  168.  
  169. -- a b are the location of the button, c d are the point where we press the
  170. -- button.
  171.  
  172. buttonPress :: Int -> Int -> Int -> Int -> Bool
  173. buttonPress a b c d | (abs (c-a))<=30 && (abs (d-b))<=10   = True
  174.                     | (c-a+30)*(c-a+30)+(d-b)*(d-b)<=100   = True
  175.                     | (c-a-30)*(c-a-30)+(d-b)*(d-b)<=100   = True
  176.                     | otherwise                            = False
  177.  
  178.  
  179.  
  180. randmax :: XMArray Int -> Int -> Int -> [Int] -> IO Int
  181. randmax a ind max mi | ind > 360  = 
  182.                        let lmi = length mi
  183.                        in case lmi of
  184.                           0 -> return (-1)
  185.                           1 -> return (head mi)
  186.                           _ -> random lmi >>= \ i ->
  187.                                return (mi !! i)
  188.                      | otherwise  = xMArrayLookup a ind >>= \ tt3 ->
  189.                                     if (tt3 > max) 
  190.                                     then randmax a (ind+1) tt3 [ind]
  191.                                     else if (tt3 == max) 
  192.                                          then randmax a (ind+1) max (ind:mi)
  193.                                          else randmax a (ind+1) max mi
  194.  
  195. robot :: XMArray Int -> XMArray Int -> XMArray Int -> IO XPoint
  196. robot numbersteps weight1 weight2
  197.       = xMArrayLookup numbersteps 0 >>= \(tt5) ->
  198.         if (tt5 == 0)
  199.            then return (XPoint 10 10)
  200.            else
  201.         randmax weight1 0 0 [] >>= \ tmp1 ->
  202.         randmax weight2 0 0 [] >>= \ tmp2 ->
  203.         xMArrayLookup weight1 tmp1 >>= \ tmp3 ->
  204.                 xMArrayLookup weight2 tmp2 >>= \ tmp4 ->
  205.                   if (tmp3 >= 200) 
  206.                       then return (xPosition tmp1)
  207.                       else if (tmp3 > tmp4)
  208.                                then return (xPosition tmp1)
  209.                                else return (xPosition tmp2)
  210.  
  211.  
  212. promptFor prompt xinfo state =
  213.   let (GameState player1 player2 board steps weight1 weight2 time
  214.                  numbersteps promptString next_player) = state
  215.       (XInfo display window gcontext gcontext2 gcontextp) = xinfo
  216.   in
  217.   xDrawRectangle (XDrawWindow window) gcontext2
  218.                  (XRect 616 536 248 28) True >>
  219.   xMArrayUpdate promptString 0 prompt >> 
  220.   xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) prompt >>
  221.   xDisplayForceOutput display >>
  222.   let h_base = (length prompt + 1) * 6 + 620
  223.       getString :: Int -> String -> IO String
  224.       getString h_pos sofar =
  225.         xGetEvent display >>= \event ->
  226.         case (xEventType event) of
  227.           XButtonPressEvent -> 
  228.             let (XPoint x y) = xEventPos event
  229.             in 
  230.             (if ishelp x y then helpGame xinfo state 
  231.              else xBell display 0)
  232.             >>
  233.             getString h_pos sofar
  234.           XExposureEvent -> 
  235.             may_redraw (xEventCount event == 0) xinfo state >>
  236.             xDrawGlyphs (XDrawWindow window) gcontext (XPoint h_base 550) sofar
  237.             >>
  238.             xDrawRectangle (XDrawWindow window) gcontext
  239.                            (XRect (h_base + 6 * h_pos) (550-10) 6 13) True
  240.             >> getString h_pos sofar
  241.           XKeyPressEvent -> 
  242.             let code = xEventCode event
  243.                 state = xEventState event
  244.                 bs = if (sofar == "") then getString h_pos sofar
  245.                      else xDrawRectangle (XDrawWindow window) gcontext2 
  246.                                          (XRect (h_base + 6 * h_pos) 
  247.                                                 (550-10) 6 13) 
  248.                                          True >>
  249.                           xDrawRectangle (XDrawWindow window) gcontext 
  250.                                          (XRect (h_base + 6 * (h_pos - 1)) 
  251.                                                 (550-10) 6 13) 
  252.                                          True >> 
  253.                           getString (h_pos-1) (take (length sofar - 1) sofar) 
  254.             in  
  255.             xKeycodeCharacter display code state >>= \ char ->
  256.             case char of
  257.                (XSome '\r') -> return sofar
  258.                (XSome '\DEL') -> bs
  259.                (XSome '\BS') -> bs
  260.                XNull     -> getString h_pos sofar
  261.                (XSome c) -> xDrawRectangle (XDrawWindow window) gcontext2 
  262.                                            (XRect (h_base + 6 * h_pos) 
  263.                                                   (550-10) 6 13) 
  264.                                            True >> 
  265.                             xDrawGlyph (XDrawWindow window) gcontext
  266.                                        (XPoint (h_base + 6 * h_pos) 550) c >>
  267.                             xDrawRectangle (XDrawWindow window) gcontext 
  268.                                            (XRect (h_base + 6 * (h_pos + 1)) 
  269.                                                   (550-10) 6 13) 
  270.                                            True >> 
  271.                             getString (h_pos + 1) (sofar ++ [c])
  272.  
  273.   in 
  274.   xDrawRectangle (XDrawWindow window) gcontext
  275.                  (XRect h_base (550-10) 6 13) True >>
  276.   getString 0 ""
  277.  
  278.  
  279. helpGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) state =
  280.   drawHelp xinfo >>
  281.   let
  282.     loop xinfo state = 
  283.       xGetEvent display >>= \ event ->
  284.       case (xEventType event) of
  285.         XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state >>
  286.                           drawHelp xinfo >>
  287.                           loop xinfo state
  288.         XButtonPressEvent -> 
  289.                           let (XPoint x y) = xEventPos event
  290.                           in
  291.                           if (x > 200 && x < 300 && y > 230 && y < 290) 
  292.                           then redraw xinfo state >> 
  293.                                return ()
  294.                           else loop xinfo state
  295.         _              -> xBell display 0 >>
  296.                           loop xinfo state
  297.   in
  298.   loop xinfo state
  299.  
  300.  
  301.  
  302.