Lock.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module Lock where
  12 import Control.Monad.Writer
  13 import Data.Maybe
  14 import qualified Data.Map as Map
  15
  16 import Frame
  17 import GameState
  18 import GameStateTypes
  19 import Hex
  20 import Util
  21 import Physics
  22
  23 type Lock = (Frame, GameState)
  24 liftLock :: (GameState -> GameState) -> (Lock -> Lock)
  25 liftLock g (f,st) = (f,g st)
  26
  27 lockSize (f,_) = frameSize f
  28
  29 baseLock :: Int -> Lock
  30 baseLock size =
  31     let frame = BasicFrame size
  32     in (frame, baseState frame)
  33
  34 deframe :: Lock -> Lock
  35 deframe = delTools . liftLock (setpp 0 nullpp)
  36 nullpp = PlacedPiece (PHS zero) (Block [])
  37
  38 reframe :: Lock -> Lock
  39 reframe l@(f, st) = addTools $ delTools $ liftLock (setpp 0 (framePiece f)) l
  40
  41 validLock :: Lock -> Bool
  42 validLock lock@(f,st) = and
  43     [ st == stepPhysics st
  44     , lock == reframe lock
  45     , validGameState st
  46     ]
  47
  48 type Solution = [PlayerMove]
  49
  50 checkSolution :: Lock -> Solution -> Bool
  51 checkSolution lock pms =
  52     let (frame,st) = reframe lock
  53         tick :: GameState -> PlayerMove -> GameState
  54         tick st pm = fst . runWriter $ physicsTick pm st
  55     in any (\st' -> checkSolved (frame,st')) $ scanl tick st pms
  56
  57 checkSolved :: Lock -> Bool
  58 checkSolved (f,st) =
  59     and [ isNothing $ Map.lookup p (stateBoard st) | p <- boltArea f ]
  60
  61
  62 canonify :: Lock -> Lock
  63 canonify = addTools . stabilise . delTools . delOOB
  64 delTools :: Lock -> Lock
  65 delTools = liftLock delTools' where
  66         delTools' :: GameState -> GameState
  67         delTools' st =
  68             fromMaybe st $ listToMaybe
  69                 [ delTools' $ delPiece idx st
  70                 | (idx,pp) <- enumVec $ placedPieces st
  71                 , isTool $ placedPiece pp ]
  72 addTools :: Lock -> Lock
  73 addTools (f,st) =
  74     let st' = clearToolArea f st
  75     in (f, foldr addpp st' $ initTools f)
  76
  77 -- |An important property of the game physics is that any state stabilises in
  78 -- finite time. Proof: in any spontaneous state change some spring gets closer
  79 -- to being of natural length, and none get further from it.
  80 stabilise :: Lock -> Lock
  81 stabilise = liftLock stabilise' where
  82         stabilise' :: GameState -> GameState
  83         stabilise' st =
  84             let st' = stepPhysics st
  85             in if st == st' then st else stabilise' st'
  86
  87 delOOB :: Lock -> Lock
  88 delOOB l@(f,st) =
  89     fromMaybe l $ listToMaybe
  90         [ delOOB $ liftLock (delPiece idx) l
  91         | (idx,_) <- enumVec $ placedPieces st
  92         , not $ isFrame idx
  93         , all (not.inBounds f) $ fullFootprint st idx
  94         , null $ springsEndAtIdx st idx]