-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module SDLUI where

import Graphics.UI.SDL hiding (flip)
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL.TTF as TTF
import Control.Concurrent.STM
import Control.Applicative hiding ((<*>))
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Word
import Data.Array
import Data.List
import Data.Ratio
import Data.Function (on)
--import Debug.Trace (traceShow)

import Hex
import Command
import GameState (stateBoard)
import GameStateTypes
import BoardColouring
import Lock
import Physics
import KeyBindings
import Mundanities
import Metagame
import SDLRender
import InputMode
import Maxlocksize

data UIState = UIState { scrHeight::Int, scrWidth::Int
    , gsSurface::Maybe Surface
    , bgSurface::Maybe Surface
    , lastDrawArgs::Maybe DrawArgs
    , miniLocks::Map Lock Surface
    , metaSelectables::Map HexVec Selectable
    , contextButtons::[ButtonGroup]
    , uiOptions::UIOptions
    , settingBinding::Maybe Command
    , uiKeyBindings :: Map InputMode KeyBindings
    , dispFont::Maybe TTF.Font
    , dispFontSmall::Maybe TTF.Font
    , lastFrameTicks::Word32
    , paintTileIndex::Int
    , leftButtonDown::Maybe HexVec, middleButtonDown::Maybe HexVec, rightButtonDown::Maybe HexVec
    , mousePos::(HexVec,Bool)
    , message::Maybe (Pixel, String)
    , hoverStr :: Maybe String
    , dispCentre::HexPos
    , dispLastCol::PieceColouring }
    deriving (Eq, Ord, Show)
type UIM = StateT UIState IO
nullUIState = UIState 0 0 Nothing Nothing Nothing Map.empty Map.empty []
    defaultUIOptions Nothing Map.empty Nothing Nothing 0 0 Nothing Nothing Nothing
    (zero,False) Nothing Nothing (PHS zero) Map.empty

data UIOptions = UIOptions
    { useFiveColouring::Bool
    , showBlocks::Bool
    , whsButtons::WrHoSel
    , useBackground::Bool
    }
    deriving (Eq, Ord, Show, Read)
defaultUIOptions = UIOptions False False WHSSelected True
modifyUIOptions f = modify $ \s -> s { uiOptions = f $ uiOptions s }

renderToMain :: RenderM a -> UIM a
renderToMain m = do
    surf <- liftIO getVideoSurface
    renderToMainWithSurf surf m
renderToMainWithSurf :: Surface -> RenderM a -> UIM a
renderToMainWithSurf surf m = do
    (scrCentre, size) <- getGeom
    centre <- gets dispCentre
    mfont <- gets dispFont
    bgsurf <- gets bgSurface
    liftIO $ runReaderT m $ RenderContext surf bgsurf centre scrCentre size mfont


refresh :: UIM ()
refresh = do 
    surface <- liftIO getVideoSurface
    liftIO $ SDL.flip surface

waitFrame :: UIM ()
waitFrame = do
    last <- gets lastFrameTicks
    let next = last + 1000 `div` 30
    now <- liftIO getTicks
    -- liftIO $ print now
    when (now < next) $
	liftIO $ delay (next - now)
    modify $ \ds -> ds { lastFrameTicks = now }


data Button = Button { buttonPos::HexVec, buttonCmd::Command }
    deriving (Eq, Ord, Show)
