{-# LANGUAGE
      GADTs
    , MultiParamTypeClasses
    , OverloadedLabels
    , OverloadedStrings
    , TemplateHaskell
    , ViewPatterns
  #-}
-- | SAT based Soccer Simulator/ Game
--
-- TODO
--
module Main (main) where

import Control.Lens hiding (set)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (runReaderT)
import qualified Data.Vector as V
import Data.IORef
import Data.Maybe
import Data.List
import Data.Text (pack)

import Data.GI.Base
import qualified GI.Cairo as GI.Cairo
import qualified GI.GLib as GLib
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk

import Graphics.Rendering.Cairo
import Graphics.Rendering.Cairo.Internal (Render(runRender))
import Graphics.Rendering.Cairo.Types (Cairo(Cairo))
import Foreign.Ptr (castPtr)

import Numeric (showFFloat)
import System.Console.GetOpt
import System.Environment (getArgs)
import System.Exit

import Satter.TwoD
import Satter.Field
import Satter.Types
import Satter.Ball
import Satter.PlayerSAT
import Satter.Player

programName :: String
programName = "SATter 0.5.1"

data WindowLayout = Portrait | Landscape

timerInterval :: Int
timerInterval = 25

breakPeriod :: Int
breakPeriod = 180

layoutDefault :: WindowLayout
layoutDefault = Landscape

data ConfigurationOption = ConfigurationOption
                           {
                             _useSAT       :: Int
                           , _solverLoop   :: Int
                           , _testRun      :: Int
                           , _randomSeed   :: Double
                           , _layout       :: WindowLayout
                           , _windowScale  :: Double
                           , _autoRestart  :: Bool
                           , _debugMessage :: Bool
                           , _dumpRule     :: Maybe FilePath
                           , _dumpCNF      :: Maybe FilePath
                           , _displayHelp  :: Bool
                           }

makeLenses ''ConfigurationOption

defaultConfigration :: ConfigurationOption
defaultConfigration = ConfigurationOption 0 1 0 270 Landscape 1 True False Nothing Nothing False

options :: [OptDescr (ConfigurationOption -> ConfigurationOption)]
options =
  [
    Option ['S'] ["use-SAT"]
     (ReqArg (\v c -> c & useSAT .~ read v) (show (defaultConfigration ^. useSAT)))
    "the number of SAT controlled players"
  , Option ['L'] ["solver-loop"]
     (ReqArg (\v c -> c & solverLoop .~ read v) (show (defaultConfigration ^. solverLoop)))
    "the number of SAT solver iteration"
  , Option ['t'] ["testrun-seconds"]
     (ReqArg (\v c -> c & testRun .~ div (1000 * read v) timerInterval) (show (defaultConfigration ^. testRun)))
    "display stastics after a dumb simulation [second]"
  , Option ['T'] ["testrun"]
     (ReqArg (\v c -> c & testRun .~ read v) (show (defaultConfigration ^. testRun)))
    "display stastics after a dumb simulation [tick]"
  , Option ['r'] ["randomize-seed"]
     (ReqArg (\v c -> c & randomSeed .~ read v) (show (defaultConfigration ^. randomSeed)))
    "display stastics after a dumb simulation [tick]"
  , Option ['l'] ["landscape"]
     (NoArg (\c -> c & layout .~ Landscape))
    "use landscape mode"
  , Option ['p'] ["portrait"]
     (NoArg (\c -> c & layout .~ Portrait))
    "use portrait mode"
  , Option ['s'] ["scale"]
     (ReqArg (\v c -> c & windowScale .~ max 0.25 (read v)) (show (defaultConfigration ^. windowScale)))
    "display scale"
  , Option ['a'] ["auto-restart"]
    (ReqArg (\v c -> c & autoRestart .~ read v) (show (defaultConfigration ^. autoRestart)))
    "restart automatically when the ball is out of field"
  , Option ['d'] ["debug"]
    (NoArg (\c -> c & debugMessage .~ True))
    "display debug message on console"
  , Option ['D'] ["dump-cnf"]
    (ReqArg (\v c -> c & dumpCNF .~ Just v) "")
    "dump the CNF to a file or not"
  , Option ['R'] ["dump-rule"]
    (ReqArg (\v c -> c & dumpRule .~ Just v) "")
    "dump the rules to a file or not"
  , Option ['h'] ["help"]
    (NoArg (\c -> c & displayHelp .~ True))
    "display this help message"
  ]

usage :: String
usage = "Usage: satter [-[lp]] [-S n] [-L n] [-t n] [-d] [-a] [--help]"

parseOptions :: [String] -> IO ConfigurationOption
parseOptions argv =
    case getOpt Permute options argv of
      (o, [], []) -> return $ foldl (flip id) defaultConfigration o
      (_, _, errs) -> ioError (userError (concat errs ++ usageInfo usage options))

-- | This function bridges gi-cairo with the hand-written cairo
-- package. It takes a `GI.Cairo.Context` (as it appears in gi-cairo),
-- and a `Render` action (as in the cairo lib), and renders the
-- `Render` action into the given context.
renderWithContext :: GI.Cairo.Context -> Render () -> IO ()
renderWithContext ct r = withManagedPtr ct $ \p ->
                         runReaderT (runRender r) (Cairo (castPtr p))

main :: IO ()
main = do
    args <- getArgs
    conf <- parseOptions args
    when (conf ^. displayHelp) $ do
      putStrLn $ usageInfo usage options
      exitFailure
    unless (conf ^. dumpRule == Nothing) $ do
      let (Just f) = conf ^. dumpRule
      print cnfInfo
      dumpTheRule f
      putStrLn $ "the CNF for rules was saved to " ++ f
      exitSuccess
    g <- initializeGameContext conf (conf ^. randomSeed) defaultGameContext
    unless (conf ^. dumpCNF == Nothing) $ do
      -- print cnfInfo
      let (Just f) = conf ^. dumpCNF
      dumpTheCNF f g
      putStrLn $ "the CNF file was saved to " ++ f
      exitSuccess
    gameRef <- newIORef g
    when (0 < conf ^. testRun) $ do
      putStrLn "starting a dumb mode simulation"
      updateWorld conf gameRef (undefined :: Gtk.Window) >> return ()
      exitSuccess
    Gtk.init Nothing
    window <- new Gtk.Window  [ #title := pack programName, #appPaintable := True, #defaultWidth := 200, #defaultHeight := 200 ]

    hb <- new Gtk.HeaderBar [ #title := pack programName, #showCloseButton := True ]
    Gtk.windowSetTitlebar window (Just hb)

    restart <- new Gtk.Button [ #label := "リスタート", #tooltipText := "Restart the game"]
    on restart #clicked $ do
      g <- readIORef gameRef
      let t = _time g
      let hasBeenRun = _runMode g
      g' <- initializeGameContext conf (fromIntegral t) g
      writeIORef gameRef $ g' &~ do time .= t + 1; debug .= g ^. debug; runMode .= True
      unless hasBeenRun $ GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window) >> return ()
    #packEnd hb restart

    im <- Gtk.imageNewFromIconName (Just "media-playback-pause") (fromIntegral (fromEnum Gtk.IconSizeButton))
    pause <- new Gtk.Button [ #image := im, #tooltipText := "Stop the game"] -- #label := "一時停止"
    on pause #clicked $ do
      g <- readIORef gameRef
      let (a, b) = _score g
      let hasBeenRun = _runMode g
      writeIORef gameRef $ g & runMode .~ not hasBeenRun
      set window [ #title := pack (if hasBeenRun then programName else "Team Blue " ++ show a ++ " - Team Red " ++ show b) ]
      unless hasBeenRun $ GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window) >> return ()
    #packEnd hb pause

    grid <- Gtk.gridNew
    Gtk.gridSetRowHomogeneous grid False
    Gtk.gridSetColumnHomogeneous grid False
    Gtk.gridSetRowSpacing grid 0
    Gtk.gridSetColumnSpacing grid 0
    Gtk.containerAdd window grid

    da <- Gtk.drawingAreaNew
    let s = conf ^. windowScale
    case conf ^. layout of
      Landscape -> Gtk.widgetSetSizeRequest da (ceiling $ s * (fheight + 2 * fvmargin)) (ceiling $ s * (fwidth + 2 * fhmargin))
      Portrait -> Gtk.widgetSetSizeRequest da (ceiling $ s * (fwidth + 2 * fhmargin)) (ceiling $ s * (fheight + 2 * fvmargin))
    Gtk.gridAttach grid da 0 0 5 1

    button1 <- new Gtk.Button [ #label := "赤：パス主体", #tooltipText := "boring offensive mode that Japan likes"]
    Gtk.gridAttach grid button1 0 1 1 1
    button2 <- new Gtk.Button [ #label := "赤：積極的攻撃", #tooltipText := "dangerous approach to get a goal"]
    Gtk.gridAttach grid button2 1 1 1 1
    button3 <- new Gtk.Button [ #label := "説明モード", #tooltipText := "show verbose labels"]
    Gtk.gridAttach grid button3 2 1 1 1
    button4 <- new Gtk.Button [ #label := "青：積極的攻撃", #tooltipText := "dangerous approach to get a goal"]
    Gtk.gridAttach grid button4 3 1 1 1
    button5 <- new Gtk.Button [ #label := "青：パス主体", #tooltipText := "boring offensive mode that Japan likes"]
    Gtk.gridAttach grid button5 4 1 1 1

    on button1 #clicked $ do
      g <- readIORef gameRef
      writeIORef gameRef $ g &~ do team2 .= ((g ^. team2) & directorIntention .~ NoStrategy)
    on button2 #clicked $ do
      g <- readIORef gameRef
      writeIORef gameRef $ g &~ do team2 .= ((g ^. team2) & directorIntention .~ AggressiveAttack)
    on button4 #clicked $ do
      g <- readIORef gameRef
      writeIORef gameRef $ g &~ do team1 .= ((g ^. team1) & directorIntention .~ AggressiveAttack)
    on button5 #clicked $ do
      g <- readIORef gameRef
      writeIORef gameRef $ g &~ do team1 .= ((g ^. team1) & directorIntention .~ NoStrategy)

    on button3 #clicked $ do
      g <- readIORef gameRef
      writeIORef gameRef $ g & debug %~ not
    on window #keyPressEvent $ \event -> do
      k <- event `get` #keyval >>= Gdk.keyvalName
      case k of
           Just "i" -> liftIO $ do
             g <- readIORef gameRef
             let (a, b) = _score g
             let dx = fromIntegral (mod (div (_time g) 11) 10) / 10 - 0.45
             let dy = fromIntegral (mod (div (_time g) 7) 10) / 10 - 0.45
             let (Ball (Geometrics pos _ v) bp) = ballDefault
             writeIORef gameRef $ g &~ do
               runMode .= True
               ball .= Ball (Geometrics pos (dx, dy) v) bp; time .= 1
               players .= (V.map (\p -> p & intention .~ NoPlan) (g ^. players))
             set window [ #title := pack ("Team Blue " ++ show a ++ " - Team Red " ++ show b) ]
             unless (_runMode g) $ GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window) >> return ()
           Just "r" -> liftIO $ do
             g <- readIORef gameRef
             let t = _time g
             let (a, b) = _score g
             g' <- initializeGameContext conf (fromIntegral t) g
             writeIORef gameRef $ g' &~ do time .= t + 1; debug .= g ^. debug; score .= (a, b)
             set window [ #title := pack ("Team Blue " ++ show a ++ " - Team Red " ++ show b) ]
             unless (_runMode g) $ GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window) >> return ()
           Just "Shift_L" -> liftIO $ do
             g <- readIORef gameRef
             writeIORef gameRef $ g & debug %~ not
             unless (_runMode g) $ GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window) >> return ()
           Just "Control_L" -> liftIO $ do
             g <- readIORef gameRef
             let (a, b) = _score g
             let hasBeenRun = _runMode g
             writeIORef gameRef $ g & runMode .~ not hasBeenRun
             set window [ #title := pack (if hasBeenRun then programName else "Team Blue " ++ show a ++ " - Team Red " ++ show b) ]
             unless hasBeenRun $ GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window) >> return ()
           Just "q" -> liftIO Gtk.mainQuit
           Just "Escape" -> liftIO $ print "?" -- mainQuit
           _ -> liftIO $ print "?"
      return False

    on da #draw $ \context -> do
      renderWithContext context $ updateCairo conf gameRef
      return True

    on window #destroy Gtk.mainQuit
    GLib.timeoutAdd GLib.PRIORITY_DEFAULT (fromIntegral timerInterval) (wup conf gameRef window)
    #showAll window
    Gtk.main

initializeGameContext :: ConfigurationOption -> Double -> GameContext -> IO GameContext
initializeGameContext conf rad' g = do
  let used = g ^. usedSeeds
  let rad = fromIntegral (mod (ceiling rad') 3600) / 10
  let vec = fromIntegral (mod (ceiling rad') 29) / 23
  when (elem (rad, vec) used) $ do
    putStrLn $ "Simulation fell into a cycle after " ++ show (g ^. time) ++ " ticks"
    exitSuccess
  let
    pos t (x, y) = (fhmargin + fwidth / 2 + x * fromIntegral (1 - 2 * (fromEnum t - 1)), fvmargin + fheight / 2 + y * fromIntegral (1 - 2 * (fromEnum t -1)))
  let dir t = 90 + fromIntegral (fromEnum t -1) * 180
  -- V.write ob 0 $ Player geometricsDefault (PlayerProperty PlayerForward 0 0 0 NoPlan)
  let ps = flip map [Team1, Team2] $ \t ->
        [
          flip map (zip [1 .. ] [(-100, 80), (100, 80), (-180, 20), (180, 20), (0, 180)]) $ \(n, p) ->
           let
             roll = if (t == Team1) && n <= conf ^. useSAT then PlayerSAT else PlayerForward
             i = (fromEnum t - 1) * 11 + n
           in Player (Geometrics (pos t p) (asDirection (dir t)) 0.6) (PlayerProperty roll t n i (pos t p)) (GoFor 1 TargetBall)
        , flip map (zip [6 .. ] [(-130, 250), (130, 250), (-170, 270), (170, 270), (0,330)]) $ \(n, p) ->
           let
             i = (fromEnum t - 1) * 11 + n
             roll = if (t == Team1) && n <= conf ^. useSAT then PlayerSAT else PlayerDefence
           in Player (Geometrics (pos t p) (asDirection (dir t)) 0.7) (PlayerProperty roll t n i (pos t p)) NoPlan
        , flip map (zip [11] [(0, fheight / 2 - 10)]) $ \(n, p) ->
           let
             roll = if (t == Team1) && n <= conf ^. useSAT then PlayerSAT else PlayerKeeper
             i = (fromEnum t - 1) * 11 + n
           in Player (Geometrics (pos t p) (0.0,0.0) 0.8) (PlayerProperty roll t n i (pos t p)) NoPlan
        ]
  satP <- newIORef []
  let g = GameContext
          1                   -- elapsed time
          (Ball (Geometrics (positionOf ballDefault) (asDirection rad) vec) Nothing)
          (V.fromList (concatMap concat ps))
          True
          (TeamContext [1 .. 11] ([], []) NoStrategy (fhmargin + fwidth / 2, fvmargin) (-1))
          (TeamContext [12 .. 22] ([], []) NoStrategy (fhmargin + fwidth / 2, fvmargin + fheight) 1)
          (0, 0)
          (conf ^. debugMessage)
          0
          (conf ^. solverLoop)
          satP
          0
          (if 0 < conf ^. testRun then (rad, vec) : used else [])
  return g

wup :: ConfigurationOption -> IORef GameContext -> Gtk.Window -> IO Bool
wup conf game win = do
  g <- readIORef game
  res <- case () of
           _ | _runMode g && 0 < _suspendByGoal g -> breakByGoal game win
           _ | _runMode g -> updateWorld conf game win
           _ -> return False
  #queueDraw win
  return res

breakByGoal :: IORef GameContext -> Gtk.Window -> IO Bool
breakByGoal game win = do
  g <- readIORef game
  set win [ #title := pack ("The last goal was at " ++ show (g ^. time) ++ " tick")]
  liftIO $ writeIORef game $ g & suspendByGoal .~ (g ^. suspendByGoal - 1)
  return True

updateWorld :: ConfigurationOption -> IORef GameContext -> Gtk.Window -> IO Bool
updateWorld conf game win = do
  ballPos <- positionOf . _ball <$> readIORef game
  g <- readIORef game
  when (_holdBy (g ^. ball) == Nothing) $ writeIORef game (g & ball .~ (g ^. ball) <!! 1) >> return ()
  g <- readIORef game
  (Ball bg _) <- _ball <$> readIORef game
  let sorted = (map _idNumber . nearestPlayers (_position bg) . map (\p -> (_property p, positionOf p))) $ V.toList (g ^. players)
  forM_ sorted $ \i -> do
    g <- readIORef game
    when (inRegion ((fhmargin, fvmargin), (fwidth + fhmargin, fheight + fvmargin)) (positionOf (g ^. ball))) $ do
      tmp <- updatePhysics g =<< updateIntention g (nthPlayer g i)
      case tmp of
        Right player' -> do
          let ball'' = g ^. ball
          g <- readIORef game
          writeIORef game $ g & players .~ ((g ^. players) V.// [(i - 1, player')])
          -- Exception Handling 1: completely strange case
          case ball'' ^. holdBy of
            Nothing -> return ()
            Just nth -> do
              unless (near2 20 (positionOf (nthPlayer g nth)) (positionOf ball'')) $ do
                g <- readIORef game
                writeIORef game (g & ball . holdBy .~ Nothing)
        Left (player', ball') -> do
          writeIORef game $ g & players .~ ((g ^. players) V.// [(i - 1, player')])
          g <- readIORef game
          writeIORef game (g & ball .~ ball')
          -- Exception Handling 1: the ball holder lost intention
          case ball' ^. holdBy of
            Nothing -> return ()
            Just nth -> do
              let p'' = nthPlayer g nth
              unless (near2 20 (positionOf p'') (positionOf ball')) $ error $ "updateWorld: " ++ show (ball', p'')
              case player' ^. intention of
                Lost _ | nth == player' ^. property . idNumber -> do
                  -- when (player' ^. property . roll == PlayerSAT) $ print ("SAT lost intention", player')
                  g <- readIORef game
                  writeIORef game (g & ball . holdBy .~ Nothing)
                Lost _ -> error $ "strange combination: " ++ show (ball', player')
                -- _ | not (near2 40 (positionOf h) (positionOf ball')) -> print ("too far", h)
                _ -> return ()
  -- Exception Handling 1: if the ball is stopped and holded, then release!
  b <- _ball <$> readIORef game
  when ((positionOf b) == ballPos && Nothing /= b ^. holdBy) $ do
    let (Just i) = b ^. holdBy
    let player = nthPlayer g i
    case player ^. intention of
      Lost _ -> do
        let (Ball bg@(Geometrics (x, y) dir v) holder) = b
        writeIORef game $ g & ball .~ (b & holdBy .~ Nothing)
        let newPos = randomizePosition g (x, y) 1.1 1
        let newDir = randomizeDirection g (directionTo (x, y) newPos) 20 2
        writeIORef game $ g & ball .~ Ball (Geometrics newPos newDir 1) Nothing
      _ -> do writeIORef game $ g & players .~ ((g ^. players) V.// [(i - 1, player & intention .~ Lost 2)])
              return ()
  g <- readIORef game
  let b = _ball g
  -- Exception Handling 2: clouded case
  ps <- playersAt g (positionOf b) (2 * playerSize)
  when (find (\(_property -> _team -> t) -> t == Team1) ps /= Nothing && find (\(_property -> _team -> t) -> t == Team2) ps /= Nothing) $ do
    let (Ball bg@(Geometrics (x, y) dir v) holder) = b <!! 1
    g <- readIORef game
    let break = case holder of
          Just i | find (\(_property -> _idNumber -> n) -> n == i) ps /= Nothing -> case mod (_time g) 4 of
            n | 2 < n && i <= 11 -> 1
            n | 2 < n -> 2
            n -> n
          _ -> mod (_time g) 3
    case break of
      1 -> do
        when (holder == Nothing) $ do
          let got = _idNumber . _property . head $ filter (\(_property -> _team -> t) -> t == Team1) ps
          writeIORef game (g & ball .~ Ball bg (Just got))
      2 -> do
        when (holder == Nothing) $ do
          let got = _idNumber . _property . head $ filter (\(_property -> _team -> t) -> t == Team2) ps
          writeIORef game (g & ball .~ Ball bg (Just got))
      _ -> do
        let newPos = randomizePosition g (x, y) 30 1
        let newDir = randomizeDirection g (directionTo (x, y) newPos) 20 2
        writeIORef game $ g & ball .~ Ball (Geometrics newPos newDir 1) Nothing
    forM_  (map (_idNumber . _property) ps) $ \i -> do
      let (Player pg pp _) = nthPlayer g i
      g <- readIORef game
      unless (fromEnum (_team pp) == break) $ writeIORef game $ g & players .~ ((g ^. players) V.// [(i - 1, Player pg pp (Lost v))])

  ball' <- _ball <$> readIORef game
  let ballPos' = positionOf ball'
  let inGoal = gotInGoal ballPos ballPos'
  let inField = not $ outOfField ballPos'

  case inGoal of
    Just 1 -> do
      g <- readIORef game
      let t = _time g
      let (a, b) = _score g
      g' <- initializeGameContext conf (fromIntegral t) g
      writeIORef game $ g' &~ do
        time .= t + 1
        runMode .= conf ^. autoRestart
        debug .= _debug g
        score .= (a + 1, b)
        suspendByGoal .= if 0 < conf ^. testRun then 0 else breakPeriod
      when (0 < conf ^. testRun) $ do
        if conf ^. testRun <= t
          then do
              putStrLn $ "end of simulation: " ++ show (_score g')
              putStrLn $ "simulation ticks: " ++ show t
              exitSuccess
          else do
              putStrLn $ show (a + 1, b) ++ " -- goal by team 1 @ " ++ showFFloat (Just 2) (fromIntegral (t * timerInterval) / 1000 :: Double) " sec (" ++ show t ++ " tick)"
              updateWorld conf game win >> return ()
      set win [ #title := pack ("Team Blue " ++ show (a + 1) ++ " - Team Red " ++ show b) ]
      return $ conf ^. autoRestart
    Just 2 -> do
      g <- readIORef game
      let t = _time g
      let (a, b) = _score g
      g' <- initializeGameContext conf (fromIntegral t) g
      writeIORef game $ g' &~ do
        time .= t + 1
        runMode .= conf ^. autoRestart
        debug .= _debug g
        score .= (a, b + 1)
        suspendByGoal .= if 0 < conf ^. testRun then 0 else breakPeriod
      when (0 < conf ^. testRun) $ do
        if conf ^. testRun <= t
          then do
              putStrLn $ "end of simulation: " ++ show (_score g)
              putStrLn $ "simulatiton ticks: " ++ show t
              exitSuccess
          else do
              putStrLn $ show (a, b + 1)  ++ " -- goal by team 2 @ " ++ showFFloat (Just 2) (fromIntegral (t * timerInterval) / 1000 :: Double) " sec (" ++ show t ++ " ticks)"
              updateWorld conf game win >> return ()
      set win [ #title := pack("Team Blue " ++ show a ++ " - Team Red " ++ show (b + 1))]
      return $ conf ^. autoRestart
    Nothing | inField -> do
      g <- readIORef game
      let t' = g ^. time + 1
      writeIORef game $ g & time +~ 1
      when (0 < conf ^. testRun) $ do
        if conf ^. testRun <= t'
          then do
              putStrLn $ "end of simulation: " ++ show (g ^. score)
              putStrLn $ "simulation ticks: " ++ show t'
              exitSuccess
          else do
              updateWorld conf game win >> return ()
      return True
    _ -> do
      g <- readIORef game
      let t = g ^. time
      let (a, b) = g ^. score
      g' <- initializeGameContext conf (fromIntegral t) g
      writeIORef game $ g' &~ do
        time .= t + 1
        runMode .= conf ^. autoRestart
        debug .= g ^. debug
        score .= (a, b)
      when (0 < conf ^. testRun) $ do
        if conf ^. testRun <= t
          then do
              putStrLn $ "end of simulation: " ++ show (a, b)
              putStrLn $ "simulation ticks: " ++ show t
              exitSuccess
          else do
              updateWorld conf game win >> return ()
      set win [ #title := pack("Team Blue " ++ show a ++ " - Team Red " ++ show b) ]
      return $ conf ^. autoRestart

updateCairo :: ConfigurationOption -> IORef GameContext -> Render ()
updateCairo conf gRef = do
  g <- liftIO $ readIORef gRef
  -- scale 0.5 0.5 -- for mac
  drawField conf g
  V.mapM_ (drawPlayer conf g) $ g ^. players
  drawBall conf g (_ball g)
  when (50 < _suspendByGoal g) $ drawGoalScene conf g

drawField conf@(_layout -> Landscape) game = do
  let band = fheight / 18
  scale (conf ^. windowScale) (conf ^. windowScale)
  setSourceRGB 0.3 0.7 0.3 >> paint
  setSourceRGB 0.3 0.72 0.4
  forM_ [1, 3 .. 17] $ \i -> rectangle (fvmargin + i * band) 0 band (fwidth + 2 * fhmargin) >> fill
  setSourceRGB 0.9 0.9 0.9
  setLineWidth 2
  -- center line
  newPath >> moveTo (fheight / 2 + fvmargin) fhmargin >> lineTo(fheight / 2 + fvmargin) (fwidth + fhmargin) >> stroke
  -- pitch area
  rectangle fvmargin fhmargin fheight fwidth >> stroke
  -- top goal post
  rectangle 4 (fwidth / 2 + fhmargin - goalWidth / 2) 20 goalWidth >> stroke
  rectangle fvmargin (fwidth / 2 + fhmargin - goalWidth * 1.8 / 2) 45 (goalWidth * 1.8) >> stroke
  rectangle fvmargin (fwidth / 2 + fhmargin - goalWidth * 3 / 2) 135 (goalWidth * 3) >> stroke
  -- bottom goal post
  rectangle (fheight + fvmargin) (fwidth / 2 + fhmargin - goalWidth / 2) 20 goalWidth >> stroke
  rectangle (fheight + fvmargin - 45) (fwidth / 2 + fhmargin - goalWidth * 1.8 / 2) 45 (goalWidth * 1.8) >> stroke
  rectangle (fheight + fvmargin - 135) (fwidth / 2 + fhmargin - goalWidth * 3 / 2) 135 (goalWidth * 3) >> stroke
  -- center circle
  arc (fheight / 2.0 + fvmargin) (fwidth / 2.0 + fhmargin) 55 0 (2 * pi) >> stroke
  -- offside line
  let y = case game ^. ball . holdBy of
        Nothing -> (-1)
        Just k | elem k (_teammates (_team1 game)) -> (minimum . map (snd . snd) . filter ((PlayerKeeper /=) . _roll . fst) . snd) $ getPositions game
        Just k | elem k (_teammates (_team2 game)) -> (maximum . map (snd . snd) . filter ((PlayerKeeper /=) . _roll . fst) . fst) $ getPositions game
  when (0 < y) $ do
    setSourceRGB 1.0 0.4 0.5
    setLineWidth 1
    newPath >> moveTo y fhmargin >> lineTo y (fwidth + fhmargin) >> stroke

drawField conf@(_layout -> Portrait) game = do
  let band = fheight / 18
  scale (conf ^. windowScale) (conf ^. windowScale)
  setSourceRGB 0.3 0.7 0.3 >> paint
  setSourceRGB 0.3 0.72 0.4
  forM [1, 3 .. 17] $ \i -> do
    rectangle 0 (fvmargin + i * band) (fwidth + 2 * fhmargin) band >> fill
  setSourceRGB 0.9 0.9 0.9
  setLineWidth 2
  -- center line
  newPath >> moveTo fhmargin (fheight / 2 + fvmargin) >> lineTo (fwidth + fhmargin) (fheight / 2 + fvmargin) >> stroke
  -- pitch area
  rectangle fhmargin fvmargin fwidth fheight >> stroke
  -- top goal post
  rectangle (fwidth / 2 + fhmargin - goalWidth / 2) 4 goalWidth 20 >> stroke
  rectangle (fwidth / 2 + fhmargin - goalWidth * 1.8 / 2) fvmargin (goalWidth * 1.8) 45 >> stroke
  rectangle (fwidth / 2 + fhmargin - goalWidth * 3 / 2) fvmargin (goalWidth * 3) 135 >> stroke
  -- bottom goal post
  rectangle (fwidth / 2 + fhmargin - goalWidth / 2) (fheight + fvmargin) goalWidth 20 >> stroke
  rectangle (fwidth / 2 + fhmargin - goalWidth * 1.8 / 2) (fheight + fvmargin - 45) (goalWidth * 1.8) 45 >> stroke
  rectangle (fwidth / 2 + fhmargin - goalWidth * 3 / 2) (fheight + fvmargin - 135) (goalWidth * 3) 135 >> stroke
  -- center circle
  arc (fwidth / 2.0 + fhmargin) (fheight / 2.0 + fvmargin) 55 0 (2 * pi) >> stroke
  -- offside line
  let y = case game ^. ball . holdBy of
        Nothing -> (-1)
        Just k | elem k (_teammates (_team1 game)) -> (minimum . map (snd . snd) . filter ((PlayerKeeper /=) . _roll . fst) . snd) $ getPositions game
        Just k | elem k (_teammates (_team2 game)) -> (maximum . map (snd . snd) . filter ((PlayerKeeper /=) . _roll . fst) . fst) $ getPositions game
  when (0 < y) $ do
    setSourceRGB 1.0 0.4 0.5
    setLineWidth 1
    newPath >> moveTo fhmargin y >> lineTo (fwidth + fhmargin) y >> stroke

drawBall :: ConfigurationOption -> GameContext -> Ball -> Render ()
drawBall conf@(_layout -> Landscape) g (Ball (Geometrics (x, y) (dx, dy) v) holdBy) = do
  scale (conf ^. windowScale) (conf ^. windowScale)
  setSourceRGB 0.2 0.4 0.3 >> arc (y +2) (x + 3) (ballSize + 1) 0 (2 * pi) >> fill
  setSourceRGB 0.9 0.8 0.8 >> arc (y +1) (x + 1) (ballSize + 1) 0 (2 * pi) >> fill
  setSourceRGB 1 1 1 >> arc y x ballSize 0 (2 * pi) >> fill
  when (_debug g) $ do
    case holdBy of
      Nothing -> setSourceRGB 1 1 1 >> moveTo (y - 20) (x - 10) >> showText (showFFloat (Just 3) v "")
      Just i -> setSourceRGB 1 1 1 >> moveTo (y - 20) (x - 10) >> showText ("hold by " ++ show i)

drawBall conf@(_layout -> Portrait) g (Ball (Geometrics (x, y) (dx, dy) v) holdBy) = do
  scale (conf ^. windowScale) (conf ^. windowScale)
  setSourceRGB 0.2 0.4 0.3 >> arc (x + 2) (y + 3) (ballSize + 1) 0 (2 * pi) >> fill
  setSourceRGB 0.9 0.8 0.8 >> arc (x + 1) (y + 1) (ballSize + 1) 0 (2 * pi) >> fill
  setSourceRGB 1 1 1 >> arc x y ballSize 0 (2 * pi) >> fill
  when (_debug g) $ do
    case holdBy of
      Nothing -> setSourceRGB 1 1 1 >> moveTo (x - 10) (y - 20) >> showText (showFFloat (Just 3) v "")
      Just i -> setSourceRGB 1 1 1 >> moveTo (x - 10) (y - 20) >> showText ("hold by " ++ show i)

drawPlayer :: ConfigurationOption -> GameContext -> Player -> Render ()
drawPlayer conf@(_layout -> Landscape) g p@(Player (Geometrics (x, y) (dx, dy) v) (PlayerProperty roll t number index _) intention) = do
  scale (conf ^. windowScale) (conf ^. windowScale)
  when (roll == PlayerSAT) $ do
    setSourceRGBA 1 1 0.4 $ 0.1 + fromIntegral (mod (_time g) 40) / 40
    setLineWidth 1
    rectangle (y - playerSize) (x - playerSize) (2 * playerSize) (2 * playerSize)
    fill
    drawSATLiterals g p
  case () of
    _ | t == Team1 && (_team1 g) ^. directorIntention == AggressiveAttack -> setSourceRGB 0.3 0.3 1.0
    _ | t == Team1                                                        -> setSourceRGB 0.0 0.0 1.0
    _ | t == Team2 && (_team2 g) ^. directorIntention == AggressiveAttack -> setSourceRGB 1.0 0.0 0.0
    _ | t == Team2                                                        -> setSourceRGB 0.7 0.2 0.2
  setLineWidth 2
  rectangle (y - playerSize / 2) (x - playerSize / 2) playerSize playerSize
  stroke
  unless (g ^. debug) $ moveTo (y - 20) x >> showText (show number)
  when (_debug g) $ do
    let rollName = case roll of
          PlayerSAT -> "SAT agent"
          PlayerForward -> "フォワード"
          PlayerKeeper -> "キーパー"
          PlayerDefence -> "ディフェンダー"
    moveTo (y - 20) (x + 20) >> showText (show number ++ "(" ++ rollName ++ ")")
    case intention of
      Lost _ -> fill >> moveTo (y + 20) x >> showText ("??" :: String)
      DribblingTo _ TargetGoal -> fill >> moveTo (y + 20) x >> showText ("ゴールに持ち込む" :: String)
      DribblingTo _ _ -> fill >> moveTo (y + 20) x >> showText ("ドリブル" :: String)
      GoFor _ TargetBall -> moveTo (y + 20) x >> showText ("取りに行く" :: String)
      GoFor _ TargetGoal -> moveTo (y + 20) x >> showText ("ゴールに向かう" :: String)
      GoFor _ TargetOffsideLine -> moveTo (y + 20) x >> showText ("サイドを上がる" :: String)
      GoFor _ TargetDefaultPosition -> moveTo (y + 20) x >> showText ("戻る" :: String)
      GoFor _ DefenceLine -> moveTo (y + 20) x >> showText ("下がる" :: String)
      GoFor _ (TargetZone z) -> moveTo (y + 20) x >> showText ("ゾーン" ++ show z)
      GoFor _ t -> moveTo (y + 20) x >> showText (show t)
      _ -> moveTo (y + 20) x >> showText (show intention)
      -- _ -> return ()
    when (roll /= PlayerKeeper && abs dx < 0.03 && abs dy < 0.03) $
      if mod (_time g) 2 == 0
         then setSourceRGB 1 0.5 0.5 >> moveTo y (x + 20) >> showText ("停止しました" :: String)
         else setSourceRGB 1 1 1 >> moveTo y (x + 20) >> showText ("停止しました" :: String)

drawPlayer conf@(_layout -> Portrait) g p@(Player (Geometrics (x, y) (dx, dy) v) (PlayerProperty roll t number index _) intention) = do
  scale (conf ^. windowScale) (conf ^. windowScale)
  when (roll == PlayerSAT) $ do
    setSourceRGBA 1 1 0.4 $ 0.1 + fromIntegral (mod (_time g) 40) / 40
    setLineWidth 1
    rectangle (x - playerSize) (y - playerSize) (2 * playerSize) (2 * playerSize)
    fill
    drawSATLiterals g p
  case () of
    _ | t == Team1 && (_team1 g) ^. directorIntention == AggressiveAttack -> setSourceRGB 0 0 0.7
    _ | t == Team1                                                        -> setSourceRGB 0 0 1
    _ | t == Team2 && (_team2 g) ^. directorIntention == AggressiveAttack -> setSourceRGB 0.7 0 0
    _ | t == Team2                                                        -> setSourceRGB 1 0.3 0
  setLineWidth 2
  rectangle (x - playerSize / 2) (y - playerSize / 2) playerSize playerSize
  stroke
  unless (g ^. debug) $ moveTo (x - 20) y >> showText (show number)
  when (_debug g) $ do
    let rollName = case roll of
          PlayerSAT -> "SAT agent"
          PlayerForward -> "フォワード"
          PlayerKeeper -> "キーパー"
          PlayerDefence -> "ディフェンダー"
    moveTo (x - 20) (y + 20) >> showText (show number ++ "(" ++ rollName ++ ")")
    case intention of
      Lost _ -> fill >> moveTo x (y + 20) >> showText ("??" :: String)
      DribblingTo _ TargetGoal -> fill >> moveTo (x + 20) y >> showText ("ゴールに持ち込む" :: String)
      DribblingTo _ _ -> fill >> moveTo (x + 20) y >> showText ("ドリブル" :: String)
      GoFor _ TargetBall -> moveTo (x + 20) y >> showText ("取りに行く" :: String)
      GoFor _ TargetGoal -> moveTo (x + 20) y >> showText ("ゴールに向かう" :: String)
      GoFor _ TargetOffsideLine -> moveTo (x + 20) y >> showText ("サイドを上がる" :: String)
      GoFor _ DefenceLine -> moveTo (x + 20) y >> showText ("戻る" :: String)
      GoFor _ (TargetZone z) -> moveTo (x + 20) y >> showText ("ゾーン" ++ show z)
      GoFor _ t -> moveTo (x + 20) y >> showText (show t)
      _  -> moveTo (x + 20) y >> showText (show intention)
      -- _ -> return ()
    when (roll /= PlayerKeeper && abs dx < 0.03 && abs dy < 0.03) $
      if mod (_time g) 2 == 0
         then setSourceRGB 1 0.5 0.5 >> moveTo x (y + 20) >> showText ("停止しました" :: String)
         else setSourceRGB 1 1 1 >> moveTo x (y + 20) >> showText ("停止しました" :: String)

drawGoalScene :: ConfigurationOption -> GameContext -> Render ()
drawGoalScene conf@(_layout -> Portrait) g = do
  let winScale = conf ^. windowScale
  -- let (a, b) = _score g
  let size = 9
  let rest = fromIntegral (_suspendByGoal g) / fromIntegral breakPeriod
  let mod' x = x - (fromIntegral (floor x))
  newPath
  moveTo (winScale * (fwidth /2 - 100)) (winScale * (fheight /2 + fromIntegral (_suspendByGoal g) / 4))
  setSourceRGB (mod' (0.3 + 2 * (1 - rest))) (mod' (0.3 + 3 * (1 - rest))) (mod' (0.3 + 2 * (1 - rest)))
  scale (winScale * size) (winScale * size)
  showText ("GOAL" :: String)

drawGoalScene conf@(_layout -> Landscape) g = do
  let winScale = conf ^. windowScale
  -- let (a, b) = _score g
  let size = 9
  let rest = fromIntegral (_suspendByGoal g) / fromIntegral breakPeriod
  let mod' x = x - (fromIntegral (floor x))
  newPath
  moveTo (winScale * (fheight /2 - 65)) (winScale * (fwidth /2 + fromIntegral (_suspendByGoal g) / 4))
  setSourceRGB (mod' (0.3 + 2 * (1 - rest))) (mod' (0.3 + 3 * (1 - rest))) (mod' (0.3 + 2 * (1 - rest)))
  scale (winScale * size) (winScale * size)
  showText ("GOAL" :: String)

drawLiteralArray :: ConfigurationOption -> GameContext -> Render ()
drawLiteralArray conf@(_layout -> Portrait) g = do
  let winScale = conf ^. windowScale
  lits <- liftIO $ readIORef (g ^. satAssignments)
  let step = fwidth / (fromIntegral (length lits))
  let y = winScale * (fvmargin + fheight) - 1
  let (numInput, _, _) = (1, 1, 1) -- cnfInfo
  setSourceRGB 0 0 0
  forM_ (zip [0 .. ] (take numInput lits)) $ \(i, b) -> do
    when b $ rectangle (winScale * (fhmargin + i * step)) y (winScale * step -1) 3 >> fill
  setSourceRGB 1 0 0
  forM_ (zip [numInput .. ] (drop numInput lits)) $ \(i, b) -> do
    when b $ rectangle (winScale * (fhmargin + fromIntegral i * step)) y (winScale * step -1) 3 >> fill

drawLiteralArray conf@(_layout -> Landscape) g = do
  let winScale = conf ^. windowScale
  lits <- liftIO $ readIORef (g ^. satAssignments)
  let step = fheight / (fromIntegral (length lits))
  let y = winScale * (fhmargin + fwidth) - 1
  let (numInput, _, _) = (1, 1, 1) -- cnfInfo
  setSourceRGB 0 0 0
  forM_ (zip [0 .. ] (take numInput lits)) $ \(i, b) -> do
    when b $ rectangle (winScale * (fvmargin + i * step)) y (winScale * step -1) 3 >> fill
  setSourceRGB 1 0 0
  forM_ (zip [numInput .. ] (drop numInput lits)) $ \(i, b) -> do
    when b $ rectangle (winScale * (fvmargin + fromIntegral i * step)) y (winScale * step -1) 3 >> fill

drawSATLiterals :: GameContext -> Player -> Render ()
drawSATLiterals g p@(Player (Geometrics (x, y) _ _) _ _) = do
  lits <- liftIO $ callSolver' (g ^. solverIteration) (makeLiterals g Nothing p)
  let loop [] = return ()
      loop (p : ls) = do
        when (0 < p) (rectangle (fheight + 5 * fhmargin - 2 * fromIntegral (length ls)) (fwidth + 5) 1 3 >> fill)
        loop ls
  setSourceRGB 1 0 1
  setLineWidth 1
  case lits of
    Just l -> do
      setSourceRGB 0 0 0
      rectangle 14 (fwidth + 5) (fheight + fhmargin * 5) 4
      fill
      setSourceRGB 1 0.5 0.2
      loop l
    Nothing -> return ()
