blank-canvas-0.6: wiki-suite/Tic_Tac_Toe.hs

{-# LANGUAGE OverloadedStrings #-}
module Tic_Tac_Toe where

import           Control.Concurrent -- wiki $

import qualified Data.Map as Map
import           Data.Map (Map)
import           Data.Text (Text)

-- import           Debug.Trace

import           Graphics.Blank

import           Wiki -- (512,384)

main :: IO ()
main = blankCanvas 3000 { events = ["mousedown"] } $ \ context -> loop context Map.empty X

data XO = X | O  deriving (Eq,Ord,Show)

swap :: XO -> XO
swap X = O
swap O = X

loop :: DeviceContext -> Map (Int, Int) XO -> XO -> IO ()
loop context board turn = do
        sz <- send context $ do
                clearRect (0,0,width context,height context)
                beginPath()

                let sz = min (width context) (height context)
                save()
                translate (width context / 2,height context / 2)
                sequence_ [ do bigLine (-sz * 0.45,n) (sz * 0.45,n)
                               bigLine (n,-sz * 0.45) (n,sz * 0.45)
                          | n <- [-sz * 0.15,sz * 0.15]
                          ]


                sequence_ [ do save()
                               translate (fromIntegral x * sz * 0.3,fromIntegral y * sz * 0.3)
                               case Map.lookup (x,y) board of
                                  Just X -> drawX (sz * 0.1)
                                  Just O -> drawO (sz * 0.1)
                                  Nothing -> return ()
                               restore()
                          | x <- [-1,0,1]
                          , y <- [-1,0,1]
                          ]
                restore()
                return sz

        let pointToSq :: (Double, Double) -> Maybe (Int, Int)
            pointToSq (x,y) = do
                    x' <- fd ((x - width context / 2) / sz)
                    y' <- fd ((y - height context / 2) / sz)
                    return (x',y')

            fd x = 
--                    trace (show ("fx",x,r)) $
                    if r `elem` [-1..1] then Just (signum r) else Nothing
                where r = round (x * 3.3333)

        let press = (width context / 2 + fromIntegral x * (sz / 4),height context / 2 + fromIntegral y * (sz / 4)) -- wiki $
                where (x,y) = head [ ix | (ix,Nothing)                                   -- wiki $
                                                 <- [ ((x',y'),Map.lookup (x',y') board) -- wiki $
                                                    | y' <- [-1,0,1]                     -- wiki $
                                                    , x' <- [-1,0,1]                     -- wiki $
                                                    ]]                                   -- wiki $

        _ <- wiki $ forkIO $ send context $ trigger $ Event {
              eMetaKey = False
            , ePageXY = return $ press
            , eType = "keypress"
            , eWhich = Nothing
        }
        event <- wait context

        file <- wiki $ anim_png "Tic_Tac_Toe"
        wiki $ snapShot context $ file
        wiki $ whenM (Map.size board == 7) $ do { build_anim "Tic_Tac_Toe" 100; close context ; quit }

        print event
        case ePageXY event of
           -- if no mouse location, ignore, and redraw
           Nothing -> loop context board turn
           Just (x',y') -> case pointToSq (x',y') of
                             Nothing -> loop context board turn
                             Just pos -> case Map.lookup pos board of
                                           Nothing -> loop context
                                                            (Map.insert pos turn board)
                                                            (swap turn)
                                                    -- already something here
                                           Just _ -> loop context board turn

xColor, oColor, boardColor :: Text
xColor = "#ff0000"
oColor = "#00a000"
boardColor = "#000080"

drawX :: Double -> Canvas ()
drawX size = do
        strokeStyle xColor
        lineCap "butt"
        beginPath()
        moveTo(-size,-size)
        lineTo(size,size)
        lineWidth 10
        stroke()
        beginPath()
        moveTo(-size,size)
        lineTo(size,-size)
        lineWidth 10
        stroke()

drawO :: Double -> Canvas ()
drawO radius = do
        beginPath()
        arc(0, 0, radius, 0, 2 * pi, False)
        lineWidth 10
        strokeStyle oColor
        stroke()

bigLine :: (Double, Double) -> (Double, Double) -> Canvas ()
bigLine (x,y) (x',y') = do
        beginPath()
        moveTo(x,y)
        lineTo(x',y')
        lineWidth 20
        strokeStyle boardColor
        lineCap "round"
        stroke()