type ButtonGroup = ([Button],(Int,Int))
singleButton :: HexVec -> Command -> Int -> ButtonGroup
singleButton pos cmd col = ([Button pos cmd], (col,0))
getButtons :: InputMode -> UIM [ ButtonGroup ]
getButtons mode = do
    whs <- gets $ whsButtons.uiOptions
    cntxtButtons <- gets contextButtons
    return $ cntxtButtons ++ case mode of 
	IMEdit -> [
	    singleButton (tl<+>hv) CmdTest 4
	    , singleButton (tl<+>(neg hw)) CmdPlay 2
	    , markGroup
	    , ([quitButton, Button (br<+>2<*>hu) CmdWriteState],(0,2))
	    , ( [ Button (bl<+>dir) (CmdDir WHSSelected dir) | dir <- hexDirs ] ++
		[ Button (bl<+>((-2)<*>hv)) (CmdRotate (-1))
		, Button (bl<+>((-2)<*>hw)) (CmdRotate 1) ], (4,0) )
	    , ( [ Button bl CmdSelect ], (0,0))
	    , ([Button (paintButtonStart <+> hu <+> i<*>hv) (paintTileCmds!!i)
		| i <- take (length paintTiles) [0..] ],(5,0))
	    ]
	IMPlay -> 
	    [ ([quitButton],(0,2))
	    , markGroup
	    , ( [ Button bl CmdWait ], (0,0))
	    , ( [ Button (bl<+>dir) (CmdDir whs dir) | dir <- hexDirs ], (4,0) )
	    ] ++
	    (if whs == WHSWrench then [] else
		[ ( [ Button (bl<+>((-2)<*>hv)) (CmdRotate (-1))
		    , Button (bl<+>((-2)<*>hw)) (CmdRotate 1)
		    ], (4,0) )
	    ]) ++
	    (if whs /= WHSSelected then [] else
		[ ( [ Button (bl<+>(2<*>hv)<+>hw) (CmdTile $ HookTile)
		    , Button (bl<+>(2<*>hv)) (CmdTile $ WrenchTile zero)
		    ], (2,0) )
	    ]) ++
	    [ singleButton tr CmdOpen 1 ]
	IMReplay -> [ ([quitButton],(0,2))
	    , markGroup ]
	IMMeta ->
	    [ ([quitButton],(0,2))
	    , singleButton serverPos CmdSetServer 2
	    , singleButton (serverPos<+>neg hu) CmdToggleCacheOnly 0
	    , singleButton lockLinePos CmdSelectLock 4
	    , singleButton (miniLockPos <+> 2<*>hv <+> neg hu <+> hw) CmdEdit 2
	    , singleButton (codenamePos <+> neg hu) (CmdSelCodename Nothing) 2
	    , singleButton (serverPos <+> 2<*>neg hv <+> hw) CmdTutorials 1
	    ]
		
	_ -> []
	where
	    quitButton = Button br CmdQuit
	    markGroup = ([Button (tl<+>hw) CmdMark, Button (tl<+>hw<+>neg hu) CmdJumpMark],(0,0))
	    tr = periphery 0
	    tl = periphery 2
	    bl = periphery 3
	    br = periphery 5

data Selectable = SelOurLock
    | SelLock ActiveLock
    | SelLockUnset ActiveLock
    | SelSelectedCodeName
    | SelOurAL
    | SelUndeclared Undeclared
    | SelReadNote NoteInfo
    | SelSolution NoteInfo
    | SelAccessed Codename
    | SelRandom Codename
    | SelSecured NoteInfo
    | SelOldLock LockSpec
    deriving (Eq, Ord, Show)

registerSelectable v r s =
    modify $ \ds -> ds {metaSelectables = foldr
	(`Map.insert` s) (metaSelectables ds) $ map (v<+>) $ hexDisc r}
registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds}
clearSelectables,clearButtons :: UIM ()
clearSelectables = modify $ \ds -> ds {metaSelectables = Map.empty}
clearButtons = modify $ \ds -> ds {contextButtons = []}

registerUndoButtons noUndo noRedo = do
    unless noUndo $ registerButtonGroup $ singleButton (periphery 2) CmdUndo 0
    unless noRedo $ registerButtonGroup $ singleButton (periphery 2<+>neg hu) CmdRedo 2

