module HRDgraphics where
 
import GraphicsUtils
import "solver.hs"
--import "HRDsolver.hs"

panelHeight = 650 :: Int
panelWidth = 500 :: Int
unitPieceSize = 100 :: Int
boardHeight = unitPieceSize * 5 :: Int
boardWidth = unitPieceSize * 4 :: Int
verticalMargin = 50 :: Int
horizontalMargin = 50 :: Int
shift = 4 :: Int
pieceMargin = 1 :: Int

main :: IO()
main
  = runGraphics $ do
    w <- openWindow "Game Window" (panelWidth, panelHeight)
    drawBoard w
    drawPieces w start
    drawButton w
    getInput w
    closeWindow w
  where
    drawBoard w =
      drawInWindow w $
        overGraphics
        [ withColor Green $
          --mkFont (50,100) (pi/4) False True "courier" $ \ font ->
          --withFont font $
          text (horizontalMargin, panelHeight - 70)
               "Hua Rong Dao"
        , text (horizontalMargin, panelHeight - 50)
               "- Copyright @ Hai Fang, 2001"
        , withColor Black $
          polygon [ (horizontalMargin + unitPieceSize,
                     verticalMargin + boardHeight)
                  , (horizontalMargin + unitPieceSize * 3,
                     verticalMargin + boardHeight)
                  , (horizontalMargin + unitPieceSize * 3,
                     verticalMargin + boardHeight + shift + 1)
                  , (horizontalMargin + unitPieceSize,
                     verticalMargin + boardHeight + shift + 1)
                  ]
        , withColor Green $
          polyline [ (horizontalMargin - 1, verticalMargin - 1)
                   , (horizontalMargin + boardWidth + 1, verticalMargin - 1)
                   , (horizontalMargin + boardWidth + 1,
                        verticalMargin + boardHeight + 1)
                   , (horizontalMargin - 1, verticalMargin + boardHeight + 1)
                   , (horizontalMargin - 1, verticalMargin - 1)
                   ]
        , withColor Green $
          polyline [ (horizontalMargin - shift, verticalMargin - shift)
                   , (horizontalMargin + boardWidth + shift,
                      verticalMargin - shift)
                   , (horizontalMargin + boardWidth + shift,
                      verticalMargin + boardHeight + shift)
                   , (horizontalMargin - shift,
                      verticalMargin + boardHeight + shift)
                   , (horizontalMargin - shift, verticalMargin - shift)
                   ]
        ]
    drawPieces w c
      = do
        drawDonkey w c
        drawSquares w c
        drawHoriz w c
        drawVertics w c
        drawEmpties w c
    drawPiece w x y wd ht c
      = let posX1 = horizontalMargin + x * unitPieceSize
            posY1 = verticalMargin + y * unitPieceSize
            posX2 = horizontalMargin + (x + wd) * unitPieceSize
            posY2 = verticalMargin + (y + ht) * unitPieceSize
            posX1' = posX1 + pieceMargin
            posY1' = posY1 + pieceMargin
            posX2' = posX2 - pieceMargin
            posY2' = posY2 - pieceMargin
         in drawInWindow w $
              overGraphics
              [ withColor c $
                polygon [ (posX1', posY1')
                        , (posX2', posY1')
                        , (posX2', posY2')
                        , (posX1', posY2')
                        ]
              , withColor Black $
                polygon [ (posX1, posY1)
                        , (posX2, posY1)
                        , (posX2, posY2)
                        , (posX1, posY2)
                        ]
              ]
    getPos c = ((c - 1) `mod` 10, c `div` 10 - 1)           
    drawDonkey w c
      = let (x, y) = getPos (donkey (snd c))
         in drawPiece w x y 2 2 Red     
    drawHoriz w c
      = let (x, y) = getPos (horiz (snd c))
         in drawPiece w x y 2 1 Blue
    drawSquares w c
      = drawSquare (squares (snd c))
        where
          drawSquare []  = error "no squares"
          drawSquare [h]
            = let (x, y) = getPos h
               in drawPiece w x y 1 1 Blue 
          drawSquare (h : t)
            = let (x, y) = getPos h
               in do drawPiece w x y 1 1 Blue
                     drawSquare t

    drawVertics w c
      = drawVertic (vertics (snd c))
        where
          drawVertic []  = error "no vertics"
          drawVertic [h]
            = let (x, y) = getPos h
               in drawPiece w x y 1 2 Blue
          drawVertic (h : t)
            = let (x, y) = getPos h
               in do drawPiece w x y 1 2 Blue
                     drawVertic t

    drawEmpties w c
      = let (x1, y1) = getPos (fst (fst c))
            (x2, y2) = getPos (snd (fst c))
         in do
              drawPiece w x1 y1 1 1 Black
              drawPiece w x2 y2 1 1 Black

    drawButton w
      = drawSolve1 w

    drawSolve1 w
      = let posX   = panelWidth - horizontalMargin - 25
            posY   = panelHeight - 50
            posCX1 = posX - 25
            posCY1 = posY - 25
            posCX2 = posX + 25
            posCY2 = posY + 25
         in drawInWindow w $
              overGraphics
              [ withColor Red $
                text (posX - 21, posY - 5) "start"
              , withColor Yellow $
                ellipse (posCX1, posCY1) (posCX2, posCY2)
              ]

    drawSolve2 w
      = let posX   = panelWidth - horizontalMargin - 25
            posY   = panelHeight - 50
            posCX1 = posX - 25
            posCY1 = posY - 25
            posCX2 = posX + 25
            posCY2 = posY + 25
         in drawInWindow w $
              overGraphics
              [ withColor Red $
                text (posX - 13, posY - 7) "..."
              , withColor Yellow $
                ellipse (posCX1, posCY1) (posCX2, posCY2)
              ]

    drawSolve3 w
      = let posX   = panelWidth - horizontalMargin - 25
            posY   = panelHeight - 50
            posCX1 = posX - 25
            posCY1 = posY - 25
            posCX2 = posX + 25
            posCY2 = posY + 25
         in drawInWindow w $
              overGraphics
              [ withColor Red $
                text (posX - 19, posY - 5) "quit"
              , withColor Yellow $
                ellipse (posCX1, posCY1) (posCX2, posCY2)
              ]

    drawPlay w
      = let posX   = panelWidth - horizontalMargin - 25
            posY   = panelHeight - 50
            posCX1 = posX - 25
            posCY1 = posY - 25
            posCX2 = posX + 25
            posCY2 = posY + 25
            posTX1 = posX - 8
            posTY1 = posY - 12
            posTX2 = posX + 12
            posTY2 = posY
         in drawInWindow w $
              overGraphics
              [ withColor Red $
                polygon [ (posTX1, posTY1)
                        , (posTX2, posTY2)
                        , (posTX1, posTY2 * 2 - posTY1)
                        ]
              , withColor Yellow $
                ellipse (posCX1, posCY1) (posCX2, posCY2)
              ]

    drawSolution w [] _ _ = return 0
    drawSolution w (m : ms) c step
      = let c1 = appMove c m
            p = getPiece1 (fst m) (snd c1)
         in do
              drawEmpties w c1
              drawMovingPiece w p c1
              drawStepNum w step
              loopn 30000
              drawSolution w ms c1 (step + 1)
        where
          drawMovingPiece w p c1
            = case p of
                Donkey -> drawDonkey w c1
                Horiz  -> drawHoriz w c1
                Square ->
                  let (x, y) = getPos (fst m)
                   in drawPiece w x y 1 1 Blue
                Vertic ->
                  let b = case snd m of
                            ToDown -> (fst m - 10)
                            _ -> fst m
                      (x, y) = getPos b
                   in drawPiece w x y 1 2 Blue

          getPiece1 cell board
            | donkey board - cell == 0   = Donkey
            | donkey board - cell == -1  = Donkey
            | donkey board - cell == -10 = Donkey
            | donkey board - cell == -11 = Donkey
            |  horiz board - cell == 0   = Horiz
            |  horiz board - cell == -1  = Horiz
            | elem cell (squares board)  = Square
            | elem cell (vertics board)  = Vertic
            | elem (cell - 10) (vertics board)  = Vertic

          drawStepNum w n
            = let posX = panelWidth - horizontalMargin - 25
                  posY = panelHeight - 50
                  posCX1 = posX - 25
                  posCY1 = posY - 25
                  posCX2 = posX + 25
                  posCY2 = posY + 25
                  shiftX | n `div` 100 > 0 = 12
                         | n `div` 10  > 0 = 8
                         | n < 10          = 4
               in drawInWindow w $
                  overGraphics
                    [ withColor Red $
                      text (posX - shiftX, posY - 5) (show n)
                    , withColor Yellow $
                      ellipse (posCX1, posCY1) (posCX2, posCY2)
                    ]

          loopn 0 = return 0
          loopn n = loopn (n - 1)

    getInput w
      = loop
          where
            loop  = do
                    e <- getWindowEvent w
                    case e of
                      Button {pt, isLeft, isDown}
                        | isLeft == True && isDown == True && inArea pt
                        -> do
                             drawPlay w
                             return solve
                             loop1 
                        | isLeft == False && isDown == True
                        -> return 0
                      _ -> loop

            loop1 = do
                    e <- getWindowEvent w
                    case e of
                      Button {pt, isLeft, isDown}
                        | isLeft == True && isDown == True && inArea pt
                        -> do
                             drawSolve2 w
                             drawSolution w (reverse (fst solve)) start 1
                             drawSolve3 w
                             loop2
                      _ -> loop1

            loop2 = do
                    e <- getWindowEvent w
                    case e of
                      Button {pt, isLeft, isDown}
                        | isLeft == True && isDown == True && inArea pt
                        -> return 0
                        | isLeft == False && isDown == True
                        -> return 0
                      _ -> loop2

            inArea (x, y)
              = let posX = panelWidth - horizontalMargin - 25
                    posY = panelHeight - 50
                 in    (x <= posX + 25) && (x >= posX - 25)
                    && (y <= posY + 25) && (y >= posY - 25)

            solve = solveHRD start okStatus