commandOfSelectable IMMeta SelOurLock _ = CmdEdit
commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = CmdSolve (Just i)
commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = CmdPlaceLock (Just i)
commandOfSelectable IMMeta (SelLockUnset (ActiveLock _ i)) _ = CmdPlaceLock (Just i)
commandOfSelectable IMMeta SelSelectedCodeName False = CmdSelCodename Nothing
commandOfSelectable IMMeta SelSelectedCodeName True = CmdHome
commandOfSelectable IMMeta SelOurAL _ = CmdHome
commandOfSelectable IMMeta (SelUndeclared undecl) _ = CmdDeclare $ Just undecl
commandOfSelectable IMMeta (SelReadNote note) False = CmdSelCodename $ Just $ noteAuthor note
commandOfSelectable IMMeta (SelReadNote note) True = CmdViewSolution $ Just note
commandOfSelectable IMMeta (SelSolution note) False = CmdSelCodename $ Just $ noteAuthor note
commandOfSelectable IMMeta (SelSolution note) True = CmdViewSolution $ Just note
commandOfSelectable IMMeta (SelAccessed name) _ = CmdSelCodename $ Just name
commandOfSelectable IMMeta (SelRandom name) _ = CmdSelCodename $ Just name
commandOfSelectable IMMeta (SelSecured note) False = CmdSelCodename $ Just $ lockOwner $ noteOn note
commandOfSelectable IMMeta (SelSecured note) True = CmdViewSolution $ Just note
commandOfSelectable IMMeta (SelOldLock ls) _ = CmdPlayLockSpec $ Just ls
commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = CmdInputSelLock i
commandOfSelectable IMTextInput (SelLockUnset (ActiveLock _ i)) _ = CmdInputSelLock i
commandOfSelectable IMTextInput (SelReadNote note) _ = CmdInputCodename $ noteAuthor note
commandOfSelectable IMTextInput (SelSolution note) _ = CmdInputCodename $ noteAuthor note
commandOfSelectable IMTextInput (SelSecured note) _ = CmdInputCodename $ lockOwner $ noteOn note
commandOfSelectable IMTextInput (SelRandom name) _ = CmdInputCodename name
commandOfSelectable IMTextInput (SelUndeclared undecl) _ = CmdInputSelUndecl undecl
commandOfSelectable _ _ _ = CmdNone

cmdAtMousePos pos@(mPos,central) im selMode = do
    buttons <- (concat . map fst) <$> getButtons im
    sels <- gets metaSelectables
    return $ listToMaybe $
	[ buttonCmd button
	    | button <- buttons, mPos == buttonPos button, central]
	++ maybe [] (\isRight -> [ commandOfSelectable im sel isRight
	    | Just sel <- [Map.lookup mPos sels] ]) selMode

data UIOptButton a = UIOptButton { getUIOpt::UIOptions->a, setUIOpt::a->UIOptions->UIOptions,
    uiOptVals::[a], uiOptPos::HexVec, uiOptGlyph::a->Glyph, uiOptDescr::a->String }

-- non-uniform type, so can't use a list...
uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False]
	(periphery 0 <+> 2 <*> neg hw <+> neg hv) useFiveColourButton
	(\v -> if v then "Adjacent pieces get different colours" else
	"Pieces are coloured according to type")
uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [True,False]
	(periphery 0 <+> 2 <*> neg hw <+> 3 <*> neg hv) showBlocksButton
	(\v -> if v then "Blocked and blocking forces are annotated" else
	"Blockage annotations disabled")
uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [WHSSelected, WHSWrench, WHSHook]
	(periphery 3 <+> 3 <*> hv) whsButtonsButton
	(\v -> "Showing buttons for controlling " ++ case v of
	    WHSSelected -> "selected tool"
	    WHSWrench -> "wrench"
	    WHSHook -> "hook")

drawUIOptionButtons :: InputMode -> UIM ()
drawUIOptionButtons mode = when (mode `elem` [IMPlay, IMEdit]) $ do
    drawUIOptionButton uiOB1
    drawUIOptionButton uiOB2 
    when (mode == IMPlay) $ drawUIOptionButton uiOB3
drawUIOptionButton b = do
    value <- gets $ (getUIOpt b).uiOptions
    renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b))
	[hollowGlyph $ obscure purple, uiOptGlyph b value]
describeUIOptionButton b = do
    value <- gets $ (getUIOpt b).uiOptions
    return $ uiOptDescr b value
-- XXX: hand-hacking lenses...
toggleUIOption (UIOptButton getopt setopt vals _ _ _) = do
    value <- gets $ getopt.uiOptions
    let value' = head $ drop (1 + (fromMaybe 0 $ elemIndex value vals)) $ cycle vals
    modifyUIOptions $ setopt value'

readUIConfigFile :: UIM ()
readUIConfigFile = do 
    path <- liftIO $ confFilePath "SDLUI.conf"
    mOpts <- liftIO $ readReadFile path
    case mOpts of
	Just opts -> modify $ \s -> s {uiOptions = opts}
	Nothing -> return ()
writeUIConfigFile :: UIM ()
writeUIConfigFile = do
    path <- liftIO $ confFilePath "SDLUI.conf"
    opts <- gets uiOptions
    liftIO makeConfDir
    liftIO $ writeFile path $ show opts

readBindings :: UIM ()
readBindings = do 
    path <- liftIO $ confFilePath "bindings"
    mbdgs <- liftIO $ readReadFile path
    case mbdgs of
	Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}
	Nothing -> return ()
writeBindings :: UIM ()
writeBindings = do
    path <- liftIO $ confFilePath "bindings"
    bdgs <- gets uiKeyBindings
    liftIO makeConfDir
    liftIO $ writeFile path $ show bdgs

paintTiles :: [ Maybe Tile ]
paintTiles =
    [ Just BallTile
    , Just $ ArmTile zero False
    , Just $ PivotTile zero
    , Just $ SpringTile Relaxed zero
    , Just $ BlockTile []
    , Nothing
    ]

paintTileCmds = map (maybe CmdWait CmdTile) paintTiles

getEffPaintTileIndex :: UIM Int
getEffPaintTileIndex = do
    mods <- liftIO getModState
    if any (`elem` mods) [KeyModLeftCtrl, KeyModRightCtrl]
    then return $ length paintTiles - 1
    else gets paintTileIndex

paintButtonStart :: HexVec
paintButtonStart = periphery 0 <+> (- length paintTiles `div` 2)<*>hv

drawPaintButtons :: UIM ()
drawPaintButtons = do
    pti <- getEffPaintTileIndex
    renderToMain $ sequence_ [ 
	do
	    let gl = case paintTiles!!i of
		    Nothing -> hollowInnerGlyph $ dim purple
		    Just t -> tileGlyph t $ dim purple
	    drawAtRel gl pos
	    when selected $ drawAtRel cursor pos
	| i <- take (length paintTiles) [0..]
	, let pos = paintButtonStart <+> i<*>hv
	, let selected = i == pti
	]

periphery 0 = ((3*maxlocksize)`div`2)<*>hu <+> ((3*maxlocksize)`div`4)<*>hv
periphery n = rotate n $ periphery 0
-- ^ XXX only peripheries 0,2,3,5 are guaranteed to be on-screen!
--messageLineStart = (maxlocksize+1)<*>hw
messageLineCentre = ((maxlocksize+1)`div`2)<*>hw <+> ((maxlocksize+1+1)`div`2)<*>neg hv
titlePos = (maxlocksize+1)<*>hv <+> ((maxlocksize+1)`div`2)<*>hu

screenWidthHexes,screenHeightHexes::Int
screenWidthHexes = 32
screenHeightHexes = 25
getGeom :: UIM (SVec, Int)
getGeom = do 
    h <- gets scrHeight 
    w <- gets scrWidth
    let scrCentre = SVec (w`div`2) (h`div`2)
    -- |size is the greatest integer such that
    -- and [2*size*screenWidthHexes <= width
    --	, 3*ysize size*screenHeightHexes <= height]
    --	where ysize size = round $ fromIntegral size / sqrt 3
    let size = max 1 $ minimum [ w`div`(2*screenWidthHexes)
	    , floor $ sqrt 3 * (0.5 + (fromIntegral $ h`div`(3*screenHeightHexes)))]
    return (scrCentre, size)

data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions
    deriving (Eq, Ord, Show)

drawMainGameState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM ()
drawMainGameState highlight colourFixed alerts st = do
    uiopts <- gets uiOptions
    drawMainGameState' $ DrawArgs highlight colourFixed alerts st uiopts

drawMainGameState' :: DrawArgs -> UIM ()
drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do
    lastArgs <- gets lastDrawArgs
    void $ if lastArgs == Just args
	then do
	    vidSurf <- liftIO getVideoSurface
	    gsSurf <- liftM fromJust $ gets gsSurface
	    liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
	else do
	    modify $ \ds -> ds { lastDrawArgs = Just args }
	    let board = stateBoard st
	    lastCol <- gets dispLastCol
	    let coloured = colouredPieces colourFixed st
	    let colouring = if useFiveColouring uiopts
		then boardColouring st coloured lastCol
		else pieceTypeColouring st coloured
	    modify $ \ds -> ds { dispLastCol = colouring }
	    gsSurf <- liftM fromJust $ gets gsSurface
	    renderToMainWithSurf gsSurf $ do
		erase
		sequence_ [ drawAt glyph pos | 
		    (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring highlight) board
		    ]

		when (showBlocks uiopts) $ sequence_
		    $ [ drawBlocked st colouring False force |
		    AlertBlockedForce force <- alerts ]
		    ++ [ drawBlocked st colouring True force |
		    AlertBlockingForce force <- alerts ]
		    ++ [ drawBlocked st colouring True force |
		    AlertResistedForce force <- alerts ]
		    -- ++ [ drawAt collisionMarker pos | AlertCollision pos <- alerts ]
	    vidSurf <- liftIO getVideoSurface
	    liftIO $ blitSurface gsSurf Nothing vidSurf Nothing

drawMiniLock :: Lock -> HexVec -> UIM ()
drawMiniLock lock v = do
    surface <- Map.lookup lock <$> gets miniLocks >>= maybe new return
    renderToMain $ blitAt surface v
    where
	miniLocksize = 3
	new = do
	    (_, size) <- getGeom
	    let minisize = size `div` (ceiling $ lockSize lock % miniLocksize)
	    let width = size*2*(miniLocksize*2+1)
	    let height = ceiling $ fromIntegral size * sqrt 3 * fromIntegral (miniLocksize*2+1+1)
	    surf <- liftIO $ createRGBSurface [] width height 16 0 0 0 0
	    liftIO $ setColorKey surf [SrcColorKey] $ Pixel 0
	    uiopts <- gets uiOptions
	    let st = snd $ reframe lock
		coloured = colouredPieces False st
		colouring = if useFiveColouring uiopts
		    then boardColouring st coloured Map.empty
		    else pieceTypeColouring st coloured
		draw = sequence_ [ drawAt glyph pos | 
		    (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring []) $ stateBoard st ]
	    liftIO $ runReaderT draw $
		RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) minisize Nothing
	    clearOldMiniLocks
	    modify $ \ds -> ds { miniLocks = Map.insert lock surf $ miniLocks ds }
	    return surf

-- | TODO: do this more cleverly
clearOldMiniLocks =
    (>=50).Map.size <$> gets miniLocks >>= flip when clearMiniLocks
clearMiniLocks = modify $ \ds -> ds { miniLocks = Map.empty}

drawEmptyMiniLock v =
    renderToMain $ recentreAt v $ rescaleRender 6 $ drawAtRel (hollowInnerGlyph $ dim white) zero

getBindingStr :: InputMode -> UIM (Command -> String)
getBindingStr mode = do
    setting <- gets settingBinding
    uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
    return (\cmd ->
	if Just cmd == setting then "??"
	else maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd)

drawButtons :: InputMode -> UIM ()
drawButtons mode = do
    buttons <- getButtons mode
    bindingStr <- getBindingStr mode
    renderToMain $ sequence_ $ concat [
	    [ drawAtRel (buttonGlyph col) v >> renderStrColAt buttonTextCol bdg v |
		(i,(v,bdg)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b)) $ buttonGroup
		, let col = dim $ colourWheel (base+inc*i) ]
	| (buttonGroup,(base,inc)) <- buttons
	]
    where enumerate = zip [0..]

initVideo :: Int -> Int -> UIM ()
initVideo w h = do
    liftIO $ setVideoMode w h 0 [Resizable]
    
    -- see what size we actually got:
    vinfo <- liftIO $ getVideoInfo
    let [w',h'] = map ($vinfo) [videoInfoWidth,videoInfoHeight]

    modify $ \ds -> ds { scrWidth = w' }
    modify $ \ds -> ds { scrHeight = h' }
    gssurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0
    modify $ \ds -> ds { gsSurface = Just gssurf, lastDrawArgs = Nothing }

    (_,size) <- getGeom
    let fontfn = "VeraMono.ttf"
    fontpath <- liftIO $ getDataPath fontfn
    font <- liftIO $ TTF.tryOpenFont fontpath size
    smallFont <- liftIO $ TTF.tryOpenFont fontpath (2*size`div`3)
    modify $ \ds -> ds { dispFont = font, dispFontSmall = smallFont }

    useBG <- gets $ useBackground.uiOptions
    mbg <- if useBG then do
	    bgsurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0
	    renderToMainWithSurf bgsurf $ drawBasicBG $ 2*(max screenWidthHexes screenHeightHexes)`div`3
	    return $ Just bgsurf
	else return Nothing
    modify $ \ds -> ds { bgSurface = mbg }

    clearMiniLocks

    when (isNothing font) $ lift.putStr $ "Warning: font file not found at "++fontpath++".\n"

drawMsgLine = void.runMaybeT $ do
    (col,str) <- msum
	[ ((,) dimWhiteCol) <$> MaybeT (gets hoverStr)
	, MaybeT $ gets message
	]
    lift $ do
	renderToMain $ blankRow messageLineCentre
	smallFont <- gets dispFontSmall
	renderToMain $
	    (if length str > screenWidthHexes * 3 then withFont smallFont else id) $
		renderStrColAt col str messageLineCentre

setMsgLineNoRefresh col str = do
    modify $ \s -> s { message = Just (col,str) }
    unless (null str) $ modify $ \s -> s { hoverStr = Nothing }
    drawMsgLine 
setMsgLine col str = setMsgLineNoRefresh col str >> refresh

drawTitle (Just title) = renderToMain $ renderStrColAt messageCol title titlePos
drawTitle Nothing = return ()
    
say = setMsgLine messageCol
sayError = setMsgLine errorCol

miniLockPos = (-9)<*>hw <+> hu
lockLinePos = 2<*>(hu <+> neg hw) <+> miniLockPos
serverPos = 12<*>hv <+> 6<*>neg hu
serverWaitPos = serverPos <+> hw <+> neg hu
nextPagePos = serverPos <+> 4<*>neg hv
randomNamesPos = 9<*>hv <+> neg hu
codenamePos = (-4)<*>hw <+> 4<*>hv
undeclsPos = hv <+> neg hw <+> codenamePos
accessedOursPos = 2<*>hw <+> codenamePos
locksPos = hw<+>neg hv
retiredPos = locksPos <+> 10<*>hu <+> (-4)<*>hv