packages feed

intricacy (empty) → 0.3

raw patch · 57 files changed

+8033/−0 lines, 57 filesdep +SDLdep +SDL-gfxdep +SDL-ttfsetup-changedbinary-added

Dependencies added: SDL, SDL-gfx, SDL-ttf, array, base, binary, bytestring, containers, cryptohash, directory, filepath, hscurses, mtl, network-fancy, pipes, random, stm, time, transformers, vector

Files

+ AsciiLock.hs view
@@ -0,0 +1,245 @@+-- 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 AsciiLock (lockToAscii, lockOfAscii, stateToAscii+    , readAsciiLockFile, writeAsciiLockFile) where++import Data.Function (on)+import Control.Applicative hiding ((<*>))+import Control.Monad+import Control.Arrow ((&&&))+import System.IO+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Vector as Vector+import Data.Vector (Vector, (!), (//))+import Data.Maybe+import Data.Traversable as T+import Data.List++import Lock+import GameStateTypes+import GameState+import BoardColouring+import Frame+import Hex+import CVec+import Util+import Mundanities+++type AsciiLock = [String]++lockToAscii :: Lock -> AsciiLock+lockToAscii (_,st) = stateToAscii st++stateToAscii :: GameState -> AsciiLock+stateToAscii st =+    let colouring = boardColouring st (ppidxs st) Map.empty+    in boardToAscii colouring . stateBoard $ st++lockOfAscii :: AsciiLock -> Maybe Lock+lockOfAscii lines = do+    board <- asciiToBoard lines+    let size = maximum $ map (hx . (<->origin))$ Map.keys board+	frame = BasicFrame size+    st <- asciiBoardState frame board+    return (frame, st)++boardToAscii :: PieceColouring -> GameBoard -> AsciiLock+boardToAscii colouring board =+    let asciiBoard :: Map CVec Char+	asciiBoard = Map.mapKeys (hexVec2CVec . (<->origin))+	    $ fmap (monochromeOTileChar colouring) board+	(miny,maxy) = minmax $ map cy $ Map.keys asciiBoard+	(minx,maxx) = minmax $ map cx $ Map.keys asciiBoard+	asciiBoard' = Map.mapKeys (<->CVec miny minx) asciiBoard+    in [ [ Map.findWithDefault ' ' (CVec y x) asciiBoard' +	    | x <- [0..(maxx-minx)] ]+	| y <- [0..(maxy-miny)] ]++asciiToBoard :: AsciiLock -> Maybe GameBoard+asciiToBoard lines =+    let asciiBoard :: Map CVec Char+	asciiBoard = Map.fromList [(CVec y x,ch)+	    | (line,y) <- zip lines [0..]+	    , (ch,x) <- zip line [0..]+	    , ch `notElem` "\t\r\n "]+	(miny,maxy) = minmax $ map cy $ Map.keys asciiBoard+	midy = miny+(maxy-miny)`div`2+	midline = filter ((==midy).cy) $ Map.keys asciiBoard+	(minx,maxx) = minmax $ map cx $ midline+	centre = CVec midy (minx+(maxx-minx)`div`2)+    in Map.mapKeys ((<+>origin) . cVec2HexVec . (<->centre))+	<$> T.mapM monoToOTile asciiBoard++asciiBoardState :: Frame -> GameBoard -> Maybe GameState+asciiBoardState frame board =+    let addPreBase st = foldr addpp st (replicate 6 $ PlacedPiece origin $ Block [])+	addBase st = foldr addBaseOT st $ Map.toList $+	    Map.filter (isBaseTile.snd) board+	isBaseTile (BlockTile _) = True+	isBaseTile (PivotTile _) = True+	isBaseTile HookTile = True+	isBaseTile (WrenchTile _) = True+	isBaseTile (BallTile) = True+	isBaseTile _ = False+	addBaseOT :: (HexPos,(PieceIdx,Tile)) -> GameState -> GameState+	addBaseOT (pos,(o,BlockTile [])) = addBlockPos o pos+	addBaseOT (pos,(-1,t)) = addpp $ PlacedPiece pos $ basePieceOfTile t+	basePieceOfTile (PivotTile _) = Pivot []+	basePieceOfTile HookTile = Hook hu NullHF+	basePieceOfTile (WrenchTile _) = Wrench zero+	basePieceOfTile BallTile = Ball+	componentifyNew st = foldr ((fst.).componentify) st $ filter (/=0) $ ppidxs st+	-- | we assume that the largest wholly out-of-bounds block is the frame+	setFrame st = fromMaybe st $ do+	    (idx,pp) <- listToMaybe $ sortBy (flip compare `on` blockSize . placedPiece . snd)+		    [ (idx,pp)+		    | (idx,pp) <- enumVec $ placedPieces st+		    , isBlock . placedPiece $ pp+		    , let fp = plPieceFootprint pp+		    , not $ null fp+		    , all (not.inBounds frame) fp+		    ]+	    return $ delPiece idx $ setpp 0 pp st+	blockSize (Block vs) = length vs+	baseSt = setFrame . componentifyNew . addBase . addPreBase $ GameState Vector.empty []++	baseBoard = stateBoard baseSt+	addAppendages :: GameState -> Maybe GameState+	addAppendages st = foldM addAppendageOT st $ Map.toList $+	    Map.filter (not.isBaseTile.snd) board+	addAppendageOT st (pos,(-1,ArmTile dir _)) = +	    let rpos = (neg dir<+>pos)+	    in case Map.lookup rpos baseBoard of+		Just (idx,PivotTile _) -> Just $ addPivotArm idx pos st+		Just (idx,HookTile) -> Just $ setpp idx (PlacedPiece rpos (Hook dir NullHF)) st+		_ -> Nothing+	addAppendageOT st (pos,(-1,SpringTile extn dir)) =+	    let rpos = (neg dir<+>pos)+	    in case Map.lookup rpos baseBoard of+		Just (_,SpringTile _ _) -> Just st+		Just (ridx,tile) -> do+		    (_,epos) <- castRay pos dir baseBoard+		    let twiceNatLen = sum [ extnValue extn+			    | i <- [1..hexLen (epos<->rpos)-1]+			    , let pos' = i<*>dir<+>rpos+			    , Just (_,SpringTile extn _) <- [ Map.lookup pos' board ] ]+			extnValue Compressed = 4+			extnValue Relaxed = 2+			extnValue Stretched = 1+			Just root = posLocus baseSt rpos+			Just end = posLocus baseSt epos+		    Just $ flip addConn st $ Connection root end $ Spring dir $ twiceNatLen`div`2+		_ -> Just st+	addAppendageOT _ _ = Nothing+    in addAppendages baseSt++monochromeOTileChar :: PieceColouring -> OwnedTile -> Char+monochromeOTileChar colouring (idx,BlockTile _) =+    case Map.lookup idx colouring of+	Just 1 -> '%'+	Just 2 -> '"'+	Just 3 -> '&'+	Just 4 -> '~'+	_ -> '#'+monochromeOTileChar _ (_,t) = monochromeTileChar t+monochromeTileChar (PivotTile _) = 'o'+monochromeTileChar (ArmTile dir _) +    | dir == hu = '-'+    | dir == hv = '\\'+    | dir == hw = '/'+    | dir == neg hu = '.'+    | dir == neg hv = '`'+    | dir == neg hw = '\''+monochromeTileChar HookTile = '@'+monochromeTileChar (WrenchTile _) = '*'+monochromeTileChar BallTile = 'O'+monochromeTileChar (SpringTile extn dir)+    | dir == hu = case extn of+	Stretched                  -> 's'+	Relaxed                    -> 'S'+	Compressed                 -> '$'+    | dir == hv = case extn of+	Stretched                  -> 'z'+	Relaxed                    -> 'Z'+	Compressed                 -> '5'+    | dir == hw = case extn of+	Stretched                  -> '('+	Relaxed                    -> '['+	Compressed                 -> '{'+    | dir == neg hu = case extn of+	Stretched                  -> 'c'+	Relaxed                    -> 'C'+	Compressed                 -> 'D'+    | dir == neg hv = case extn of+	Stretched                  -> ')'+	Relaxed                    -> ']'+	Compressed                 -> '}'+    | dir == neg hw = case extn of+	Stretched                  -> '1'+	Relaxed                    -> '7'+	Compressed                 -> '9'+monoToOTile :: Char -> Maybe OwnedTile+monoToOTile '#' = Just $ (1,BlockTile [])+monoToOTile '%' = Just $ (2,BlockTile [])+monoToOTile '"' = Just $ (3,BlockTile [])+monoToOTile '&' = Just $ (4,BlockTile [])+monoToOTile '~' = Just $ (5,BlockTile [])+monoToOTile ch = ((,) (-1)) <$> monoToTile ch+monoToTile 'o' = Just $ PivotTile zero+monoToTile '-' = Just $ ArmTile hu False+monoToTile '\\' = Just $ ArmTile hv False+monoToTile '/' = Just $ ArmTile hw False+monoToTile '.' = Just $ ArmTile (neg hu) False+monoToTile '`' = Just $ ArmTile (neg hv) False+monoToTile '\'' = Just $ ArmTile (neg hw) False+monoToTile '@' = Just $ HookTile+monoToTile '*' = Just $ WrenchTile zero+monoToTile 'O' = Just $ BallTile+monoToTile 's' = Just $ SpringTile Stretched hu+monoToTile 'S' = Just $ SpringTile Relaxed hu+monoToTile '$' = Just $ SpringTile Compressed hu+monoToTile 'z' = Just $ SpringTile Stretched hv+monoToTile 'Z' = Just $ SpringTile Relaxed hv+monoToTile '5' = Just $ SpringTile Compressed hv+monoToTile '(' = Just $ SpringTile Stretched hw+monoToTile '[' = Just $ SpringTile Relaxed hw+monoToTile '{' = Just $ SpringTile Compressed hw+monoToTile 'c' = Just $ SpringTile Stretched (neg hu)+monoToTile 'C' = Just $ SpringTile Relaxed (neg hu)+monoToTile 'D' = Just $ SpringTile Compressed (neg hu)+monoToTile ')' = Just $ SpringTile Stretched (neg hv)+monoToTile ']' = Just $ SpringTile Relaxed (neg hv)+monoToTile '}' = Just $ SpringTile Compressed (neg hv)+monoToTile '1' = Just $ SpringTile Stretched (neg hw)+monoToTile '7' = Just $ SpringTile Relaxed (neg hw)+monoToTile '9' = Just $ SpringTile Compressed (neg hw)+monoToTile _ = Nothing++minmax :: Ord a => [a] -> (a,a)+minmax = minimum &&& maximum++readAsciiLockFile :: FilePath -> IO (Maybe Lock, Maybe Solution)+readAsciiLockFile path = flip catchIO (const $ return (Nothing,Nothing)) $ do+    lines <- readStrings path+    return $ fromMaybe (lockOfAscii lines, Nothing) $ do+	    guard $ length lines > 2+	    let (locklines, [header,solnLine]) = splitAt (length lines - 2) lines+	    guard $ isPrefixOf "Solution:" header+	    return (lockOfAscii locklines, tryRead solnLine)++writeAsciiLockFile :: FilePath -> Maybe Solution -> Lock -> IO ()+writeAsciiLockFile path msoln lock = do+    writeStrings path $ lockToAscii lock ++ case msoln of+	Nothing -> []+	Just soln -> ["Solution:", show soln]+
+ BinaryInstances.hs view
@@ -0,0 +1,134 @@+-- 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 BinaryInstances where+import Data.Binary+import qualified Data.Vector as Vector+import Control.Monad+import Data.Int (Int8)++import GameStateTypes+import Physics+import Hex+import Frame++newtype SmallInt = SmallInt {fromSmallInt :: Int}+newtype SmallNat = SmallNat {fromSmallNat :: Int}+instance Binary SmallNat where+    put (SmallNat n) = if n < 255 then putWord8 (fromIntegral n) else putWord8 255 >> put n+    get = do+	n' <- get :: Get Word8+	if n' == 255 then liftM SmallNat get else return $ SmallNat $ fromIntegral n'++instance Binary SmallInt where+    put (SmallInt n) = if abs n < 127 then put ((fromIntegral n)::Int8) else put (127::Int8) >> put n+    get = do+	n' <- get :: Get Int8+	if n' == 127 then liftM SmallInt get else return $ SmallInt $ fromIntegral n'++putPackedNat,putPackedInt :: Int -> Put+putPackedNat n = put $ SmallNat n+putPackedInt n = put $ SmallInt n+getPackedNat,getPackedInt :: Get Int+getPackedNat = liftM fromSmallNat get+getPackedInt = liftM fromSmallInt get++newtype ShortList a = ShortList {fromShortList :: [a]}+instance Binary a => Binary (ShortList a) where+    put (ShortList as) = putPackedNat (length as) >> mapM_ put as+    get = do+	n <- getPackedNat+	ShortList `liftM` getMany n++ -- | 'getMany n' get 'n' elements in order, without blowing the stack.+ -- [ copied from source of package 'binary' by Lennart Kolmodin ]+getMany :: Binary a => Int -> Get [a]+getMany = go []+ where+    go xs 0 = return $! reverse xs+    go xs i = do x <- get+                 -- we must seq x to avoid stack overflows due to laziness in+                 -- (>>=)+                 x `seq` go (x:xs) (i-1)+{-# INLINE getMany #-}++instance Binary HexVec where+    put (HexVec x y _) = putPackedInt x >> putPackedInt y+    get = do +	x <- getPackedInt+	y <- getPackedInt+	return $ tupxy2hv (x,y)+instance Binary g => Binary (PHS g) where+    put (PHS v) = put v+    get = liftM PHS get+instance Binary GameState where+    put (GameState pps conns) = put (ShortList $ Vector.toList pps) >> put (ShortList conns)+    get = liftM2 GameState (liftM (Vector.fromList . fromShortList) get) (liftM fromShortList get)+instance Binary PlacedPiece where+    put (PlacedPiece ppos p) = put ppos >> put p+    get = liftM2 PlacedPiece get get+instance Binary Piece where+    put (Block patt) = put (0::Word8) >> put (ShortList patt)+    put (Pivot arms) = put (1::Word8) >> put (ShortList arms)+    put (Hook arm stiffness) = put (2::Word8) >> put arm >> put stiffness+    put (Wrench mom) = put (3::Word8) >> put mom+    put Ball = put (4::Word8)+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> liftM (Block . fromShortList) get+	    1 -> liftM (Pivot . fromShortList) get+	    2 -> liftM2 Hook get get+	    3 -> liftM Wrench get+	    4 -> return Ball+instance Binary Connection where+    put (Connection (ri,rp) (ei,ep) l) = putPackedInt ri >> put rp >> putPackedInt ei >> put ep >> put l+    get = do+	ri <- getPackedInt+	rp <- get+	ei <- getPackedInt+	ep <- get+	l <- get+	return $ Connection (ri,rp) (ei,ep) l+instance Binary Link where+    put (Free p) = put (0::Word8) >> put p+    put (Spring d l) = put (1::Word8) >> put d >> putPackedInt l+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> liftM Free get+	    1 -> liftM2 Spring get getPackedInt+instance Binary HookForce where+    put NullHF = put (0::Word8)+    put (TorqueHF dir) = put (1::Word8) >> putPackedInt dir+    put (PushHF v) = put (2::Word8) >> put v+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> return NullHF+	    1 -> liftM TorqueHF getPackedInt+	    2 -> liftM PushHF get+instance Binary Frame where+    put (BasicFrame s) = putPackedInt s+    get = liftM BasicFrame getPackedInt++instance Binary PlayerMove where+    put NullPM = put (0::Word8)+    put (HookPush v) = put (1::Word8) >> put v+    put (HookTorque dir) = put (2::Word8) >> putPackedInt dir+    put (WrenchPush v) = put (3::Word8) >> put v+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> return NullPM+	    1 -> liftM HookPush get+	    2 -> liftM HookTorque getPackedInt+	    3 -> liftM WrenchPush get+
+ BoardColouring.hs view
@@ -0,0 +1,93 @@+-- 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 BoardColouring where++import Control.Applicative hiding ((<*>))+import Control.Monad+import Data.Function (on)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as Vector+import Data.List+import Data.Maybe++import Hex+import GameState+import GameStateTypes+import Util+import GraphColouring++type PieceColouring = Map PieceIdx Int++colouredPieces :: Bool -> GameState -> [PieceIdx]+colouredPieces colourFixed st = [ idx |+    (idx, PlacedPiece _ p) <- enumVec $ placedPieces st+    , isPivot p ||+	and [ isBlock p, idx > 0+	      , or [ colourFixed, not $ null $ springsEndAtIdx st idx ] ] ]++pieceTypeColouring :: GameState -> [PieceIdx] -> PieceColouring+pieceTypeColouring st coloured = Map.fromList+    [ (idx, col) | (idx, PlacedPiece _ p) <- enumVec $ placedPieces st+	, idx `elem` coloured+	, let col = if isBlock p then 1+((connGraphHeight st idx - 1) `mod` 5) else 0 ]+    ++boardColouring :: GameState -> [PieceIdx] -> PieceColouring -> PieceColouring+boardColouring st coloured lastCol =+   fiveColour graph lastCol+    where+	board = stateBoard st+	graph = Map.fromList [ (idx, nub $ neighbours idx)+	    | idx <- coloured ]+	neighbours idx = +	    neighbours' idx (perim idx) []+	perim :: PieceIdx -> Set (HexPos,HexDir)+	perim idx =+	    Set.fromList $ nubBy ((==)`on`fst) [ (pos', neg dir)+		| dir <- hexDirs+		, pos <- fullFootprint st idx+		, let pos' = dir <+> pos+		, Just True /= do+		    (idx',_) <- Map.lookup pos' board+		    return $ idx == idx'+		]+	neighbours' :: PieceIdx -> Set (HexPos,HexDir) -> [PieceIdx] -> [PieceIdx]+	neighbours' idx as ns +	    | Set.null as = ns+	    | otherwise =+		let a = head $ Set.elems as+		    (path, ns') = march idx (fst a) a True+		in neighbours' idx+		    (Set.filter (\(pos,_) -> pos `notElem` path) as)+		    (ns++ns')+	-- |march around the piece's boundary, returning positions visited and+	-- neighbouring pieces met (in order)+	march idx startPos (pos,basedir) init+	    | not init && pos == startPos = ([],[])+	    | otherwise =+	    let n = do +		    (idx',_) <- Map.lookup pos board+		    guard $ idx' `elem` coloured+		    return idx'+		mNext = listToMaybe +		    [ (pos', rotate (h-2) basedir)+		    | h <- [1..5] +		    , let pos' = (rotate h basedir)<+>pos+		    , (fst <$> Map.lookup pos' board) /= Just idx+		    ]+		(path,ns) = case mNext of+		    Nothing -> ([],[])+		    Just next -> march idx startPos next False+	    in (pos:path, (maybeToList n)++ns)+
+ COPYING view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ CVec.hs view
@@ -0,0 +1,29 @@+-- 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 CVec where++import Hex+import Data.Monoid++data CVec = CVec { cy, cx :: Int }+    deriving (Eq, Ord, Show)+instance Monoid CVec where+    mempty = CVec 0 0+    mappend (CVec y x) (CVec y' x') = CVec (y+y') (x+x')+instance Grp CVec where+    neg (CVec y x) = CVec (-y) (-x) +type CCoord = PHS CVec++hexVec2CVec :: HexVec -> CVec+hexVec2CVec (HexVec x y z) = CVec (-y) (x-z) +cVec2HexVec :: CVec -> HexVec+cVec2HexVec (CVec y x) = HexVec ((x+y)`div`2) (-y) ((y-x)`div`2)+
+ Cache.hs view
@@ -0,0 +1,96 @@+-- 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 Cache where++import Network.Fancy+import Control.Concurrent.STM+import Control.Concurrent+import Control.Applicative+import Control.Exception+import Control.Monad.Trans.Reader+import System.Directory+import Control.Monad+import Data.Maybe+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Binary+import System.IO+import System.FilePath++import Database+import Protocol+import Metagame+import Mundanities+import ServerAddr++data FetchedRecord = FetchedRecord {fresh :: Bool, fetchError :: Maybe String, fetchedRC :: Maybe RecordContents}+    deriving (Eq, Ord, Show)+++getRecordCached :: ServerAddr -> Maybe Auth -> Maybe (TVar Bool) -> Bool -> Record -> IO (TVar FetchedRecord)+getRecordCached saddr auth mflag cOnly rec = do+    fromCache <- withCache saddr $ getRecord rec+    let fresh = isJust fromCache && invariantRecord rec+    tvar <- atomically $ newTVar $ FetchedRecord fresh Nothing fromCache+    unless (cOnly || fresh) $ void $ forkIO $ getRecordFromServer fromCache tvar+    return tvar+    where+	getRecordFromServer fromCache tvar = do+	    let action = case rec of+		    RecUserInfo name ->+			let curVersion = (\(RCUserInfo (v,_)) -> v) <$> fromCache+			in GetUserInfo name curVersion +		    _ -> askForRecord rec+	    resp <- makeRequest saddr (ClientRequest+		    protocolVersion (if needsAuth action then auth else Nothing) action)+	    case resp of+		ServerError err -> tellRec $ FetchedRecord True (Just err) fromCache+		ServerCodenameFree -> tellRec $ FetchedRecord True Nothing Nothing+		ServerFresh -> tellRec $ FetchedRecord True Nothing fromCache+		ServedUserInfoDeltas deltas -> do+		    let Just (RCUserInfo (v,info)) = fromCache+		    let rc = RCUserInfo (v+length deltas, applyDeltas info deltas)+		    withCache saddr $ putRecord rec rc+		    tellRec $ FetchedRecord True Nothing (Just rc)+		_ -> do+		    let rc = rcOfServerResp resp+		    withCache saddr $ putRecord rec rc+		    tellRec $ FetchedRecord True Nothing (Just rc)+	    where+		tellRec fr = atomically $ do+		    writeTVar tvar fr+		    case mflag of {Just flag -> writeTVar flag True; _ -> return ()}++waitFetchedFresh :: TVar FetchedRecord -> IO ()+waitFetchedFresh tvar = atomically $ readTVar tvar >>= check.fresh++makeRequest :: ServerAddr -> ClientRequest -> IO ServerResponse+makeRequest saddr@(ServerAddr host port) request =+    handle (return . ServerError . (show::SomeException -> String)) $+	withStream (IP host port) makeRequest'+	    `catchIO` (const $ return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!")+    where+	makeRequest' hdl = do+	    BS.hPut hdl $ BL.toStrict $ encode request +	    hFlush hdl+	    (decode . BL.fromStrict) `liftM` BS.hGetContents hdl++knownServers :: IO [ServerAddr]+knownServers = flip catchIO (const $ return []) $ do+    cachedir <- confFilePath "cache"+    saddrstrs <- getDirectoryContents cachedir >>= filterM (\dir ->+	doesDirectoryExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"intricacydb"++[pathSeparator])+    return $ concat $ map (maybeToList . strToSaddr) saddrstrs++withCache :: ServerAddr -> DBM a -> IO a+withCache saddr m = do+    cachedir <- (++[pathSeparator]++saddrStr saddr) `liftM` confFilePath "cache"+    runReaderT m cachedir
+ Command.hs view
@@ -0,0 +1,112 @@+-- 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 Command where+import Hex+import GameStateTypes+import Metagame++data Command = CmdDir WrHoSel HexDir | CmdRotate TorqueDir | CmdWait+	| CmdMoveTo HexPos | CmdManipulateToolAt HexPos+	| CmdDrag HexPos HexDir+	| CmdToggle+	| CmdOpen+	| CmdTile Tile | CmdPaint (Maybe Tile)+	| CmdPaintFromTo (Maybe Tile) HexPos HexPos+	| CmdSelect | CmdUnselect+	| CmdDelete | CmdMerge+	| CmdMark | CmdJumpMark+	| CmdPlay | CmdTest+	| CmdUndo | CmdRedo+	| CmdReplayForward Int | CmdReplayBack Int+	| CmdInputChar Char+	| CmdInputSelLock LockIndex | CmdInputCodename Codename | CmdInputSelUndecl Undeclared+	| CmdWriteState+	| CmdTutorials+	| CmdShowRetired | CmdPlayLockSpec (Maybe LockSpec)+	| CmdSetServer | CmdToggleCacheOnly+	| CmdSelCodename (Maybe Codename) | CmdBackCodename | CmdHome+	| CmdSolve (Maybe LockIndex) | CmdDeclare (Maybe Undeclared)+	| CmdViewSolution (Maybe NoteInfo)+	| CmdSelectLock | CmdNextLock | CmdPrevLock+	| CmdEdit | CmdPlaceLock (Maybe LockIndex)+	| CmdRegister | CmdAuth+	| CmdNextPage | CmdPrevPage+	| CmdRedraw | CmdRefresh | CmdSuspend+	| CmdQuit | CmdForceQuit+	| CmdHelp | CmdBind+	| CmdNone+    deriving (Eq, Ord, Show, Read)+data WrHoSel = WHSWrench | WHSHook | WHSSelected+    deriving (Eq, Ord, Show, Read)+	+describeCommand :: Command -> String+describeCommand (CmdDir whs dir) = "move " ++ whsStr whs ++ " " ++ dirStr dir+describeCommand (CmdRotate dir) = "rotate " ++ (if dir == 1 then "counter" else "") ++ "clockwise"+describeCommand CmdWait = "nothing"+describeCommand CmdToggle = "toggle tool"+describeCommand CmdOpen = "open lock"+describeCommand (CmdTile tile) = tileStr tile+describeCommand CmdMerge = "merge with adjacent piece" +describeCommand CmdMark = "mark state"+describeCommand CmdJumpMark = "jump to marked state"+describeCommand CmdSelect = "select piece" +describeCommand CmdUnselect = "unselect piece"+describeCommand CmdDelete = "delete piece"+describeCommand CmdPlay = "play lock"+describeCommand CmdTest = "test lock"+describeCommand CmdUndo = "undo"+describeCommand CmdRedo = "redo"+describeCommand (CmdReplayForward _) = "advance replay"+describeCommand (CmdReplayBack _) = "rewind replay"+describeCommand CmdWriteState = "write lock"+describeCommand CmdTutorials = "play tutorial levels"+describeCommand CmdShowRetired = "show retired locks"+describeCommand CmdSetServer = "set server"+describeCommand CmdToggleCacheOnly = "toggle using only cache"+describeCommand (CmdSelCodename mname) = "select player" ++ maybe "" (' ':) mname+describeCommand CmdBackCodename = "select last player"+describeCommand CmdHome = "select self"+describeCommand (CmdSolve mli) = "solve lock" ++ maybe "" ((' ':).(:"").lockIndexChar) mli+describeCommand (CmdPlayLockSpec mls) = "find lock by number" ++ maybe "" ((' ':).show) mls+describeCommand (CmdDeclare mundecl) = "declare solution" ++ maybe "" (\_->" [specified solution]") mundecl+describeCommand (CmdViewSolution mnote) = "view lock solution" ++ maybe "" (\_->" [specified solution]") mnote+describeCommand CmdSelectLock = "choose lock"+describeCommand CmdNextLock = "next lock"+describeCommand CmdPrevLock = "previous lock"+describeCommand CmdNextPage = "page forward through lists"+describeCommand CmdPrevPage = "page back through lists"+describeCommand CmdEdit = "edit lock"+describeCommand (CmdPlaceLock mli) = "place lock" ++ maybe "" ((' ':).(:"").lockIndexChar) mli+describeCommand CmdRegister = "register codename"+describeCommand CmdAuth = "authenticate"+describeCommand CmdBind = "bind key"+describeCommand CmdQuit = "quit"+describeCommand CmdHelp = "help"+describeCommand _ = ""++tileStr HookTile = "hook"+tileStr (WrenchTile _) = "wrench"+tileStr (ArmTile _ _) = "arm"+tileStr (PivotTile _) = "pivot"+tileStr (SpringTile _ _) = "spring"+tileStr (BlockTile _) = "block"+tileStr BallTile = "ball"+whsStr WHSWrench = "wrench"+whsStr WHSHook = "hook"+whsStr WHSSelected = "tool"+dirStr v+    | v == hu = "right"+    | v == neg hu = "left"+    | v == hv = "up-left"+    | v == neg hv = "down-right"+    | v == hw = "down-left"+    | v == neg hw = "up-right"+dirStr _ = ""
+ CursesRender.hs view
@@ -0,0 +1,98 @@+-- 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 CursesRender where++import qualified UI.HSCurses.Curses as Curses+import Data.Char (ord)+import qualified Data.Map as Map+import Data.Map (Map)++import Hex+import CVec+import GameStateTypes+import BoardColouring (PieceColouring)++-- From Curses.CursesHelper:+-- | Converts a list of 'Curses.Color' pairs (foreground color and+--   background color) into the curses representation 'Curses.Pair'.+colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair]+colorsToPairs cs =+    do p <- Curses.colorPairs+       let nColors = length cs+           blackWhite = p < nColors+       if blackWhite then do+	    print ("Terminal does not support enough colors. Number of " +++                      " colors requested: " ++ show nColors +++                      ". Number of colors supported: " ++ show p)+	    return $ replicate nColors $ Curses.Pair 0+          else mapM toPairs (zip [1..] cs)+     where toPairs (n, (fg, bg)) =+               let p = Curses.Pair n+               in do Curses.initPair p fg bg+                     return p++type AttrChar = (Char, Curses.Attr)+type ColPair = Int+white,red,green,yellow,blue,magenta,cyan :: ColPair+white = 0+red = 1+green = 2+yellow = 3+blue = 4+magenta = 5+cyan = 6+data Glyph = Glyph Char ColPair Curses.Attr+a0 = Curses.attr0+bold = Curses.setBold a0 True+tileChar :: Tile -> AttrChar+tileChar (BlockTile _) = ('#',a0)+tileChar (PivotTile dir) | dir == zero = ('o',bold)+    | canonDir dir == hu = ('-',bold)+    | canonDir dir == hv = ('\\',bold)+    | canonDir dir == hw = ('/',bold)+tileChar (ArmTile dir principal) = let+    cdir = canonDir dir+    c | cdir == hu = '-'+      | cdir == hv = '\\'+      | cdir == hw = '/'+      | otherwise = '?'+    a = if principal then bold else a0+    in (c,a)+tileChar HookTile = ('@',bold)+tileChar (WrenchTile mom) = ('*',if mom /= zero then bold else a0)+tileChar BallTile = ('O',a0)+tileChar (SpringTile Relaxed _) = ('S',a0)+tileChar (SpringTile Compressed _) = ('$',bold)+tileChar (SpringTile Stretched _) = ('s',bold)+tileChar _ = ('?',bold)++ownedTileGlyph :: PieceColouring -> [PieceIdx] -> OwnedTile -> Glyph+ownedTileGlyph colouring reversed (owner,t) =+    let (ch,attr) = tileChar t+	pair = case Map.lookup owner colouring of+		    Nothing -> 0+		    Just n -> n+1+	rev = owner `elem` reversed+    in Glyph ch pair (Curses.setReverse attr rev)++addCh :: Char ->  IO ()+addCh c = Curses.wAddStr Curses.stdScr [c]+mvAddCh :: CVec -> Char ->  IO ()+mvAddCh (CVec y x) c = Curses.mvAddCh y x $ fromIntegral $ ord c+mvAddStr :: CVec -> String -> IO ()+mvAddStr (CVec y x) = Curses.mvWAddStr Curses.stdScr y x+mvAddGlyph :: [Curses.Pair] -> CVec -> Glyph -> IO ()+mvAddGlyph cpairs v (Glyph ch col attr) =+    Curses.attrSet attr (cpairs!!col) >> mvAddCh v ch+move :: CVec -> IO ()+move (CVec y x) = Curses.move y x+clearLine :: Int -> IO ()+clearLine y = Curses.move y 0 >> Curses.clrToEol
+ CursesUI.hs view
@@ -0,0 +1,140 @@+-- 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 CursesUI where++import qualified UI.HSCurses.Curses as Curses+import Control.Concurrent.STM+import Control.Applicative+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Array+import Data.Maybe+import Data.List+import Control.Monad.Trans.Maybe+import Control.Monad.State+import Data.Function (on)++import Hex+import GameState (stateBoard)+import GameStateTypes+import BoardColouring+import Frame+import KeyBindings+import Command+import Mundanities+import ServerAddr+import InputMode+import CursesRender+import CVec++data UIState = UIState { dispCPairs::[Curses.Pair], dispCentre::HexPos+    , dispLastCol::PieceColouring, uiKeyBindings :: Map InputMode KeyBindings+    , message::Maybe (Curses.Attr, ColPair, String)}+type UIM = StateT UIState IO+nullUIState = UIState [] (PHS zero) Map.empty Map.empty Nothing++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++getBindings mode = do+    uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+    return $ uibdgs ++ bindings mode++bindingsStr :: InputMode -> [Command] -> UIM String+bindingsStr mode cmds = do+    uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+    return $ (\x -> "["++x++"]") $ intercalate "," $+	[ maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd+	    | cmd <- cmds ]+++erase :: UIM ()+erase = liftIO Curses.erase+refresh :: UIM ()+refresh = liftIO Curses.refresh++type Geom = (CVec, HexPos)+getGeom :: UIM Geom+getGeom = do +    (h,w) <- liftIO Curses.scrSize+    centre <- gets dispCentre+    return (CVec (h`div`2) (w`div`2), centre)++drawAt :: Glyph -> HexPos -> UIM ()+drawAt gl pos =+    drawAtWithGeom gl pos =<< getGeom+drawAtWithGeom gl pos geom@(scrCentre,centre) =+    drawAtCVec gl $ scrCentre <+> (hexVec2CVec $ pos <-> centre)+drawAtCVec :: Glyph -> CVec -> UIM ()+drawAtCVec gl cpos = do+    cpairs <- gets dispCPairs+    liftIO $ mvAddGlyph cpairs cpos gl++drawStr :: Curses.Attr -> ColPair -> CVec -> String -> UIM ()+drawStr attr col v str = do+    cpairs <- gets dispCPairs+    liftIO $ Curses.attrSet attr (cpairs!!col) >> mvAddStr v str+drawStrGrey :: CVec -> String -> UIM ()+drawStrGrey = drawStr a0 0+drawStrCentred attr col v str =+    drawStr attr col (v <+> CVec 0 (-length str `div` 2)) str++drawCursorAt :: Maybe HexPos -> UIM ()+drawCursorAt Nothing =+    void $ liftIO $ Curses.cursSet Curses.CursorInvisible+drawCursorAt (Just pos) = do +    geom@(scrCentre,centre) <- getGeom+    liftIO $ Curses.cursSet Curses.CursorVisible+    liftIO $ move $ scrCentre <+> (hexVec2CVec $ pos <-> centre)++drawState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM ()+drawState reversed colourFixed alerts st = do+    lastCol <- gets dispLastCol+    colouring <- drawStateWithGeom reversed colourFixed lastCol st =<< getGeom+    modify $ \ds -> ds { dispLastCol = colouring }++-- TODO: monochrome mode+drawStateWithGeom reversed colourFixed lastCol st geom = do+    let colouring = boardColouring st (colouredPieces colourFixed st) lastCol+    sequence_ [ drawAtWithGeom glyph pos geom | +	(pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring reversed) $ stateBoard st+	]+    return colouring++drawMsgLine = void.runMaybeT $ do+    (attr,col,str) <- MaybeT $ gets message+    lift $ do+	(h,w) <- liftIO Curses.scrSize+	liftIO $ clearLine $ h-1+	drawStr attr col (CVec (h-1) 0) $ take (w-1) str+setMsgLine attr col str = do+    modify $ \s -> s { message = Just (attr,col,str) }+    drawMsgLine+    refresh++drawTitle (Just title) = do+    (h,w) <- liftIO Curses.scrSize+    drawStrCentred a0 white (CVec 0 (w`div`2)) title+drawTitle Nothing = return ()+    +say = setMsgLine bold white+sayError = setMsgLine bold red
+ CursesUIMInstance.hs view
@@ -0,0 +1,343 @@+-- 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/.++{-# LANGUAGE FlexibleInstances #-}+module CursesUIMInstance () where++import qualified UI.HSCurses.Curses as Curses+import qualified UI.HSCurses.CursesHelper as CursesH+import Control.Concurrent.STM+import Control.Applicative+import Data.Char (ord)+import Data.Monoid+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Array+import Data.Maybe+import Data.List+import Control.Monad.Trans.Maybe+import Control.Concurrent (threadDelay)+import Control.Monad.State+import Data.Function (on)+import Data.Foldable (for_)++import Hex+import GameStateTypes+import Physics+import Frame+import Command+import KeyBindings+import ServerAddr+import Cache+import Database+import Metagame+import Protocol+import Util+import InputMode+import MainState+import CursesUI+import CursesRender+import CVec+++drawName :: Bool -> CVec -> Codename -> StateT MainState UIM ()+drawName showScore pos name = do+    ourName <- (authUser <$>) <$> gets curAuth+    relScore <- getRelScore name+    let (attr,col) = case relScore of+	    Just 0 -> (a0,yellow)+	    Just 1 -> (bold,cyan) +	    Just 2 -> (a0,green) +	    Just 3 -> (bold,green) +	    Just (-1) -> (bold,magenta)+	    Just (-2) -> (a0,red)+	    Just (-3) -> (bold,red)+	    _ -> if ourName == Just name then (bold,white) else (a0,white)+    lift $ drawStrCentred attr col pos+	(name ++ if showScore then " " ++ maybe "" show relScore else "")++drawActiveLock :: CVec -> ActiveLock -> StateT MainState UIM ()+drawActiveLock pos (ActiveLock name i) = do+    drawName False (pos <+> CVec 0 (-1)) name+    lift $ drawStr bold white (pos <+> CVec 0 1) [':',lockIndexChar i]++data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre+    deriving (Eq, Ord, Show, Enum)+fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> StateT MainState UIM ()] -> StateT MainState UIM Int+fillBox (CVec t l) (CVec b r) width grav draws = do+    let half = width`div`2+	starty = (if grav == GravDown then b else t)+	cv = (b+t)`div`2+	ch = (l+r)`div`2+	gravCentre = case grav of+	    GravDown   -> CVec b ch+	    GravUp     -> CVec t ch+	    GravLeft   -> CVec cv l+	    GravRight  -> CVec cv r+	    GravCentre -> CVec cv ch+	locs = sortBy (compare `on` dist) $ concat+	    [ map (CVec j) [ l+margin + (width+1)*i | i <- [0..(r-l-(2*margin))`div`(width+1)] ]+	    | j <- [t..b]+	    , let margin = if (j-starty)`mod`2 == 0 then half else width ]+	dist v = sqlen $ v <-> gravCentre+	sqlen (CVec y x) = (y*(width+1))^2+x^2+    selDraws <- do+	    offset <- gets listOffset+	    let na = length locs+		nd = length draws+	    return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws+    let zipped = zip locs selDraws+    sequence_ $ map (uncurry ($)) $ zip selDraws locs+    return $ (if grav==GravDown then (minimum.(b:)) else (maximum.(t:))) [ y | (CVec y x,_) <- zipped ]++drawLockInfo al@(ActiveLock name i) lockinfo = do+    (h,w) <- liftIO Curses.scrSize+    let [left,vcentre,right] = [ (k+2*i)*w`div`6 + (1-k) | k <- [0,1,2] ]+    let [top,bottom] = [6, h-1]+    let hcentre = (top+bottom)`div`2 - 1+    ourName <- (authUser <$>) <$> gets curAuth++    (lockTop, lockBottom) <- (fromJust<$>)$ runMaybeT $ msum+	[ do+	    lock <- mgetLock $ lockSpec lockinfo+	    let size = frameSize $ fst lock+	    guard $ bottom - top >= 5 + 2*size+1 + 1 + 5 && right-left >= 4*size+1+	    lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin)+	    return (hcentre - size - 1, hcentre + size + 1)+	, lift $ do+	    drawActiveLock (CVec hcentre vcentre) al+	    return (hcentre - 1, hcentre + 1)+	]++    startOn <-+	if (public lockinfo) +	then lift $ drawStrCentred bold white (CVec (lockTop-1) vcentre) "Everyone!"+	    >> return (lockTop-1)+	else if null $ accessedBy lockinfo+	    then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "No-one"+		>> return (lockTop-1)+	    else+		fillBox (CVec (top+1) (left+1)) (CVec (lockTop-1) (right-1)) 3 GravDown $+		    [ \pos -> drawName False pos name | name <- accessedBy lockinfo ]+    lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Accessed by:"+    +    undecls <- gets undeclareds+    if isJust $ guard . (|| public lockinfo) . (`elem` accessedBy lockinfo) =<< ourName+    then lift $ drawStrCentred a0 green (CVec (lockBottom+1) vcentre) "Accessed!"+    else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls+    then lift $ drawStrCentred a0 yellow (CVec (lockBottom+1) vcentre) "Undeclared solution!"+    else do+	read <- take 3 <$> getNotesReadOn lockinfo+	unless (null read || ourName == Just name) $ do+	    let rntext = if right-left > 30 then "Read notes by:" else "Notes:"+		s = vcentre - (length rntext+(3+1)*3)`div`2+	    lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext+	    void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft+		[ \pos -> drawName False pos name | name <- map noteAuthor read ]++    lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:"+    if null $ notesSecured lockinfo+	then lift $+	    drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None"+	else+	    void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp+		[ (`drawActiveLock` al) | al <- map noteOn $ notesSecured lockinfo ]++charify :: Curses.Key -> Maybe Char+charify key = case key of+    Curses.KeyChar ch -> Just ch+    Curses.KeyBackspace -> Just '\b'+    Curses.KeyLeft -> Just '4'+    Curses.KeyRight -> Just '6'+    Curses.KeyDown -> Just '2'+    Curses.KeyUp -> Just '8'+    Curses.KeyHome -> Just '7'+    Curses.KeyNPage -> Just '3'+    Curses.KeyPPage -> Just '9'+    Curses.KeyEnd -> Just '1'+    _ -> Nothing++instance UIMonad (StateT UIState IO) where+    runUI m = evalStateT m nullUIState++    drawMainState = do+	lift erase+	s <- get+	lift . drawTitle =<< getTitle+	lift drawMsgLine+	drawMainState' s+	lift refresh+	where+	drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel }) = lift $ do+	    drawState [] False alerts st+	    drawCursorAt $ listToMaybe [ pos |+		(_, PlacedPiece pos p) <- enumVec $ placedPieces st+		, or [wsel && isWrench p, not wsel && isHook p] ]+	drawMainState' (ReplayState {}) = do+	    lift . drawState [] False [] =<< gets rsCurrentState+	    lift $ drawCursorAt Nothing+	drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece, selectedPos=selPos }) = lift $ do+	    drawState (maybeToList selPiece) True [] st+	    drawCursorAt $ if isNothing selPiece then Just selPos else Nothing+	drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path lock _) = do+	    let ourName = liftM authUser auth+	    let selName = listToMaybe names+	    (h,w) <- liftIO Curses.scrSize+	    when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!"+	    lift $ do+		drawCursorAt Nothing+		sstr <- (++"   Server: ") <$> bindingsStr IMMeta [CmdSetServer, CmdToggleCacheOnly]+		hstr <- (\[ks,ts] -> ts++" tut   "++ks++" keys") <$>+		    bindingsStr IMMeta `mapM` [[CmdHelp],[CmdTutorials]]+		drawStrGrey (CVec 0 0) $ sstr +++		    take (w - length sstr - length hstr)+			(saddrStr saddr ++ (if cOnly then "  (cache only) " else "") ++ repeat ' ') +++		    hstr+		drawStrGrey (CVec 1 0) =<<+		    (\[es,ls] -> take 5 (es ++ repeat ' ') ++ "   Lock: " ++ path ++ "     " ++ ls) <$>+			bindingsStr IMMeta `mapM`+			    [ [CmdEdit] ++ if path == "" then [] else [CmdPlaceLock Nothing]+			    , [CmdSelectLock] ++ if path == "" then [] else [CmdNextLock, CmdPrevLock]+			    ]+	    lift $ drawStrGrey (CVec 2 (maximum [w`div`3+1, w`div`2 - 13])) =<< bindingsStr IMMeta [CmdSelCodename Nothing]+	    maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName+	    void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=+		\(FetchedRecord fresh err muirc) -> lift $ do+		    lift $ do+			unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7)+			maybe (return ()) sayError err+			when (fresh && isNothing ourName) $+			    drawStrGrey (CVec 2 (w`div`2+1+9)) =<<+				(bindingsStr IMMeta $ if isNothing muirc then [CmdRegister] else [CmdAuth])+		    for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of+			Just retired -> do+			    (h,w) <- liftIO Curses.scrSize+			    void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre+				[ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ]+			    lift $ drawStrGrey (CVec 5 (w`div`3)) =<< bindingsStr IMMeta+				([CmdShowRetired] ++ if null retired then [] else [CmdPlayLockSpec Nothing])+			Nothing -> do+			    sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo |+				(i,Just lockinfo) <- assocs $ userLocks uinfo ]+			    unless (null $ elems $ userLocks uinfo) $ lift $+				drawStrGrey (CVec 5 (w`div`3)) =<< bindingsStr IMMeta [CmdSolve Nothing, CmdViewSolution Nothing]+	    when (isJust ourName && ourName == selName) $ do+		unless (null undecls) $ do+		    str <- lift $ (++" Undeclared solutions:") <$> bindingsStr IMMeta [CmdDeclare Nothing]+		    let s = max 1 $ (w-(length str + 6*length undecls))`div`2+		    let y = 4+		    lift $ drawStr bold white (CVec y s) str+		    void $ fillBox (CVec y (s+length str+1)) (CVec y (w-1)) 5 GravLeft+			[ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ]+		rnames <- liftIO $ atomically $ readTVar rnamestvar+		unless (null rnames) $+		    void $ fillBox (CVec 2 5) (CVec 5 (w`div`3)) 3 GravCentre+			[ \pos -> drawName False pos name | name <- rnames ]+	    when (ourName /= selName) $ void $ runMaybeT $ do+		sel <- MaybeT $ return selName+		us <- MaybeT $ return ourName+		ourUInfo <- mgetUInfo us+		let accessed = [ ActiveLock us i +			| i<-[0..2]+			, Just lock <- [ userLocks ourUInfo ! i ]+			, public lock || selName `elem` map Just (accessedBy lock) ]+		guard $ not $ null accessed+		let str = "has accessed:"+		let s = (w-(4 + length str + 6*(length accessed)))`div`2+		let y = 4+		lift $ do+		    drawName False (CVec y (s+1)) sel+		    lift $ drawStrGrey (CVec y $ s+4) str+		    void $ fillBox (CVec y (s+4+length str+1)) (CVec y (w-1)) 5 GravLeft $+			[ (`drawActiveLock` al) | al <- accessed]++    drawAlerts alerts =+	do mapM_ drawAlert alerts+	   unless (null alerts) +	    $ do refresh+		 liftIO $ threadDelay $ 5*10^4+	where+	    drawAlert (AlertCollision pos) = drawAt cGlyph pos+	    drawAlert _ = return ()+	    cGlyph = Glyph '!' 0 a0++    drawMessage = say+    drawError = sayError++    showHelp mode = do+	bdgs <- nub <$> getBindings mode+	erase+	(h,w) <- liftIO Curses.scrSize+	let bdgWidth = 35+	    showKeys chs = intercalate "/" (map showKey chs)+	    maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs+	drawStrCentred a0 white (CVec 0 (w`div`2)) "Bindings:"+	sequence_ [ drawStr a0 white (CVec (y+2) (x*bdgWidth) ) $+		keysStr ++ replicate pad ' ' ++ ": " ++ desc |+	    ((keysStr,pad,desc),(x,y)) <- zip [(keysStr,pad,desc)+		    | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs+		    , let cmd = snd $ head group+		    , let desc = describeCommand cmd+		    , not $ null desc+		    , let chs = map fst group+		    , let keysStr = showKeys chs+		    , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr,+			    bdgWidth - length desc - length keysStr - 1]+		    ]+		(map (`divMod` (h-3)) [0..])+	    , (x+1)*bdgWidth < w]+	refresh+	void $ getInput mode++    getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ())+    setUIBinding mode cmd ch =+	modify $ \s -> s { uiKeyBindings =+		Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdgs ++ [bdg])+		    mode [(ch,cmd)] $ uiKeyBindings s }++    initUI = +	do liftIO CursesH.start +	   cpairs <- liftIO $ colorsToPairs [ (f, CursesH.black) | f <-+		[ CursesH.white, CursesH.red, CursesH.green, CursesH.yellow, CursesH.blue, CursesH.magenta, CursesH.cyan] ] +	   modify $ \s -> s {dispCPairs = cpairs}+	   readBindings+	   return True++    endUI = do+	writeBindings+	liftIO CursesH.end+    unblockInput = return $ Curses.ungetCh 0+    suspend = do+	liftIO $ do+	    CursesH.suspend +	    Curses.resetParams +	redraw+    redraw = liftIO $ do+	Curses.endWin+	Curses.refresh++    warpPointer _ = return ()++    getDrawImpatience = return $ \_ -> return ()++    getInput mode = do+	let userResizeCode = 1337  -- XXX: chosen not to conflict with HSCurses codes+	key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode)+	if key == Curses.KeyUnknown userResizeCode+	    then do+		liftIO Curses.scrSize+		return [CmdRedraw]+	    else do+		let mch = charify key+		    unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above+		flip (maybe $ return []) mch $ \ch ->+		    if mode == IMTextInput+		    then return [CmdInputChar ch]+		    else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode
+ Database.hs view
@@ -0,0 +1,201 @@+-- 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 Database where++-- TODO: use ByteString everywhere++import Control.Applicative+import Control.Monad+import System.IO+import System.FilePath+import System.Directory+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy.Char8 as CL+import qualified Data.ByteString.Char8 as CS++--import OpenSSL.Digest (MessageDigest(SHA1), toHex)+--import OpenSSL.Digest.ByteString.Lazy (digest)+--import Data.Digest.Pure.SHA (sha1, showDigest)+--see also OpenSSL.EVP.Digest from HsOpenSSL+import Crypto.Hash (hashlazy, Digest, SHA1, digestToHexByteString)++import Protocol+import Metagame+import Lock+import Mundanities++--hash :: String -> IO String+--hash str = fmap (>>=toHex) $ digest SHA1 $ CL.pack $ str+sha1 :: CL.ByteString -> Digest SHA1+sha1 = hashlazy+hash :: String -> String+hash = CS.unpack . digestToHexByteString . sha1 . CL.pack+++data Record+    = RecPassword Codename+    | RecUserInfo Codename+    | RecUserInfoLog Codename+    | RecLock LockSpec+    | RecNote NoteInfo+    | RecLockHashes+    | RecRetiredLocks Codename+    | RecServerInfo+    deriving (Eq, Ord, Show)+data RecordContents+    = RCPassword Password+    | RCUserInfo VersionedUInfo+    | RCUserInfoDeltas [UserInfoDelta]+    | RCLock Lock+    | RCSolution Solution+    | RCLockHashes [String]+    | RCLockSpecs [LockSpec]+    | RCServerInfo ServerInfo+    deriving (Eq, Ord, Show)++rcOfServerResp (ServedServerInfo x) = RCServerInfo x+rcOfServerResp (ServedLock x) = RCLock x+rcOfServerResp (ServedSolution x) = RCSolution x+rcOfServerResp (ServedUserInfo x) = RCUserInfo x+rcOfServerResp (ServedRetired x) = RCLockSpecs x+rcOfServerResp _ = error "no corresponding rc"++invariantRecord (RecUserInfo _) = False+invariantRecord (RecUserInfoLog _) = False+invariantRecord (RecPassword _) = False+invariantRecord (RecRetiredLocks _) = False+invariantRecord (RecNote _) = False+invariantRecord _ = True++askForRecord RecServerInfo = GetServerInfo+askForRecord (RecUserInfo name) = GetUserInfo name Nothing+askForRecord (RecLock ls) = GetLock ls+askForRecord (RecNote note) = GetSolution note+askForRecord (RecRetiredLocks name) = GetRetired name+askForRecord _ = error "no corresponding request"++type DBM = ReaderT FilePath IO+	    +recordExists :: Record -> DBM Bool+recordExists rec = recordPath rec >>= liftIO . doesFileExist++getRecord :: Record -> DBM (Maybe RecordContents)+getRecord rec = do+    path <- recordPath rec+    liftIO $ flip catchIO (const $ return Nothing) $ do+	h <- openFile path ReadMode+	getRecordh rec h <* hClose h+getRecordh (RecPassword _) h = ((RCPassword <$>) . tryRead) <$> hGetStrict h+getRecordh (RecUserInfo _) h = ((RCUserInfo <$>) . tryRead) <$> hGetStrict h+getRecordh (RecUserInfoLog _) h = ((RCUserInfoDeltas <$>) . tryRead) <$> hGetStrict h+getRecordh (RecLock _) h = ((RCLock <$>) . tryRead) <$> hGetStrict h+getRecordh (RecNote _) h = ((RCSolution <$>) . tryRead) <$> hGetStrict h+getRecordh RecLockHashes h = ((RCLockHashes <$>) . tryRead) <$> hGetStrict h+getRecordh (RecRetiredLocks name) h = ((RCLockSpecs <$>) . tryRead) <$> hGetStrict h+getRecordh RecServerInfo h = ((RCServerInfo <$>) . tryRead) <$> hGetStrict h++hGetStrict h = CS.unpack `liftM` concatMWhileNonempty (repeat $ CS.hGet h 1024)+    where concatMWhileNonempty (m:ms) = do+	    bs <- m+	    if CS.null bs+		then return bs+		else (bs `CS.append`) `liftM` concatMWhileNonempty ms++putRecord :: Record -> RecordContents -> DBM ()+putRecord rec rc = do+    path <- recordPath rec+    liftIO $ do+	mkdirhierto path +	h <- openFile path WriteMode +	putRecordh rc h+	hClose h+putRecordh (RCPassword hpw) h = hPutStr h $ show hpw+putRecordh (RCUserInfo info) h = hPutStr h $ show info+putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas+putRecordh (RCLock lock) h = hPutStr h $ show lock+putRecordh (RCSolution solution) h = hPutStr h $ show solution+putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes+putRecordh (RCLockSpecs lss) h = hPutStr h $ show lss+putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo++modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM ()+modifyRecord rec f = do+    h <- recordPath rec >>= liftIO . flip openFile ReadWriteMode +    liftIO $ do+	Just rc <- getRecordh rec h+	hSeek h AbsoluteSeek 0+	putRecordh (f rc) h+	hTell h >>= hSetFileSize h +	hClose h++delRecord :: Record -> DBM ()+delRecord rec = recordPath rec >>= liftIO . removeFile++newLockRecord :: Lock -> DBM LockSpec+newLockRecord lock = do+    dbpath <- ask+    let path = dbpath++[pathSeparator]++"lastlock"+    h <- liftIO $ openFile path ReadWriteMode+    contents <- liftIO $ hGetStrict h+    let ls = if null contents then 0 else 1 + read contents+    liftIO $ hSeek h AbsoluteSeek 0+    liftIO $ hPutStr h $ show ls+    liftIO $ hClose h+    putRecord (RecLock ls) (RCLock lock)+    return ls++listUsers :: DBM [Codename]+listUsers = do+    dbpath <- ask+    liftIO $ (map unpathifyName . filter ((==3).length)) <$> getDirectoryContents (dbpath++[pathSeparator]++"users")++recordPath :: Record -> DBM FilePath+recordPath rec = do+	dbpath <- ask+	return $ dbpath ++ [pathSeparator] ++ recordPath' rec+    where+	recordPath' (RecPassword name) = userDir name ++ "passwd"+	recordPath' (RecUserInfo name) = userDir name ++ "info"+	recordPath' (RecUserInfoLog name) = userDir name ++ "log"+	recordPath' (RecLock ls) = locksDir ++ show ls+	recordPath' (RecNote (NoteInfo name _  alock)) = userDir name ++ "notes" ++ [pathSeparator] ++ alockFN alock+	recordPath' (RecRetiredLocks name) = userDir name ++ "retired"+	recordPath' RecLockHashes = "lockHashes"+	recordPath' RecServerInfo = "serverInfo"++	userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]+	alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx+	locksDir = "locks"++[pathSeparator]++-- dummy out characters which are disallowed on unix or windows:+pathifyName = map $ \c -> case c of +    '/'->'s'+    '.'->'d'+    '\\'->'b'+    '<'->'l'+    '>'->'g'+    ':'->'c'+    '|'->'p'+    '?'->'q'+    '*'->'a'+    _ -> c+unpathifyName = map $ \c -> case c of +    's'->'/'+    'd'->'.'+    'b'->'\\'+    'l'->'<'+    'g'->'>'+    'c'->':'+    'p'->'|'+    'q'->'?'+    'a'->'*'+    _ -> c
+ Debug.hs view
@@ -0,0 +1,20 @@+-- 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 Debug where++import qualified Debug.Trace as Trace+import Text.Show.Pretty (ppShow)++prettyTrace :: Show a => a -> b -> b+prettyTrace = Trace.trace . ppShow+prettyTraceVal :: Show a => a -> a+prettyTraceVal x = prettyTrace x x+
+ EditGameState.hs view
@@ -0,0 +1,155 @@+-- 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 EditGameState (modTile, mergeTiles) where++import Control.Applicative hiding ((<*>))+import Data.Function (on)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe+import Control.Monad+import Data.List++import Hex+import GameState+import GameStateTypes+--import Debug+	+modTile :: Maybe Tile -> HexPos -> HexPos -> Bool -> GameState -> GameState+modTile tile pos lastPos painting st =+    let board = stateBoard st+	curOwnedTile = Map.lookup pos board+	(st',mowner) = case curOwnedTile of+	    Nothing -> (st,Nothing)+	    Just (owner,SpringTile _ _) -> (delConnectionsIn pos st, Just owner)+	    Just (owner,_) -> delPiecePos owner pos st -- XXX may invalidate board's indices to st+	board' = stateBoard st'+	addPiece p = addpp $ PlacedPiece pos p+	lastMOwner = do+	    (o,_) <- Map.lookup lastPos board+	    return o+	{-+	same = isJust $ do+		t <- tile+		(_,t') <- curOwnedTile+		guard $ ((==) `on` tileType) t t'+		return $ Just ()+	-}+	lastElem os = isJust $ do+	       lastOwner <- lastMOwner+	       guard $ lastOwner `elem` os+	lastWasDiff = isNothing $ do+	       lastOwner <- lastMOwner+	       owner <- mowner+	       guard $ owner == lastOwner+	lastOK = painting || lastWasDiff+	validSpringRootTile ot = case snd ot of+	    BlockTile _ -> True+	    PivotTile _ -> True+	    _ -> False+	-- |Find next adjacent, skipping over current entity.+	-- XXX: Note this doesn't work when the entity is adjacent in multiple+	-- non-contiguous directions.+	nextOfAdjacents adjs loop = listToMaybe $ fromMaybe adjs $ do+		owner <- mowner+		i <- elemIndex owner adjs+		return $ (dropWhile (== owner) $ drop i adjs) +++		    if loop && i > 0 then adjs else []+    in case mowner of+	 Just o | protectedPiece o -> st+	 _ -> (case tile of+	   -- _ | same && (pos /= lastPos) -> id+	   Just (BlockTile _) ->+	       let adjacentBlocks = [ idx |+		       dir <- hexDirs+		       , Just (idx, BlockTile _) <- [Map.lookup (dir <+> pos) board']+		       , not $ protectedPiece idx ]+		   addToIdx = if lastOK && lastElem adjacentBlocks+		       then lastMOwner+		       else nextOfAdjacents adjacentBlocks False+	       in case addToIdx of+		  Nothing -> addPiece $ Block [zero]+		  Just b -> addBlockPos b pos+	   Just (ArmTile armdir _) -> +	       let adjacentPivots = [ idx |+		       dir <- if armdir == zero then hexDirs else [armdir, neg armdir]+		       , Just (idx, PivotTile _) <- [Map.lookup (dir <+> pos) board'] ]+		   addToIdx = if lastOK && lastElem adjacentPivots+		       then lastMOwner+		       else nextOfAdjacents adjacentPivots True+	       in case addToIdx of+		      Nothing -> id+		      Just p -> addPivotArm p pos+	   Just (SpringTile _ _) ->+	       let possibleSprings = [ Connection root end $ Spring sdir natLen |+		       sdir <- hexDirs+		       , let epos = sdir <+> pos+		       , Just (eidx, BlockTile _) <- [Map.lookup epos board']+		       , not $ protectedPiece eidx+		       , (ridx, rpos) <- maybeToList $ castRay (neg sdir <+> pos) (neg sdir) board'+		       , Just True == (validSpringRootTile `liftM` Map.lookup rpos board')+		       , let natLen = hexLen (rpos <-> epos) - 1+		       , natLen > 0+		       {-+		       , null [ conn |+			   conn@(Connection _ _ (Spring sdir' _)) <-+			       springsAtIdx st' eidx ++ springsEndAtIdx st' ridx+			   , not $ sdir' `elem` [sdir,neg sdir] ]+		       -}+		       , not $ connGraphPathExists st' eidx ridx+		       , let end = (eidx, epos <-> (placedPos $ getpp st' eidx))+		       , let root = (ridx, rpos <-> (placedPos $ getpp st' ridx))+		       ]+		   nextSpring = listToMaybe $ fromMaybe possibleSprings $ do+		       (_,SpringTile _ _) <- curOwnedTile -- XXX: therefore the indices of st are still valid+		       i <- findIndex (`elem` connections st) possibleSprings+		       return $ drop (i+1) possibleSprings+	       in case nextSpring of+		      Nothing -> id+		      Just conn -> addConn conn+	   Just (PivotTile _) -> addPiece $ Pivot []+	   Just (WrenchTile _) -> addPiece $ Wrench zero+	   Just HookTile -> let arm = listToMaybe [ dir | +				    dir <- hexDirs+				    , isNothing $ Map.lookup (dir <+> pos) board' ]+			    in case arm of Just armdir -> addPiece $ Hook armdir NullHF+					   _ -> id+	   Just (BallTile) -> addPiece Ball+	   _ -> id+	   ) st'++-- | merge tile/piece with a neighbouring piece. If we merge a piece with+-- connections, the connections are deleted: otherwise we'd need some fiddly+-- conditions to ensure connection graph acyclicity.+mergeTiles :: HexPos -> HexDir -> Bool -> GameState -> GameState+mergeTiles pos dir mergePiece st = fromMaybe st $ do+    let board = stateBoard st+    (idx,tile) <- Map.lookup pos board+    (idx',tile') <- Map.lookup (dir<+>pos) board+    guard $ idx /= idx'+    guard $ all (not . protectedPiece) [idx,idx']+    case tile of+	BlockTile _ -> do+	    BlockTile _ <- Just tile'+	    let st' = if mergePiece+			  then delPiece idx st+			  else fst $ delPiecePos idx pos st+	    (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st'+	    return $ if mergePiece+			 then foldr (addBlockPos idx'') st'+				$ plPieceFootprint $ getpp st idx+			 else addBlockPos idx'' pos st'+	ArmTile _ _  -> do+	    PivotTile _ <- Just tile'+	    let st' = fst $ delPiecePos idx pos st+	    (idx'',_) <- Map.lookup (dir<+>pos) $ stateBoard st'+	    return $ addPivotArm idx'' pos st'+
+ Frame.hs view
@@ -0,0 +1,84 @@+-- 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 Frame where++import Data.List ((\\))+import qualified Data.Vector as Vector++import GameState+import GameStateTypes+import Hex++data Frame = BasicFrame Int+    deriving (Eq, Ord, Show, Read)++frameSize :: Frame -> Int+frameSize (BasicFrame size) = size+ +bolthole, entrance :: Frame -> HexVec+bolthole (BasicFrame size) = size<*>hu <+> (size`div`2)<*>hv+entrance f = neg $ bolthole f++boltWidth :: Frame -> Int+boltWidth (BasicFrame size) = size`div`4+1+++baseState :: Frame -> GameState+baseState f =+    GameState +	(Vector.fromList $ [ framePiece f, bolt ] ++ (initTools f))+	[]+    where+	bolt = PlacedPiece (bolthole f <+> origin) $ Block $+	    [ n<*>hu | n <- [-1..boltWidth f - 1] ] -- ++ [(-2)<*>hu<+>neg hv]++framePiece :: Frame -> PlacedPiece+framePiece f@(BasicFrame size) =+    PlacedPiece origin $ Block $+	map (bolthole f <+>) (+	    [ bw<*>hu <+> n<*>hv | n <- [0..bw] ]+	    ++ [ bw<*>hu <+> i<*>hw <+> n<*>hv | i <- [1..bw-1], n <- [0,bw+i] ])+	++ (map (entrance f <+>) [neg hu <+> hv, 2 <*> neg hu, neg hu <+> hw,+		2 <*> hw, neg hv <+> hw])+	++ (concat [+		map (rotate r) [ (n<*>hu) <+> (size<*>hw) | n <- [0..size-1] ] | r <- [0..5] ] \\ +	    [bolthole f, entrance f])+    where bw = boltWidth f++initTools :: Frame -> [PlacedPiece]+initTools f =+    [ PlacedPiece (entrance f <+> neg hu <+> origin) $ Wrench zero,+    PlacedPiece (entrance f <+> hw <+> origin) $ Hook (neg hw) NullHF ]++clearToolArea :: Frame -> GameState -> GameState+clearToolArea f st = foldr delPieceIn st [entrance f <+> v <+> origin+	    | v <- [ neg hu, hw, zero ] ]++boltArea :: Frame -> [HexPos]+boltArea f = map PHS+	[ bolthole f <+> bw<*>hu <+> i<*>hw <+> n<*>hv | i <- [1..bw-1], n <- [1..bw+i-1] ]+    where bw = boltWidth f++inBounds :: Frame -> HexPos -> Bool+inBounds f pos = hexLen (pos <-> origin) < frameSize f+inEditable :: Frame -> HexPos -> Bool+inEditable f pos = inBounds f pos || pos `elem` boltArea f ++ [PHS $ bolthole f]+checkBounds :: Frame -> HexPos -> HexPos -> HexPos+checkBounds f def pos = if inBounds f pos then pos else def+checkEditable :: Frame -> HexPos -> HexPos -> HexPos+checkEditable f def pos = if inEditable f pos then pos else def+truncateToBounds,truncateToEditable :: Frame -> HexPos -> HexPos+truncateToBounds f pos@(PHS v) = PHS $ truncateToLength (frameSize f - 1) v+truncateToEditable f pos@(PHS v) = if inBounds f pos+    then pos+    else let pos' = PHS $ truncateToLength (frameSize f + boltWidth f - 1) v+	in if inEditable f pos'+	    then pos' else truncateToBounds f pos'
+ GameState.hs view
@@ -0,0 +1,352 @@+-- 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 GameState where++import Control.Applicative hiding ((<*>))+import Data.Function (on)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as Vector+import Data.Maybe+import Control.Monad+import Control.Monad.State+import Data.List+import Data.Vector (Vector, (!), (//))++import Hex+import Util+import GameStateTypes+--import Debug++ppidxs :: GameState -> [PieceIdx]+ppidxs = Vector.toList . (Vector.findIndices $ const True) . placedPieces++getpp :: GameState -> PieceIdx -> PlacedPiece+getpp st idx = (placedPieces st) ! idx++setpp :: PieceIdx -> PlacedPiece -> GameState -> GameState+setpp idx pp st@(GameState pps _) = +    let displacement = (placedPos $ getpp st idx) <-> placedPos pp+	updateConn conn@(Connection root@(ridx,rpos) end@(eidx,epos) link)+	    | ridx == idx = Connection (ridx,rpos<+>displacement) end link+	    | eidx == idx = Connection root (eidx,epos<+>displacement) link+	    | otherwise = conn+    in st {placedPieces = pps // [(idx, pp)]+	, connections = map updateConn $ connections st }++addpp :: PlacedPiece -> GameState -> GameState+addpp pp st@(GameState pps _) = st {placedPieces = Vector.snoc pps pp}++addConn :: Connection -> GameState -> GameState+addConn conn st@(GameState _ conns) = st {connections = conn:conns}++type Component = (HexVec, Set HexVec)+components :: Set HexVec -> [Component]+components patt+    | Set.null patt = []+    | otherwise =+	let c = if zero `Set.member` patt then zero else head $ Set.toList patt+	    (patt',comp) = floodfill c patt+	in ( (c, Set.map (<+> neg c) comp) : components patt' )++floodfill :: HexVec -> Set HexVec -> (Set HexVec, Set HexVec)+floodfill start patt = floodfill' start `execState` (patt, Set.empty)+    where +	floodfill' :: HexVec -> State (Set HexVec, Set HexVec) ()+	floodfill' start = do+	      (patt, dels) <- get+	      let patt' = Set.delete start patt+	      unless (Set.size patt' == Set.size patt) $ do+		  put (patt', Set.insert start dels)+		  sequence_ [ floodfill' (dir<+>start) | dir <- hexDirs ]++delPiece :: PieceIdx -> GameState -> GameState+delPiece idx (GameState pps conns) =+    GameState (Vector.concat [Vector.take idx pps, Vector.drop (idx+1) pps])+	[ Connection (ridx',rv) (eidx',ev) link |+	    Connection (ridx,rv) (eidx,ev) link <- conns+	    , ridx /= idx+	    , eidx /= idx+	    , let ridx' = if ridx > idx then ridx-1 else ridx+	    , let eidx' = if eidx > idx then eidx-1 else eidx ]++delPieceIn :: HexPos -> GameState -> GameState+delPieceIn pos st =+    case liftM fst $ Map.lookup pos $ stateBoard st of+	Just idx -> delPiece idx st+	_ -> st++setPiece :: PieceIdx -> Piece -> GameState -> GameState+setPiece idx p st = +    setpp idx (PlacedPiece (placedPos $ getpp st idx) p) st++adjustPieces :: (Piece -> Piece) -> GameState -> GameState+adjustPieces f st =+    st { placedPieces = fmap+	(\pp -> pp { placedPiece = f $ placedPiece pp })+       $ placedPieces st }++addBlockPos :: PieceIdx -> HexPos -> GameState -> GameState+addBlockPos b pos st =+    let PlacedPiece ppos (Block patt) = getpp st b+    in setPiece b (Block (pos <-> ppos:patt)) st++addPivotArm :: PieceIdx -> HexPos -> GameState -> GameState+addPivotArm p pos st =+    let PlacedPiece ppos (Pivot arms) = getpp st p+    in setPiece p (Pivot (pos <-> ppos:arms)) st++locusPos :: GameState -> Locus -> HexPos+locusPos s (idx,v) = v <+> (placedPos $ getpp s idx)++posLocus :: GameState -> HexPos -> Maybe Locus+posLocus st pos = listToMaybe [ (idx,pos<->ppos) |+    (idx,pp@(PlacedPiece ppos _)) <- enumVec $ placedPieces st+    , pos `elem` plPieceFootprint pp ]++connectionLength :: GameState -> Connection -> Int+connectionLength st (Connection root end _) =+    let rootPos = locusPos st root+	endPos = locusPos st end+    in hexLen (endPos <-> rootPos) - 1++springsAtIdx,springsEndAtIdx,springsRootAtIdx :: GameState -> PieceIdx -> [Connection]+springsAtIdx st idx =+    [ c | c@(Connection (ridx,_) (eidx, _) (Spring _ _)) <- connections st+	  , idx `elem` [ridx,eidx] ]+springsAtIdxIgnoring st idx idx' =+    [ c | c@(Connection (ridx,_) (eidx, _) (Spring _ _)) <- connections st+	  , idx `elem` [ridx,eidx], idx' `notElem` [ridx,eidx] ]+springsEndAtIdx st idx =+    [ c | c@(Connection _ (eidx, _) (Spring _ _)) <- connections st+	  , eidx==idx ]+springsRootAtIdx st idx =+    [ c | c@(Connection (ridx, _) _ (Spring _ _)) <- connections st+	  , ridx==idx ]+connectionsBetween :: GameState -> PieceIdx -> PieceIdx -> [Connection]+connectionsBetween st idx idx' =+    filter connIsBetween $ connections st+    where+	connIsBetween conn =+	    isPerm (idx,idx') (fst $ connectionRoot conn, fst $ connectionEnd conn)+	isPerm (x,y) (x',y') = (x==x'&&y==y')||(x==y'&&y==x')++connGraphPathExists :: GameState -> PieceIdx -> PieceIdx -> Bool+connGraphPathExists st ridx eidx = (ridx == eidx) ||+	any ((connGraphPathExists st `flip` eidx) . fst .  connectionEnd)+	    (springsRootAtIdx st ridx)++connGraphHeight :: GameState -> PieceIdx -> Int+connGraphHeight st idx =+    maximum (0 : map ((+1) . connGraphHeight st . fst . connectionRoot) (springsEndAtIdx st idx))++type DiGraph a = Map a (Set a)+checkConnGraphAcyclic :: GameState -> Bool+checkConnGraphAcyclic st =+    let idxs = ppidxs st+	leaves dg = map fst $ filter (Set.null . snd) $ Map.toList dg+	checkDiGraphAcyclic dg = case listToMaybe $ leaves dg of+	    Nothing -> Map.null dg+	    Just leaf -> checkDiGraphAcyclic $ Map.delete leaf $ fmap (Set.delete leaf) dg+    in checkDiGraphAcyclic $ Map.fromList +	[ (idx, Set.fromList $ map (fst.connectionRoot) $ springsEndAtIdx st idx) | idx <- idxs ]++repossessConns :: GameState -> GameState -> GameState+repossessConns st st' =+    st' {connections = [ Connection root' end' link |+	Connection root end link <- connections st+	, root' <- maybeToList $ posLocus st' $ locusPos st root+	, end' <- maybeToList $ posLocus st' $ locusPos st end ] }++delConnectionsIn :: HexPos -> GameState -> GameState+delConnectionsIn pos st =+    st {connections = filter+	((pos `notElem`) . connectionFootPrint st)+        $ connections st}++delPiecePos :: PieceIdx -> HexPos -> GameState -> (GameState, Maybe PieceIdx)+-- ^ returns new state and the new index of what remains of the piece, if+-- anything+delPiecePos idx pos st =+    let PlacedPiece ppos p = getpp st idx+	v = pos <-> ppos+    in case p of+        Block patt ->+	    let (st',midx) = componentify idx $ setpp idx (PlacedPiece ppos $ Block $ patt \\ [v]) st+	    in (repossessConns st st', midx)+        Pivot arms -> if v == zero+	   then (delPiece idx st, Nothing)+	   else ((setPiece idx $ Pivot $ arms \\ [v]) st, Just idx)+        _ -> (delPiece idx st, Nothing)+componentify :: PieceIdx -> GameState -> (GameState, Maybe PieceIdx)+componentify idx st = let PlacedPiece ppos p = getpp st idx+    in case p of+        Block patt ->+	    let comps = components $ Set.fromList patt+		ppOfComp (v,patt) = PlacedPiece (v<+>ppos) $ Block $ Set.toList patt+	    in case comps of+		[] -> (delPiece idx st, Nothing)+		zeroComp:newComps ->+		    (setpp idx (ppOfComp zeroComp)+			$ foldr (addpp . ppOfComp) st newComps, Just idx)+	_ -> (st,Nothing)++springExtended,springCompressed,springFullyExtended,springFullyCompressed :: GameState -> Connection -> Bool+springExtended st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c > natLen+springExtended _ _ = False+springCompressed st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c < natLen+springCompressed _ _ = False+springFullyExtended st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c >= 2*natLen+springFullyExtended _ _ = False+springFullyCompressed st c@(Connection _ _ (Spring _ natLen)) = connectionLength st c <= (natLen+1)`div`2+springFullyCompressed _ _ = False+springExtensionValid st c@(Connection _ _ (Spring _ natLen)) = let l = connectionLength st c in +    l >= (natLen+1)`div`2 && l <= 2*natLen+springExtensionValid _ _ = True++stateBoard :: GameState -> GameBoard+stateBoard st@(GameState plPieces conns) =+    addConnAdjs st conns $+	(Map.unions $ map plPieceBoard $ enumVec plPieces) `Map.union`+	(Map.unions $ map (connectionBoard st) conns)++addConnAdjs :: GameState -> [Connection] -> GameBoard -> GameBoard+addConnAdjs st = flip $ foldr addConnAdj+    where+	addConnAdj (Connection root end (Spring dir _)) board =+	    addAdj (locusPos st root) dir $+	    addAdj (locusPos st end) (neg dir) board+	addConnAdj _ board = board+	addAdj pos d =+	    Map.adjust (\(o,tile) -> (o,case tile of+		    BlockTile adjs -> BlockTile (d:adjs)+		    _ -> tile))+		pos++plPieceBoard :: (PieceIdx,PlacedPiece) -> GameBoard+plPieceBoard (idx,pp) = fmap (\x -> (idx,x)) $ plPieceMap pp++plPieceMap :: PlacedPiece -> Map HexPos Tile+plPieceMap (PlacedPiece pos (Block pattern)) =+    Map.fromList [ (rel <+> pos, BlockTile adjs) |+	rel <- pattern+	, let adjs = filter (\dir -> rel <+> dir `elem` pattern) hexDirs ]+plPieceMap (PlacedPiece pos (Pivot arms)) =+    let overarmed = length arms > 2 in+    Map.fromList $ (pos, PivotTile $ if overarmed then (head arms) else zero ) : +	[ (rel <+> pos, ArmTile rel main) |+	    (rel,main) <- zip arms $ repeat False -- overarmed:$repeat False+	    ]+plPieceMap (PlacedPiece pos (Hook arm _)) =+    Map.fromList $ (pos, HookTile) : [ (arm <+> pos, ArmTile arm True) ]+plPieceMap (PlacedPiece pos (Wrench mom)) = Map.singleton pos $ WrenchTile mom+plPieceMap (PlacedPiece pos Ball) = Map.singleton pos BallTile++plPieceFootprint :: PlacedPiece -> [HexPos]+plPieceFootprint = Map.keys . plPieceMap++fullFootprint :: GameState -> PieceIdx -> [HexPos]+-- ^footprint of piece and connections ending at it+fullFootprint st idx = plPieceFootprint (getpp st idx) +++    (concat $ map (connectionFootPrint st) $ springsEndAtIdx st idx)++footprintAt :: GameState -> PieceIdx -> [HexPos]+-- ^footprint of piece and any connections at it+footprintAt st idx = plPieceFootprint (getpp st idx) +++    (concat $ map (connectionFootPrint st) $ springsAtIdx st idx)++footprintAtIgnoring :: GameState -> PieceIdx -> PieceIdx -> [HexPos]+-- ^footprint of piece and any connections at it, except those with idx'+footprintAtIgnoring st idx idx' = plPieceFootprint (getpp st idx) +++    (concat $ map (connectionFootPrint st) $ springsAtIdxIgnoring st idx idx')++collisions :: GameState -> PieceIdx -> PieceIdx -> [HexPos]+-- ^intersections of two pieces and their connections, disregarding+-- the connections which connect the two pieces+collisions st idx idx' =+    intersect (footprintAt st idx) (footprintAt st idx') \\+	(concat $ map (connectionFootPrint st) $ connectionsBetween st idx idx')++connectionBoard :: GameState -> Connection -> GameBoard+connectionBoard st (Connection root end@(eidx,_) (Spring dir natLen)) =+    let rootPos = locusPos st root+	endPos = locusPos st end+	curLen = hexLen (endPos <-> rootPos) - 1+    in Map.fromList $+	[ ((d <*> dir) <+> rootPos, (eidx, SpringTile extension dir))+	    | d <- [1..curLen],+	    let extension | d <= natLen - curLen = Compressed+			  | curLen-d < 2*(curLen - natLen) = Stretched+			  | otherwise = Relaxed ]+connectionBoard _ _ = Map.empty++connectionFootPrint :: GameState -> Connection -> [HexPos]+connectionFootPrint s c = Map.keys $ connectionBoard s c++castRay :: HexPos -> HexDir -> GameBoard -> Maybe (PieceIdx, HexPos)+castRay start dir board =+    castRay' 30 start+    where castRay' 0 _ = Nothing+	  castRay' n pos =+	      case Map.lookup pos board of+		  Nothing -> castRay' (n-1) (dir<+>pos)+		  Just (idx,_) -> Just (idx,pos)++validGameState :: GameState -> Bool+validGameState st@(GameState pps conns) = and+    [ checkValidHex st+    , checkConnGraphAcyclic st+    , and [ null $ collisions st idx idx'+	    | idx <- ppidxs st+	    , idx' <- [0..idx-1] ]+    , and [ isHexDir dir+	    && castRay (dir<+>rpos) dir+		(stateBoard $ GameState pps (conns \\ [c]))+		== Just (eidx, epos)+	    && springExtensionValid st c+	    && (validRoot st root)+	    && (validEnd st end)+	    | c@(Connection root@(ridx,_) end@(eidx,_) (Spring dir _)) <- conns+	    , let [rpos,epos] = map (locusPos st) [root,end] ]+    , and [ 1 == length (components $ Set.fromList patt) +	    | Block patt <- map placedPiece $ Vector.toList pps ]+    ]++validRoot st (idx,v) = case placedPiece $ getpp st idx of+    (Block _) -> True+    (Pivot _) -> v==zero+    _ -> False+validEnd st (idx,_) = case placedPiece $ getpp st idx of+    (Block _) -> True+    _ -> False++checkValidHex (GameState pps conns) = and+    [ all validPP $ Vector.toList pps+    , all validConn conns ]+    where+	validVec (HexVec x y z) = x+y+z==0+	validPos (PHS v) = validVec v+	validDir v = validVec v && isHexDir v+	validPP (PlacedPiece pos piece) = validPos pos && validPiece piece+	validPiece (Block patt) = all validVec patt+	validPiece (Pivot arms) = all validDir arms+	validPiece (Hook dir _) = validDir dir+	validPiece _ = True+	validConn (Connection (_,rv) (_,ev) link) = all validVec [rv,ev] && validLink link+	validLink (Free v) = validVec v+	validLink (Spring dir _) = validDir dir++protectedPiece :: PieceIdx -> Bool+protectedPiece = isFrame+isFrame :: PieceIdx -> Bool+isFrame = (==0)
+ GameStateTypes.hs view
@@ -0,0 +1,84 @@+-- 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 GameStateTypes where++import Data.Map (Map)+import Data.Vector (Vector)+import Hex++data GameState = GameState { placedPieces :: Vector PlacedPiece,+	connections :: [Connection] }+    deriving (Eq, Ord, Show, Read)++data PlacedPiece = PlacedPiece { placedPos :: HexPos, placedPiece :: Piece }+    deriving (Eq, Ord, Show, Read)++type PieceIdx = Int++data Piece = Block { blockPattern :: [HexVec] }+	    | Pivot { pivotArms :: [HexDir] }+	    | Hook { hookArm :: HexDir, hookForce :: HookForce}+	    | Wrench { wrenchMomentum :: HexDir }+	    | Ball+    deriving (Eq, Ord, Show, Read)++data HookForce = NullHF | PushHF HexDir | TorqueHF Int+    deriving (Eq, Ord, Show, Read)++isBlock, isPivot, isHook, isWrench, isTool, isBall :: Piece -> Bool+isBlock p = case p of Block _ -> True; _ -> False+isPivot p = case p of Pivot _ -> True; _ -> False+isHook p = case p of Hook _ _ -> True; _ -> False+isWrench p = case p of Wrench _ -> True; _ -> False+isTool p = isWrench p || isHook p+isBall p = case p of Ball -> True; _ -> False++data Connection = Connection { connectionRoot :: Locus+		    , connectionEnd :: Locus, connectionLink :: Link }+    deriving (Eq, Ord, Show, Read)++type Locus = (PieceIdx, HexVec)++data Link = Free { freePos :: HexVec }+	  | Spring { springDir :: HexDir, springNatLength :: Int }+    deriving (Eq, Ord, Show, Read)++data SpringExtension = Relaxed | Compressed | Stretched+    deriving (Eq, Ord, Show, Read)++data Tile = BlockTile [HexDir] | PivotTile HexDir | ArmTile HexDir Bool | HookTile | WrenchTile HexDir+	  | BallTile | SpringTile SpringExtension HexDir+    deriving (Eq, Ord, Show, Read)++tileType :: Tile -> Tile+tileType (BlockTile _) = BlockTile []+tileType (PivotTile _) = PivotTile zero+tileType (ArmTile _ _) = ArmTile zero False+tileType (WrenchTile _) = WrenchTile zero+tileType (BallTile) = BallTile+tileType (SpringTile _ _) = SpringTile Relaxed zero+tileType t = t++type OwnedTile = (PieceIdx, Tile)+type GameBoard = Map HexPos OwnedTile++-- |TorqueDir: Int of absolute value <= 1+type TorqueDir = Int++-- |'force' encompasses both usual directional forces and torques; we use+-- 'push' for the former.+data Force = Push PieceIdx HexDir | Torque PieceIdx TorqueDir+    deriving (Eq, Ord, Show)++-- |Alert: for passing information about physics processing to the UI+data Alert = AlertCollision HexPos | AlertBlockingForce Force+	   | AlertResistedForce Force | AlertBlockedForce Force+    deriving (Eq, Ord, Show)
+ GraphColouring.hs view
@@ -0,0 +1,92 @@+-- 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 GraphColouring where++import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as Vector+import Data.List+import Data.Maybe++type Colouring a = Map a Int+type Graph a = (Set a, Set (Set a))+type PlanarGraph a = Map a [a]++fourColour :: Ord a => Graph a -> Colouring a -> Colouring a+fourColour (nodes,edges) lastCol =+    -- bruteforce +    if Map.keysSet lastCol == nodes && isColouring lastCol+	then lastCol+	else head $ filter isColouring colourings+    where +	isColouring mapping = and [+	    Map.lookup s mapping /= Map.lookup e mapping |+		edge <- Set.toList edges+		, [s,e] <- [Set.toList edge] ]+	colourings = colourings' $ Set.toList nodes+	colourings' [] = [ Map.empty ]+	colourings' (n:ns) = [ Map.insert n c m |+	    m <- colourings' ns+	    , c <- [0..3] ]++fiveColour :: Ord a => PlanarGraph a -> Colouring a -> Colouring a+-- ^algorithm based on that presented in+-- http://people.math.gatech.edu/~thomas/PAP/fcstoc.pdf +-- Key point: a planar graph can't have all vertices of degree >= 6+-- (Proof: suppose it does, so |E| >= 3|V|; WLOG the graph is triangulated,+-- so then |F| <= 2/3 |E|. So \xi = |V|-|E|+|F| <= (1/3 - 1 + 2/3)|E| = 0.+-- But a planar graph has Euler characteristic 1.)+fiveColour g lastCol =+    if Map.keysSet lastCol == Map.keysSet g && isColouring lastCol+	then lastCol+	else fiveColour' g+    where+    isColouring mapping = and [+	Map.lookup s mapping /= Map.lookup e mapping |+	    s <- Map.keys g+	    , e <- g Map.! s ]+    --fiveColour' :: PlanarGraph a -> Colouring a+    fiveColour' g+	| g == Map.empty = Map.empty+	| otherwise =+	let +	    adjsOf v = (nub $ g Map.! v) \\ [v]+	    v = head $ filter ((<=5) . length . adjsOf) $ Map.keys g+	    adjs = adjsOf v+	    addTo c = let vc = head $ possCols v \\ map (c Map.!) adjs+		      in Map.insert v vc c+	in if length adjs < 5+	   then addTo $ fiveColour' $ deleteNode v g+	   else let (v',v'') = if adjs!!2 `elem` (g Map.! (adjs!!0))+			then (adjs!!1,adjs!!3)+			else (adjs!!0,adjs!!2)+		in addTo $ demerge v' v'' $ fiveColour' $ merge v v' v'' g+    --possCols :: a -> [Int]+    possCols v = maybe [0..4] (\lvc -> lvc:([0..4] \\ [lvc])) $ Map.lookup v lastCol+    --demerge :: a -> a -> Colouring a -> Colouring a+    demerge v v' c = Map.insert v' (c Map.! v) c+    --merge :: a -> a -> a -> PlanarGraph a -> PlanarGraph a+    merge v v' v'' g =+	deleteNode v $ contractNodes v' v''+	    $ Map.adjust (concatAdjsOver v $ g Map.! v'') v' g+    --concatAdjsOver :: a -> [a] -> [a] -> [a]+    concatAdjsOver v adjs adjs' =+	let (s,_:e) = splitAt (fromJust $ elemIndex v adjs) adjs+	in s ++ adjs' ++ e+    deleteNode v =+	fmap (filter (/= v)) . Map.delete v+    contractNodes v v' =+	fmap (map (\v'' -> if v'' == v' then v else v'')) . Map.delete v'+    ++
+ Hex.lhs view
@@ -0,0 +1,244 @@+-- 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/.++\begin{document}++An abstract hex board type.++We coordinatize by the integral points of the hyperplane x+y+z=0:++Some hopefully elucidatory diagrams:++   .   .+   v.        u = (1,0,-1)+ .   .___.   v = (-1,1,0)+   w,  u     w = (0,-1,1)+   .   .+                                   X+                             -2-1 0+       Y                     , , , 1+     . | .               2 -. . * , 2+       |                1 -. . * * ,     * : "principal hextant"+   .   .   .         Y 0 -. . 0 . .           x>=0&&y>0+     /   \             -1 -. . . . `+   / .   . \            -2 -. . . `-2+  Z          X               ` ` `-1+                              2 1 0+                                 Z+++\begin{code}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+module Hex where++import Data.Ix+import Data.Monoid+import Data.Ratio+import Data.List (minimumBy)+import Data.Function (on)+   +data HexVec = HexVec {hx,hy,hz :: Int} deriving (Eq, Ord, Show, Read)++hu,hv,hw :: HexVec+hu = HexVec    1    0 (-1)+hv = HexVec (-1)    1    0+hw = HexVec    0 (-1)    1++hv2tup :: HexVec -> (Int,Int,Int)+hv2tup (HexVec x y z) = (x,y,z)++tup2hv :: (Int,Int,Int) -> HexVec+tup2hv (x,y,z) +    | x+y+z == 0 = HexVec x y z+    | otherwise = error "bad hex"++hv2tupxy :: HexVec -> (Int,Int)+hv2tupxy (HexVec x y _) = (x,y)++tupxy2hv :: (Int,Int) -> HexVec+tupxy2hv (x,y) = HexVec x y (-(x+y))++hexLen :: HexVec -> Int+hexLen (HexVec x y z) = maximum $ map abs [x,y,z]++hexDot :: HexVec -> HexVec -> Int+hexDot (HexVec x y z) (HexVec x' y' z') = x*x'+y*y'+z*z'++hexDisc :: Int -> [HexVec] +hexDisc r = [ HexVec x y z | x <- [-r..r], y <- [-r..r],+	let z = -x-y, abs z <= r ]++hextant :: HexVec -> Int+-- ^undefined at zero+--	` 1 '+--	2` '0+--	--*--+--	3' `5+--	' 4 `+hextant (HexVec x y z)+    | x > 0 && y >= 0 = 0+    | -z > 0 && -x >= 0 = 1+    | y > 0 && z >= 0 = 2+    | -x > 0 && -y >= 0 = 3+    | z > 0 && x >= 0 = 4+    | -y > 0 && -z >= 0 = 5+    | otherwise = error $ "Tried to take hextant of zero"++-- hextant (rotate n hu) == n+rotate :: Int -> HexVec -> HexVec+rotate 0 v = v+rotate 2 (HexVec x y z) = HexVec z x y+rotate (-2) (HexVec x y z) = HexVec y z x+rotate 1 v = neg $ rotate (-2) v+rotate (-1) v = neg $ rotate 2 v+rotate n v | n < 0 = rotate (n+6) v+	| n > 6 = rotate (n-6) v+	| otherwise = rotate (n-2) (rotate 2 v)++cmpAngles :: HexVec -> HexVec -> Ordering+-- ^ordered by angle, taking cut along u+cmpAngles v@(HexVec x y _) v'@(HexVec x' y' _)+    | v == zero && v' == zero = EQ+    | v == zero = LT+    | compare (hextant v) (hextant v') /= EQ = +	compare (hextant v) (hextant v')+    | hextant v /= 0 =+	cmpAngles (rotate (-(hextant v)) v) (rotate (-(hextant v)) v')+    | otherwise = compare (y%x) (y'%x')++instance Ix HexVec where+    range (h,h') = +	[ tupxy2hv (x,y) | (x,y) <- range (hv2tupxy h, hv2tupxy h') ]+    inRange (h,h') h'' =+	inRange (hv2tupxy h, hv2tupxy h') (hv2tupxy h'')+    index (h,h') h'' =+	index (hv2tupxy h , hv2tupxy h') (hv2tupxy h'')++-- HexDirs are intended to be HexVecs of length <= 1+type HexDir = HexVec+isHexDir :: HexVec -> Bool+isHexDir v = hexLen v == 1++type HexDirOrZero = HexVec+isHexDirOrZero :: HexVec -> Bool+isHexDirOrZero v = hexLen v <= 1++hexDirs :: [HexDir]+hexDirs = map (`rotate` hu) [0..5]++hexVec2HexDirOrZero :: HexVec -> HexDirOrZero+hexVec2HexDirOrZero v+    | v == zero = zero+    | otherwise = rotate (hextant v) hu++--minusHu = HexVec    (-1) 1    0+--minusHv = HexVec    0    (-1) 1+--minusHw = HexVec    1    0    (-1)++canonDir :: HexDir -> HexDir+canonDir dir | dir `elem` [ hu, hv, hw ] = dir+	     | isHexDir dir = canonDir $ neg dir+	     | dir == zero = zero+	     | otherwise = undefined++scaleToLength :: Int -> HexVec -> HexVec+scaleToLength n v@(HexVec x y z) =+    let+	l = hexLen v+	lv' = map ((`div`l).(n*)) [x,y,z]+	minI = fst $ minimumBy (compare `on` snd) $+	    zip [0..] $ map abs lv'+	[x'',y'',z''] = zipWith (-) lv' [ d+		| i <- [0..2]+		, let d = if i == minI then sum lv' else 0 ]+    in HexVec x'' y'' z''+truncateToLength :: Int -> HexVec -> HexVec+truncateToLength n v = if hexLen v <= n then v else scaleToLength n v+\end{code}+     +Some general stuff on groups and actions and principal homogeneous spaces. We+use additive notation, even though there's no assumption of commutativity.++\begin{code}+class Monoid g => Grp g where+    neg :: g -> g+    zero :: g+    zero = mempty++instance (Grp g1, Grp g2) => Grp (g1,g2) where+    neg (a,b) = (neg a, neg b)++infixl 6 <+>+infixl 6 <->+class Action a b where+    (<+>) :: a -> b -> b+instance Monoid m => Action m m where+    (<+>) = mappend++class Differable a b c where+    (<->) :: a -> b -> c+instance Grp g => Differable g g g where+    x <-> y = x <+> (neg y)++newtype PHS g = PHS { getPHS :: g }+    deriving (Eq, Ord, Show, Read)++instance Grp g => Action g (PHS g) where+    x <+> (PHS y) = PHS (x <+> y)+instance Grp g => Differable (PHS g) (PHS g) g where+    (PHS x) <-> (PHS y) = x <-> y+    +infixl 7 <*>+class MultAction a b where+    (<*>) :: a -> b -> b+    +instance (Grp a, Integral n) => MultAction n a where+    0 <*> _              = zero+    1 <*> x              = x+    n <*> x+	| n < 0     = (-n) <*> (neg x)+	| even n    = (n `div` 2) <*> (x <+> x)+	| otherwise = x <+> ((n `div` 2) <*> (x <+> x))++\end{code}++Now we define HexSpaces as spaces acted on by HexVec, and with a canonical+HexVec difference between two points (e.g. PHS HexVec).++\begin{code}++instance Monoid HexVec where+    (HexVec x y z) `mappend` (HexVec x' y' z') = HexVec (x+x') (y+y') (z+z')+    mempty = HexVec 0 0 0+instance Grp HexVec where+    neg (HexVec x y z) = HexVec (-x) (-y) (-z)++class (Action HexVec b, Differable b b HexVec) => HexSpace b+instance HexSpace (PHS HexVec)++type HexPos = PHS HexVec+origin :: HexPos+origin = PHS zero++\end{code}++Testing:++\begin{code}+{-+r = range (tup2hv (-3,-3,6), tup2hv (3,3,-6))+test1 = index (tup2hv (-3,-3,6), tup2hv (3,3,-6)) (r!!5) == 5++a :: PHS HexVec+a = PHS zero+test2 = hu <+> a+-}+\end{code}+\end{document}
+ Init.hs view
@@ -0,0 +1,82 @@+-- 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 Init where+++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State+import Data.Maybe+import System.Exit+import System.Environment+import System.Directory+import System.Console.GetOpt++import Mundanities+import AsciiLock+import Lock+import MainState+import Interact++data Opt = LockSize Int | ForceCurses+    deriving (Eq, Ord, Show)+options =+    [ Option ['c'] ["curses"] (NoArg ForceCurses) "force curses UI"+    -- , Option ['s'] ["locksize"] (ReqArg (LockSize . read) "SIZE") "locksize"+    ]+parseArgs :: [String] -> IO ([Opt],[String])+parseArgs argv =+    case getOpt Permute options argv of+	(o,n,[]) -> return (o,n)+	(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+    where header = "Usage: intricacy [OPTION...] [file]"++setup :: IO (Maybe Lock,[Opt],Maybe String)+setup = do+    argv <- getArgs+    (opts,args) <- parseArgs argv+    --let frameSize = fromMaybe 8 $ listToMaybe [ size | LockSize size <- opts ]+    (fromJust <$>) $ runMaybeT $ msum [ do+	rpath <- MaybeT $ return $ listToMaybe args+	msum [ do+	    path <- MaybeT $ (Just <$> canonicalizePath rpath)+			`catchIO` (const $ return Nothing)+	    lock <- reframe.fst <$> MaybeT (readLock path)+	    return (Just lock,opts,Just path)+	    , do+		lift $ putStrLn $ "Failed to open lock file: "++rpath+		lift $ exitFailure+		mzero ]+	, return (Nothing,opts,Nothing) ]++main' :: (UIMonad s, UIMonad c) =>+	Maybe (s MainState -> IO (Maybe MainState)) ->+	Maybe (c MainState -> IO (Maybe MainState)) -> IO ()+main' msdlUI mcursesUI = do+    (mlock,opts,mpath) <- setup+    initMState <- case mlock of+	    Nothing -> initMetaState+	    Just lock -> return $ newEditState lock Nothing mpath+    void $ runMaybeT $ msum [ do+	    finalState <- msum +		[ do+		    guard $ ForceCurses `notElem` opts+		    sdlUI <- MaybeT . return $ msdlUI+		    MaybeT $ sdlUI $ interactUI `execStateT` initMState+		, do+		    cursesUI <- MaybeT . return $ mcursesUI+		    MaybeT $ cursesUI $ interactUI `execStateT` initMState+		]+	    when (isNothing mlock) $ lift $ writeMetaState finalState+	    lift $ exitSuccess+	, lift exitFailure ]
+ InputMode.hs view
@@ -0,0 +1,14 @@+-- 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 InputMode where++data InputMode = IMEdit | IMPlay | IMReplay | IMMeta | IMTextInput+    deriving (Eq, Ord, Show, Read)
+ Interact.hs view
@@ -0,0 +1,623 @@+-- 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 Interact (interactUI) where ++import Control.Monad.State+import Control.Applicative+import qualified Data.Vector as Vector+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad.Writer+import Control.Monad.Trans.Error+import Control.Monad.Trans.Maybe+import Data.Maybe+import Data.Char+import Data.List+import Control.Concurrent.STM+import Control.Concurrent+import System.Directory+import System.FilePath+import Data.Array+import Data.Function (on)++import Hex+import Command+import Physics+import Mundanities+import AsciiLock+import GameState+import GameStateTypes+import EditGameState+import Frame+import Lock+import Cache+import Database+import Protocol+import Metagame+import ServerAddr+import MainState+import InputMode+import Maxlocksize+import InteractUtil++interactUI :: UIMonad uiM => StateT MainState uiM InteractSuccess+interactUI = do+    lift $ drawMessage ""+    (IMMeta==) . ms2im <$> get >>= flip when (void $ do+	flag <- gets newAsync+	unblock <- lift unblockInput+	_ <- liftIO $ forkIO $ forever $ do+	    atomically $ readTVar flag >>= check >> writeTVar flag False+	    unblock++	-- draw before testing auth, lest a timeout mean a blank screen+	drawMainState++	testAuth+	refreshUInfoUI+	(isNothing <$> gets curAuth >>=) $ flip when $+	    lift $ drawMessage "Welcome. To play the tutorial levels, press 'T'."+	)+    setMark '0'+    loop++    where+	loop = do+	    mainSt <- get+	    let im = ms2im mainSt+	    when (im == IMPlay && not (psSolved mainSt)) checkWon+	    when (im == IMMeta) $ (checkAsyncErrors >>) $ void.runMaybeT $ +		mourNameSelected >>=+		    flip when (lift purgeInvalidUndecls)+	    drawMainState+	    cmds <- lift $ getSomeInput im+	    runErrorT (mapM_ (processCommand im) cmds) >>= \x -> case x of+		Left ret -> do+		    lift $ drawMessage ""+		    return ret+		Right _ -> loop++-- | TODO: neater would be to use a stream (see package 'pipes') for+-- input?+getSomeInput im = do+    cmds <- getInput im+    if null cmds then getSomeInput im else return cmds++newtype InteractSuccess = InteractSuccess Bool+instance Error InteractSuccess where+    noMsg = InteractSuccess False++processCommand :: UIMonad uiM => InputMode -> Command -> ErrorT InteractSuccess (StateT MainState uiM) ()+processCommand im CmdQuit = do+    case im of+	IMReplay -> throwError $ InteractSuccess False+	IMPlay -> lift (gets psIsSub) >>= flip when (throwError $ InteractSuccess False)+	IMEdit -> lift editStateUnsaved >>= flip unless (throwError $ InteractSuccess True)+	_ -> return ()+    title <- lift $ getTitle+    really <- lift $ lift $ confirm $ "Really quit" ++ maybe "" (" from "++) title ++ "?"+    when really $ throwError $ InteractSuccess False+processCommand im CmdForceQuit = throwError $ InteractSuccess False+processCommand IMPlay CmdOpen = do+    st <- gets psCurrentState+    frame <- gets psFrame+    if checkSolved (frame,st) then throwError $ InteractSuccess True else lift.lift $ drawError "Locked!"+processCommand im cmd = lift $ processCommand' im cmd++processCommand' :: UIMonad uiM => InputMode -> Command -> StateT MainState uiM ()+processCommand' im CmdHelp = lift $ showHelp im+processCommand' im CmdBind = lift $ flip (>>) (drawMessage "") $ void $ runMaybeT $ do+	lift $ drawMessage "Command to bind: "+	cmd <- msum $ repeat $ do+	    cmd <- MaybeT $ listToMaybe <$> getInput im+	    guard $ not.null $ describeCommand cmd+	    return cmd+	lift $ drawMessage ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat binding to delete): ")+	ch <- MaybeT getChRaw+	guard $ ch /= '\ESC'+	lift $ setUIBinding im cmd ch++processCommand' _ CmdSuspend = lift $ suspend+processCommand' _ CmdRedraw = lift $ redraw+processCommand' im CmdMark = void.runMaybeT $ do+    guard $ im `elem` [IMEdit, IMPlay, IMReplay]+    str <- MaybeT $ lift $ textInput "Mark: " 1 False True Nothing Nothing+    ch <- MaybeT $ return $ listToMaybe str+    guard $ ch `notElem` ['0', '\'']+    lift $ setMark ch+processCommand' im CmdJumpMark = void.runMaybeT $ do+    guard $ im `elem` [IMEdit, IMPlay, IMReplay]+    str <- MaybeT $ lift $ textInput+	"Jump to mark ('0' for starting state): " 1 False True Nothing Nothing+    ch <- MaybeT $ return $ listToMaybe str+    lift $ jumpMark ch+processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do+    name <- msum [ MaybeT $ return $ mname+	, do+	    newCodename <- (map toUpper <$>) $ MaybeT $ lift $ textInput "Codename:" 3 False True Nothing Nothing+	    guard $ length newCodename == 3+	    return newCodename+	]+    guard $ validCodeName name+    lift $ do+	modify $ \ms -> ms { codenameStack = (name:codenameStack ms) }+	invalidateUInfo name+	refreshUInfoUI+processCommand' IMMeta CmdHome = void.runMaybeT $ do+    ourName <- mgetOurName+    lift $ do+	modify $ \ms -> ms { codenameStack = (ourName:codenameStack ms) }+	refreshUInfoUI+processCommand' IMMeta CmdBackCodename = do+    stack <- gets codenameStack+    when (length stack > 1) $ do+	modify $ \ms -> ms { codenameStack = tail stack }+	refreshUInfoUI+processCommand' IMMeta CmdSetServer = void.runMaybeT $ do+    saddr <- gets curServer+    saddrs <- liftIO $ knownServers+    newSaddrstr <- MaybeT $ lift $ textInput "Set server:" 256 False False+	    (Just $ map saddrStr saddrs) (Just $ saddrStr saddr)+    newSaddr <- MaybeT $ return $ strToSaddr newSaddrstr+    modify $ \ms -> ms { curServer = newSaddr }+    unless (nullSaddr newSaddr) $+	msum [ void $ MaybeT $ getFreshRecBlocking RecServerInfo+	, modify $ \ms -> ms { curServer = saddr }+	]+processCommand' IMMeta CmdToggleCacheOnly =+    not <$> gets cacheOnly >>= \c -> modify $ \ms -> ms {cacheOnly = c}++processCommand' IMMeta CmdRegister = void.runMaybeT $ do+    newName <- mgetCurName+    mauth <- gets curAuth+    let isUs = maybe False ((==newName).authUser) mauth+    confirmOrBail $ if isUs then "Really reset password?" else "Register codename "++newName++"?"+    passwd <- (hashPassword newName <$>) $ MaybeT $ lift $+	textInput "Enter new password:" 64 True False Nothing Nothing+    lift $ if isUs then do+	    resp <- curServerAction $ ResetPassword passwd+	    case resp of+		ServerAck -> do+		    lift $ drawMessage "New password set."+		    modify $ \ms -> ms {curAuth = Just $ Auth newName passwd}+		ServerError err -> lift $ drawError err+		_ -> lift $ drawMessage $ "Bad server response: " ++ show resp+	else do+	    modify $ \ms -> ms {curAuth = Just $ Auth newName passwd}+	    resp <- curServerAction Register+	    case resp of+		ServerAck -> do+		    invalidateUInfo newName+		    refreshUInfoUI+		    lift $ drawMessage "Registered!"+		ServerError err -> do+		    lift $ drawError err+		    modify $ \ms -> ms {curAuth = Nothing}+		_ -> lift $ drawMessage $ "Bad server response: " ++ show resp+processCommand' IMMeta CmdAuth = void.runMaybeT $ do+    auth <- lift $ gets curAuth+    if isJust auth then do+	confirmOrBail "Log out?"+	modify $ \ms -> ms {curAuth = Nothing}+    else do+	name <- mgetCurName+	passwd <- (hashPassword name <$>) $ MaybeT $ lift $+	    textInput ("Enter password for "++name++":") 64 True False Nothing Nothing+	lift $ do+	    modify $ \ms -> ms {curAuth = Just $ Auth name passwd}+	    resp <- curServerAction $ Authenticate+	    case resp of+		ServerAck -> (lift $ drawMessage "Authenticated.")+		ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)+		ServerError err -> do+		    lift $ drawError err+		    modify $ \ms -> ms {curAuth = auth}+		_ -> lift $ drawMessage $ "Bad server response: " ++ show resp+processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do+    name <- mgetCurName+    uinfo <- mgetUInfo name+    idx <- msum [ MaybeT $ return midx+	, askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ]+    ls <- MaybeT $ return $ lockSpec <$> userLocks uinfo ! idx+    undecls <- lift (gets undeclareds)+    msum [ do+	    undecl <- MaybeT $ return $ find (\(Undeclared _ ls' _) -> ls == ls') undecls+	    _ <- MaybeT $ gets curAuth+	    confirmOrBail "Declare existing solution?"+	    void.lift.runMaybeT $ -- ignores MaybeT failures+		declare undecl+	, do+	    RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls+	    soln <- solveLock lock $ Just $+		"solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ "  (#" ++ show ls ++")"+	    mourName <- lift $ (authUser <$>) <$> gets curAuth+	    guard $ mourName /= Just name+	    let undecl = Undeclared soln ls (ActiveLock name idx) +	    msum [ do+		    _ <- MaybeT $ gets curAuth+		    confirmOrBail "Declare solution?"+		    declare undecl+		, unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $+		    modify $ \ms -> ms { undeclareds = (undecl : undeclareds ms) }+		]+	]+processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do+    ls <- msum [ MaybeT $ return mls+	, do +	    tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing+	    MaybeT . return $ fst <$> (listToMaybe $ (reads :: ReadS Int) tls)+	]+    RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls+    solveLock lock $ Just $ "solving " ++ show ls+    +processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do+    mourNameSelected >>= guard+    name <- mgetCurName+    undecls <- lift $ gets undeclareds+    guard $ not $ null undecls+    declare =<< msum [ MaybeT $ return mundecl+	, if length undecls == 1+	then return $ head undecls+	else do+	    which <- MaybeT $ lift $ textInput+		("Declare which solution?")+		5 False True Nothing Nothing+	    MaybeT $ return $ msum+		[ do+		    i <- fst <$> (listToMaybe $ (reads :: ReadS Int) which)+		    guard $ 0 < i && i <= length undecls+		    return $ undecls !! (i-1)+		, listToMaybe $ [ undecl+		    | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls+		    , or [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==+			    map toUpper which +			, name'==name && [lockIndexChar i] == which+			] ]+		]+	]+processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do+    note <- msum [ MaybeT $ return mnote, do+	ourName <- mgetOurName+	name <- mgetCurName+	uinfo <- mgetUInfo name+	noteses <- lift $ sequence+	    [ case mlockinfo of+		Nothing -> return []+		Just lockinfo -> (++lockSolutions lockinfo) <$> do+			ns <- getNotesReadOn lockinfo +			return $ if length ns < 3 then [] else ns+	    | mlockinfo <- elems $ userLocks uinfo ]+	idx <- askLockIndex "View solution to which lock?" "No solutions to view" $ not.null.(noteses!!)+	let notes = noteses!!idx+	    authors = map noteAuthor notes+	author <- if length notes == 1+	    then return $ noteAuthor $ head notes +	    else (map toUpper <$>) $ MaybeT $ lift $+		textInput ("View solution by which player? ["+		    ++ intercalate "," (take 3 authors)+		    ++ if length authors > 3 then ",...]" else "]")+		3 False True (Just $ authors) Nothing+	MaybeT $ return $ find ((==author).noteAuthor) notes+	]+    let ActiveLock name idx = noteOn note+    uinfo <- mgetUInfo name+    ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx)+    RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls+    RCSolution soln <- MaybeT $ getFreshRecBlocking $ RecNote note+    lift.lift $ execStateT interactUI $ newReplayState (snd.reframe$lock) soln $ Just $+	"viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx]++processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do+    mourNameSelected >>= guard+    ourName <- mgetOurName+    (lock,msoln) <- MaybeT $ gets curLock+    lockpath <- lift $ gets curLockPath+    ourUInfo <- mgetUInfo ourName+    idx <- msum [ MaybeT $ return midx+	, askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True+	]+    when (isJust $ userLocks ourUInfo ! idx) $+	confirmOrBail "Really retire existing lock?"+    soln <- msum [ MaybeT $ return msoln,+	solveLock lock $ Just $ "testing lock" ]+    lift $ do +	curServerActionAsync $ SetLock lock idx soln+	invalidateUInfo ourName+	refreshUInfoUI++processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do+    lockdir <- liftIO $ confFilePath "locks"+    paths <- liftIO $ map (drop (length lockdir + 1)) <$> getDirContentsRec lockdir+    path <- MaybeT $ lift $ textInput "Select lock:" 1024 False False (Just paths) Nothing+    lift $ setLockPath path+processCommand' IMMeta CmdNextLock =+    gets curLockPath >>= liftIO . nextLock True >>= setLockPath+processCommand' IMMeta CmdPrevLock =+    gets curLockPath >>= liftIO . nextLock False >>= setLockPath+processCommand' IMMeta CmdNextPage =+    modify $ \ms -> ms { listOffset = listOffset ms + 1 }+processCommand' IMMeta CmdPrevPage =+    modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 }+processCommand' IMMeta CmdEdit = void.runMaybeT $ do+    (lock, msoln) <- msum [ MaybeT $ gets curLock+	, do+	    frame <- BasicFrame <$> msum [ do+		    _ <- gets curServer+		    RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo+		    return size+		, do+		    sizet <- MaybeT $ lift $ textInput+			("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing+		    size <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) sizet)+		    guard $ 3 <= size && size <= maxlocksize+		    return size+		]+	    return ((frame, baseState frame), Nothing)+	]+    path <- lift $ gets curLockPath+    newPath <- MaybeT $ lift $ (esPath <$>) $ execStateT interactUI $ newEditState (reframe lock)+	msoln (if null path then Nothing else Just path)+    lift $ setLockPath newPath+processCommand' IMMeta CmdTutorials = void.runMaybeT $ do+    tutdir <- liftIO $ getDataPath "tutorial"+    tuts <- liftIO $ (sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock")) <$>+	getDirectoryContents tutdir `catchIO` (const $ return [])+    when (null tuts) $ do+	lift.lift $ drawError "No tutorial levels found"+	mzero+    s <- MaybeT $ lift $ textInput ("Play which tutorial level [1-"++show (length tuts)++"]")+	    (length (show (length tuts))) False True Nothing Nothing+    i <- MaybeT $ return $ fst <$> (listToMaybe $ (reads :: ReadS Int) s)+    guard $ 1 <= i && i <= length tuts+    let dotut i = do+	let name = tuts !! (i-1)+	let pref = tutdir ++ [pathSeparator] ++ name+	(lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")+	text <- MaybeT $ liftIO $ listToMaybe <$> readStrings (pref ++ ".text")+	_ <- solveLock lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text+	if i+1 <= length tuts then do+		confirmOrBail $ "Tutorial level completed! Play next tutorial level (" ++ show (i+1) ++ ")?"+		dotut $ i+1+	    else lift $ do +		mauth <- gets curAuth+		lift $ drawMessage $ if isNothing mauth+		    then "Tutorial completed! To play on the server, pick a codename ('C') and register it ('R')."+		    else "Tutorial completed!"+    dotut i+processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do+    name <- mgetCurName+    newRL <- lift (gets retiredLocks) >>= \rl -> case rl of+	Nothing -> do+	    RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name+	    return $ Just lss+	Just _ -> return Nothing+    lift $ modify $ \ms -> ms {retiredLocks = newRL}+    +processCommand' IMPlay CmdUndo = do+    st <- gets psCurrentState+    stack <- gets psGameStateMoveStack+    ustms <- gets psUndoneStack+    unless (null stack) $ do+	let (st',pm) = head stack+	modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack,+	    psLastAlerts = [], psUndoneStack = (st,pm):ustms}+processCommand' IMPlay CmdRedo = do+    ustms <- gets psUndoneStack+    case ustms of +	[] -> return ()+	ustm:ustms' -> do+	    pushPState ustm+	    modify $ \ps -> ps {psUndoneStack = ustms'}+processCommand' IMPlay (CmdManipulateToolAt pos) = do+    board <- stateBoard <$> gets psCurrentState+    wsel <- gets wrenchSelected+    void.runMaybeT $ msum $ [ do+	    tile <- MaybeT $ return $ snd <$> Map.lookup pos board+	    guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}+	    lift $ processCommand' IMPlay $ CmdTile tile+	] ++ [ do+	    tile <- MaybeT $ return $ snd <$> Map.lookup (d<+>pos) board+	    guard $ tileType tile == if wsel then WrenchTile zero else HookTile+	    lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d+	    | d <- hexDirs ]+processCommand' IMPlay (CmdDrag pos dir) = do+    board <- stateBoard <$> gets psCurrentState+    wsel <- gets wrenchSelected+    void.runMaybeT $ do+	tile <- MaybeT $ return $ snd <$> Map.lookup pos board+	guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}+	lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir+	board' <- stateBoard <$> gets psCurrentState+	msum [ do+		tile' <- MaybeT $ return $ snd <$> Map.lookup pos' board'+		guard $ tileType tile' == if wsel then WrenchTile zero else HookTile+		lift.lift $ warpPointer $ pos'+	    | pos' <- [dir<+>pos, pos] ]++processCommand' IMPlay cmd = do+    wsel <- gets wrenchSelected+    st <- gets psCurrentState+    let push whs dir +	    | whs == WHSWrench || (whs == WHSSelected && wsel) =+		Just $ WrenchPush dir+	    | otherwise = Just $ HookPush dir+	torque dir = Just $ HookTorque dir+	(wsel', pm) =+	    case cmd of+		CmdTile (WrenchTile _) -> (True, Nothing)+		CmdTile HookTile -> (False, Nothing)+		CmdTile (ArmTile _ _) -> (False, Nothing)+		CmdToggle -> (not wsel, Nothing)+		CmdDir whs dir -> (wsel, push whs dir)+		CmdRotate dir -> (wsel, torque dir)+		CmdWait -> (wsel, Just NullPM)+		CmdSelect -> (wsel, Just NullPM)+		_ -> (wsel, Nothing)+    modify $ \ps -> ps {wrenchSelected = wsel'}+    case pm of+	 Nothing -> return ()+	 Just pm' -> do+	    (st',alerts) <- lift $ doPhysicsTick pm' st+	    modify $ \ps -> ps {psLastAlerts = alerts}+	    pushPState (st',pm')++processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do+    (st',pm) <- MaybeT $ listToMaybe <$> gets rsGameStateMoveStack+    lift $ modify $ \rs -> rs {rsCurrentState=st'+	, rsGameStateMoveStack = tail $ rsGameStateMoveStack rs+	, rsMoveStack = pm:rsMoveStack rs}+processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $+    processCommand' IMReplay (CmdReplayBack 1)+processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do+    pm <- MaybeT $ listToMaybe <$> gets rsMoveStack+    lift $ do+	st <- gets rsCurrentState+	(st',_) <- lift $ doPhysicsTick pm st+	modify $ \rs -> rs {rsCurrentState = st'+	    , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs+	    , rsMoveStack = tail $ rsMoveStack rs}+processCommand' IMReplay (CmdReplayForward n) = replicateM_ n $+    processCommand' IMReplay (CmdReplayForward 1)+processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1)+processCommand' IMReplay CmdRedo = processCommand' IMReplay (CmdReplayForward 1)++processCommand' IMEdit CmdPlay = do+    st <- gets $ head.esGameStateStack+    frame <- gets esFrame+    modify $ \es -> es {selectedPiece = Nothing}+    subPlay (frame,st)+processCommand' IMEdit CmdTest = do+    frame <- gets esFrame+    modifyEState (\st -> snd $ canonify (frame, st))+    modify $ \es -> es {selectedPiece = Nothing}+    mpath <- gets esPath+    st <- gets $ head.esGameStateStack+    void.runMaybeT $ do+	soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath+	lift $ modify $ \es -> es { esTested = Just (st, soln) }+processCommand' IMEdit CmdUndo = do+    st:sts <- gets esGameStateStack+    usts <- gets esUndoneStack+    unless (null sts) $ modify $ \es -> es {esGameStateStack = sts, esUndoneStack = st:usts}+processCommand' IMEdit CmdRedo = do+    usts <- gets esUndoneStack+    case usts of +	[] -> return ()+	ust:usts' -> do+	    pushEState ust+	    modify $ \es -> es {esUndoneStack = usts'}+processCommand' IMEdit CmdUnselect =+    modify $ \es -> es {selectedPiece = Nothing}+processCommand' IMEdit CmdSelect = do+    selPiece <- gets selectedPiece+    selPos <- gets selectedPos+    st:_ <- gets esGameStateStack+    let selPiece' =+	    if isJust selPiece+		then Nothing+		else liftM fst $ Map.lookup selPos $ stateBoard st+    modify $ \es -> es {selectedPiece = selPiece'}+processCommand' IMEdit (CmdDir _ dir) = do+    selPos <- gets selectedPos+    selPiece <- gets selectedPiece+    frame <- gets esFrame+    case selPiece of+	Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir <+> selPos}+	Just p -> doForce $ Push p dir+processCommand' IMEdit (CmdMoveTo newPos) = do+    frame <- gets esFrame+    modify $ \es -> es {selectedPos = truncateToEditable frame newPos}+processCommand' IMEdit (CmdDrag pos dir) = do+    board <- stateBoard.head <$> gets esGameStateStack+    void.runMaybeT $ do+	selIdx <- MaybeT $ gets selectedPiece+	idx <- MaybeT $ return $ fst <$> Map.lookup pos board+	guard $ idx == selIdx+	lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir+	board' <- stateBoard.head <$> gets esGameStateStack+	msum [ do+		idx' <- MaybeT $ return $ fst <$> Map.lookup pos' board'+		guard $ idx' == selIdx+		lift.lift $ warpPointer $ pos'+	    | pos' <- [dir<+>pos, pos] ]+processCommand' IMEdit (CmdRotate dir) = do+    selPiece <- gets selectedPiece+    case selPiece of+	Nothing -> return ()+	Just p -> doForce $ Torque p dir+processCommand' IMEdit (CmdTile tile) = do+    selPos <- gets selectedPos+    drawTile selPos (Just tile) False+processCommand' IMEdit (CmdPaint tile) = do+    selPos <- gets selectedPos+    drawTile selPos tile True+processCommand' IMEdit (CmdPaintFromTo tile from to) = do+    frame <- gets esFrame+    paintTilePath tile (truncateToEditable frame from) (truncateToEditable frame to)+processCommand' IMEdit CmdMerge = do+    selPos <- gets selectedPos+    st:_ <- gets esGameStateStack+    lift $ drawMessage "Merge in which direction?"+    cmd <- lift $ head <$> getSomeInput IMEdit+    lift $ drawMessage ""+    case cmd of+	CmdDir _ mergeDir -> do+	    modifyEState $ mergeTiles selPos mergeDir True+	    -- XXX: merging might invalidate selectedPiece+	    modify $ \es -> es {selectedPiece = Nothing}+	_ -> return ()+processCommand' IMEdit CmdWait = do+    selPos <- gets selectedPos+    selPiece <- gets selectedPiece+    st:_ <- gets esGameStateStack+    case selPiece of+	Nothing -> drawTile selPos Nothing False+	Just _ -> do (st',_) <- lift $ doPhysicsTick NullPM st+		     pushEState st'+processCommand' IMEdit CmdDelete = do+    selPiece <- gets selectedPiece+    st:_ <- gets esGameStateStack+    case selPiece of+	Nothing -> return ()+	Just p -> do modify $ \es -> es {selectedPiece = Nothing}+		     modifyEState $ delPiece p+processCommand' IMEdit CmdWriteState = void.runMaybeT $ do+    path <- lift $ gets esPath+    newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path+    guard $ not $ null newPath+    fullPath <- liftIO $ fullLockPath newPath+    (liftIO (doesFileExist fullPath `catchIO` const (return True)) >>=) $ flip when $+	confirmOrBail $ "Really overwrite '"++fullPath++"'?"+    lift $ do+	st <- gets $ head.esGameStateStack+	frame <- gets esFrame+	msoln <- getCurTestSoln+	merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing)+	    `catchIO` (return . Just . show)+	modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}+	case merr of+	    Nothing -> modify $ \es -> es {esPath = Just newPath}+	    Just err -> lift $ drawError $ "Write failed: "++err+processCommand' _ _ = return ()++hashPassword :: String -> String -> String+-- ^ salt password+hashPassword name password = hash $ "IY" ++ name ++ password++subPlay :: UIMonad uiM => Lock -> StateT MainState uiM ()+subPlay lock =+    pushEState =<< psCurrentState <$> (lift $ execStateT interactUI $ newPlayState lock Nothing True)++solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (StateT MainState uiM) Solution+solveLock lock title = do+    (InteractSuccess solved, ps) <- lift.lift $ runStateT interactUI $ newPlayState (reframe lock) title False+    guard $ solved+    return $ reverse $ (map snd) $ psGameStateMoveStack ps
+ InteractUtil.hs view
@@ -0,0 +1,225 @@+-- 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 InteractUtil where++import Control.Monad.State+import Control.Applicative+import qualified Data.Vector as Vector+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad.Writer+import Control.Monad.Trans.Error+import Control.Monad.Trans.Maybe+import Data.Maybe+import Data.Char+import Data.List+import System.Directory+import Data.Array+import Data.Function (on)++import Hex+import Command+import Physics+import Mundanities+import GameStateTypes+import EditGameState+import Frame+import Lock+import Protocol+import Metagame+import MainState+import InputMode++checkWon :: UIMonad uiM => StateT MainState uiM ()+checkWon = do+    st <- gets psCurrentState+    frame <- gets psFrame+    when (checkSolved (frame,st)) $ do+	modify $ \ps -> ps {psSolved = True}+	lift $ drawMessage "Unlocked!"+	{-+	pms <- (reverse.(map snd)) `liftM` gets psGameStateMoveStack+	let wfname = fromMaybe "unnamed.lock" fname +	liftIO $ writeFile (wfname++".solution") $ show pms+	liftIO $ B.writeFile (wfname++".solution.bin") $ Bin.encode $ pms+	-}+doForce force = do+    st:_ <- gets esGameStateStack+    let (st',alerts) = runWriter $ resolveForces+	    (Vector.singleton (ForceChoice [force])) Vector.empty+	    (\_ _->False) st+    lift (drawAlerts alerts) >> pushEState st'+drawTile pos tile painting = do+    modify $ \es -> es {selectedPiece = Nothing}+    lastMP <- gets lastModPos+    modifyEState $ modTile tile pos lastMP painting+    modify $ \es -> es {lastModPos = pos}+paintTilePath tile from to = if from == to+    then modify $ \es -> es {lastModPos = to}+    else let from' = (hexVec2HexDirOrZero $ to<->from) <+> from+	in drawTile from' tile True >> paintTilePath tile from' to++pushEState :: UIMonad uiM => GameState -> StateT MainState uiM ()+pushEState st = do+    st':sts <- gets esGameStateStack+    when (st' /= st) $ modify $ \es -> es {esGameStateStack = st:st':sts, esUndoneStack = []}+pushPState :: UIMonad uiM => (GameState,PlayerMove) -> StateT MainState uiM ()+pushPState (st,pm) = do+    st' <- gets psCurrentState+    stms <- gets psGameStateMoveStack+    when (st' /= st) $ modify $ \ps -> ps {psCurrentState = st,+	    psGameStateMoveStack = (st',pm):stms, psUndoneStack = []}+modifyEState :: UIMonad uiM => (GameState -> GameState) -> StateT MainState uiM ()+modifyEState f = do+    st:_ <- gets esGameStateStack+    pushEState $ f st++doPhysicsTick :: UIMonad uiM => PlayerMove -> GameState -> uiM (GameState, [Alert])+doPhysicsTick pm st =+    let r@(st',alerts) = runWriter $ physicsTick pm st in+    drawAlerts alerts >> return r++nextLock :: Bool -> FilePath -> IO FilePath+nextLock newer path = do+    lockdir <- confFilePath "locks"+    time <- (Just <$> (fullLockPath path >>= getModificationTime))+	`catchIO` const (return Nothing)+    paths <- getDirContentsRec lockdir+    maybe path (drop (length lockdir + 1) . fst) . listToMaybe .+	(if newer then id else reverse) . sortBy (compare `on` snd) .+	filter (maybe (const True)+	    (\x y -> (if newer then (<) else (>)) x (snd y)) time) <$>+	(\p -> (,) p <$> getModificationTime p) `mapM` paths++setLockPath path = do+    lock <- liftIO $ fullLockPath path >>= readLock+    modify $ \ms -> ms {curLockPath = path, curLock = lock}++declare undecl@(Undeclared soln ls al) = do+    ourName <- mgetOurName+    ourUInfo <- mgetUInfo ourName+    idx <- askLockIndex "Secure behind which lock?"+	"You first need to place a lock to secure your solution behind."+	(\i -> isJust $ userLocks ourUInfo ! i)+    guard $ isJust $ userLocks ourUInfo ! idx+    lift $ do+	curServerActionAsync $ DeclareSolution soln ls al idx+	mapM_ invalidateUInfo [lockOwner al, ourName]+	refreshUInfoUI++jumpMark :: UIMonad uiM => Char -> StateT MainState uiM ()+jumpMark ch = do+    mst <- get+    void.runMaybeT $ case ms2im mst of+	IMEdit -> do+	    st <- MaybeT $ return $ ch `Map.lookup` esMarks mst+	    lift $ setMark '\'' >> pushEState st+	IMPlay -> do+	    mst' <- MaybeT $ return $ ch `Map.lookup` psMarks mst+	    put mst' { psMarks = Map.insert '\'' mst $ psMarks mst }+	IMReplay -> do+	    mst' <- MaybeT $ return $ ch `Map.lookup` rsMarks mst+	    put mst' { rsMarks = Map.insert '\'' mst $ rsMarks mst }+	_ -> return ()++setMark :: (Monad m) => Char -> StateT MainState m ()+setMark ch = get >>= \mst -> case mst of+    -- ugh... remind me why I'm not using lens?+    EditState { esMarks = marks, esGameStateStack = (st:_) } ->+	put $ mst { esMarks = Map.insert ch st marks }+    PlayState {} -> put $ mst { psMarks = Map.insert ch mst $ psMarks mst }+    ReplayState {} -> put $ mst { rsMarks = Map.insert ch mst $ rsMarks mst }+    _ -> return ()++askLockIndex prompt failMessage pred = do+    let ok = filter pred [0,1,2]+    case length ok of+	0 -> (lift.lift) (drawError failMessage) >> mzero+	1 -> return $ head ok+	_ -> ask ok+    where+	ask ok = do+	    let prompt' = prompt ++ " [" ++ intersperse ',' (map lockIndexChar ok) ++ "]"+	    idx <- MaybeT $ lift $ join . (((charLockIndex<$>).listToMaybe)<$>) <$>+		textInput prompt' 1 False True Nothing Nothing+	    if idx `elem` ok then return idx else ask ok+confirmOrBail prompt = (guard =<<) $ lift.lift $ confirm prompt+confirm :: UIMonad uiM => String -> uiM Bool+confirm prompt = do+    drawMessage $ prompt ++ " [y/N]"+    waitConfirm <* drawMessage ""+    where+	waitConfirm = do+	    cmds <- getInput IMTextInput+	    case msum $ map ansOfCmd cmds of+		Just answer -> return answer+		Nothing -> waitConfirm+	ansOfCmd (CmdInputChar 'y') = Just True+	ansOfCmd (CmdInputChar 'Y') = Just True+	ansOfCmd CmdRedraw = Nothing+	ansOfCmd CmdRefresh = Nothing+	ansOfCmd _ = Just False++-- | TODO: draw cursor+textInput :: UIMonad uiM => String -> Int -> Bool -> Bool -> Maybe [String] -> Maybe String -> uiM (Maybe String)+textInput prompt maxlen hidden endOnMax mposss init = getText (fromMaybe "" init, Nothing) <* drawMessage ""+    where+	getText :: UIMonad uiM => (String, Maybe String) -> uiM (Maybe String)+	getText (s,mstem) = do+	    drawMessage $ prompt ++ " " ++ if hidden then replicate (length s) '*' else s+	    if endOnMax && isNothing mstem && maxlen <= length s+	    then return $ Just $ take maxlen s+	    else do+		cmds <- getInput IMTextInput+		case foldM applyCmd (s,mstem) cmds of+		    Left False -> return Nothing+		    Left True -> return $ Just s+		    Right (s',mstem') -> getText (s',mstem')+	    where+		applyCmd (s,mstem) (CmdInputChar c) = case c of+		    '\ESC' -> Left False+		    '\a' -> Left False -- ^G+		    '\ETX' -> Left False -- ^C+		    '\n' -> Left True+		    '\r' -> Left True+		    '\NAK' -> Right ("",Nothing)  -- ^U+		    '\b' -> Right $ (take (length s - 1) s, Nothing)+		    '\DEL' -> Right $ (take (length s - 1) s, Nothing)+		    '\t' -> case mposss of+			Nothing -> Right (s,mstem)+			Just possibilities -> case mstem of+			    Nothing -> let+				completions = filter (completes s) possibilities+				pref = if null completions then s else+				    let c = head completions+				    in head [ c' | n <- reverse [0..length c],+					let c'=take n c, all (completes c') completions ]+				in Right (pref,Just pref)+			    Just stem -> let+				completions = filter (completes stem) possibilities+				later = filter (>s) completions+				s' | null completions = s+				   | null later = head completions+				   | otherwise = minimum later+				in Right (s',mstem)+		    _ -> Right $ if isPrint c+			    then ((if length s >= maxlen then id else (++[c])) s, Nothing)+			    else (s,mstem)+		applyCmd x (CmdInputSelLock idx) =+		    Right $ ([lockIndexChar idx], Nothing)+		applyCmd x (CmdInputSelUndecl (Undeclared _ _ (ActiveLock name idx))) =+		    Right $ (name++[':',lockIndexChar idx], Nothing)+		applyCmd x (CmdInputCodename name) =+		    Right $ (name, Nothing)+		applyCmd x CmdRedraw = Right x+		applyCmd x CmdRefresh = Right x+		applyCmd _ _ = Left False+	completes s s' = take (length s) s' == s
+ KeyBindings.hs view
@@ -0,0 +1,199 @@+-- 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 KeyBindings (KeyBindings, bindings, findBindings, findBinding, showKey) where++import Data.Maybe+import Data.Char+import Data.List++import Command+import Hex+import GameStateTypes+import InputMode++type KeyBindings = [ (Char,Command) ]++ctrl, unctrl :: Char -> Char+ctrl c = toEnum $ fromEnum c - 64+unctrl c = toEnum $ fromEnum c + 64++lowerToo :: KeyBindings -> KeyBindings+lowerToo = concat . map addLower+    where addLower b@(c, cmd) = [ b, (toLower c, cmd) ]++qwertyViHex =+    [ ('l', CmdDir WHSHook hu)+    , ('h', CmdDir WHSHook $ neg hu)+    , ('b', CmdDir WHSHook hw)+    , ('u', CmdDir WHSHook $ neg hw)+    , ('y', CmdDir WHSHook hv)+    , ('n', CmdDir WHSHook $ neg hv)+    , ('L', CmdDir WHSWrench hu)+    , ('H', CmdDir WHSWrench $ neg hu)+    , ('B', CmdDir WHSWrench hw)+    , ('U', CmdDir WHSWrench $ neg hw)+    , ('Y', CmdDir WHSWrench hv)+    , ('N', CmdDir WHSWrench $ neg hv)+    , ('k', CmdRotate 1)+    , ('j', CmdRotate $ -1)+    ]+qwertyLeftHex =+    [ ('d', CmdDir WHSHook hu)+    , ('a', CmdDir WHSHook $ neg hu)+    , ('z', CmdDir WHSHook hw)+    , ('e', CmdDir WHSHook $ neg hw)+    , ('w', CmdDir WHSHook hv)+    , ('x', CmdDir WHSHook $ neg hv)+    , ('D', CmdDir WHSWrench hu)+    , ('A', CmdDir WHSWrench $ neg hu)+    , ('Z', CmdDir WHSWrench hw)+    , ('E', CmdDir WHSWrench $ neg hw)+    , ('W', CmdDir WHSWrench hv)+    , ('X', CmdDir WHSWrench $ neg hv)+    , ('q', CmdRotate 1)+    , ('c', CmdRotate $ -1)+    , ('S', CmdWait)+    , ('s', CmdWait)+    ]+dvorakMidHex =+    [ ('i', CmdDir WHSWrench hu)+    , ('e', CmdDir WHSWrench $ neg hu)+    , ('j', CmdDir WHSWrench hw)+    , ('y', CmdDir WHSWrench $ neg hw)+    , ('p', CmdDir WHSWrench hv)+    , ('k', CmdDir WHSWrench $ neg hv)+    ]++keypadHex =+    [ ('5', CmdWait)+    , ('6', CmdDir WHSSelected hu)+    , ('4', CmdDir WHSSelected $ neg hu)+    , ('1', CmdDir WHSSelected hw)+    , ('9', CmdDir WHSSelected $ neg hw)+    , ('7', CmdDir WHSSelected hv)+    , ('3', CmdDir WHSSelected $ neg hv)+    , ('8', CmdRotate 1)+    , ('2', CmdRotate $ -1)+    ]++miscLockGlobal = lowerToo+    [ ('X', CmdUndo)+    , ('\b', CmdUndo)+    , ('R', CmdRedo)+    , (ctrl 'R', CmdRedo)+    , (ctrl 'U', CmdUndo)+    , ('.', CmdWait)+    , ('Z', CmdWait)+    , ('M', CmdMark)+    , ('\'', CmdJumpMark)+    ]++miscGlobal = lowerToo+    [ ('Q', CmdQuit)+    , (ctrl 'C', CmdQuit)+    , ('?', CmdHelp)+    , (ctrl 'B', CmdBind)+    , (ctrl 'L', CmdRedraw)+    , (ctrl 'Z', CmdSuspend)+    ]++lockGlobal = keypadHex ++ qwertyViHex ++ miscGlobal ++ miscLockGlobal++playOnly = lowerToo+    [ ('O', CmdOpen)+    , (' ', CmdWait)+    , ('\r', CmdWait)+    , ('\n', CmdWait)+    , ('\t', CmdToggle)+    , ('*', CmdTile $ WrenchTile zero)+    , ('/', CmdTile HookTile)+    , ('@', CmdTile HookTile)+    ]+replayOnly =+    [ (' ', CmdReplayForward 1)+    ]+editMisc = lowerToo+    [ ('P', CmdPlay)+    , (' ', CmdSelect)+    , ('\r', CmdSelect)+    , ('\n', CmdSelect)+    , ('T', CmdTest)+    , ('W', CmdWriteState)+    , (ctrl 'S', CmdWriteState)+    , ('&', CmdMerge)+    , ('E', CmdDelete)+    ]+tilesPaintRow = lowerToo+    [ ('G', CmdTile BallTile)+    , ('F', CmdTile $ ArmTile zero False)+    , ('D', CmdTile $ PivotTile zero)+    , ('S', CmdTile $ SpringTile Relaxed zero)+    , ('A', CmdTile $ BlockTile [])+    , ('Z', CmdWait)+    ]+tilesAscii =+    [ ('o', CmdTile $ PivotTile zero)+    , ('O', CmdTile BallTile)+    , ('S', CmdTile $ SpringTile Relaxed zero)+    --, ('s', CmdTile $ SpringTile Stretched zero)+    --, ('$', CmdTile $ SpringTile Compressed zero)+    , ('-', CmdTile $ ArmTile zero False)+    --, ('-', CmdTile $ ArmTile hu False)+    , ('\\', CmdTile $ ArmTile hv False)+    , ('/', CmdTile $ ArmTile hw False)+    , ('@', CmdTile HookTile)+    , ('*', CmdTile $ WrenchTile zero)+    , ('#', CmdTile $ BlockTile [])+    ]+editOnly = editMisc ++ tilesPaintRow ++ tilesAscii++playBindings = playOnly ++ lockGlobal+replayBindings = replayOnly ++ lockGlobal+editBindings = editOnly ++ lockGlobal+metaBindings = lowerToo+    [ ('C', CmdSelCodename Nothing)+    , ('H', CmdHome)+    , ('B', CmdBackCodename)+    , ('S', CmdSolve Nothing)+    , ('D', CmdDeclare Nothing)+    , ('V', CmdViewSolution Nothing)+    , ('R', CmdRegister)+    , ('P', CmdPlaceLock Nothing)+    , ('E', CmdEdit)+    , ('L', CmdSelectLock)+    , ('O', CmdPrevLock)+    , ('N', CmdNextLock)+    , ('A', CmdAuth)+    , ('T', CmdTutorials)+    , ('+', CmdShowRetired)+    , ('#', CmdPlayLockSpec Nothing)+    , ('$', CmdSetServer)+    , ('^', CmdToggleCacheOnly)+    , ('>', CmdNextPage)+    , ('<', CmdPrevPage)+    ] ++ miscGlobal++bindings :: InputMode -> KeyBindings+bindings IMEdit = editBindings+bindings IMPlay = playBindings+bindings IMMeta = metaBindings+bindings IMReplay = replayBindings+bindings _ = []++findBindings :: KeyBindings -> Command -> [Char]+findBindings bdgs cmd = nub [ ch | (ch,cmd') <- bdgs, cmd'==cmd ]++findBinding :: KeyBindings -> Command -> Maybe Char+findBinding = (listToMaybe.) . findBindings++showKey ch | isPrint ch = [ch]+showKey ch | isPrint (unctrl ch) = ('^':[unctrl ch])+showKey _ = "[?]"
+ Lock.hs view
@@ -0,0 +1,90 @@+-- 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 Lock where+import Control.Monad.Writer+import Data.Maybe+import qualified Data.Map as Map++import Frame+import GameState+import GameStateTypes+import Hex+import Util+import Physics++type Lock = (Frame, GameState)+liftLock :: (GameState -> GameState) -> (Lock -> Lock)+liftLock g (f,st) = (f,g st)++lockSize (f,_) = frameSize f++deframe :: Lock -> Lock+deframe = delTools . liftLock (setpp 0 nullpp)+nullpp = PlacedPiece (PHS zero) (Block [])++reframe :: Lock -> Lock+reframe l@(f, st) = addTools $ delTools $ liftLock (setpp 0 (framePiece f)) l++validLock :: Lock -> Bool+validLock lock@(f,st) = and+    [ st == stepPhysics st+    , lock == reframe lock+    , validGameState st +    ]++stepPhysics :: GameState -> GameState+stepPhysics = fst.runWriter.physicsTick NullPM++type Solution = [PlayerMove]++checkSolution :: Lock -> Solution -> Bool+checkSolution lock pms =+    let (frame,st) = reframe lock+    in any (\st' -> checkSolved (frame,st')) $+		scanl (((fst.runWriter).).flip physicsTick) st pms++checkSolved :: Lock -> Bool+checkSolved (f,st) =+    let b = stateBoard st in+	and [ isNothing $ Map.lookup p b | p <- boltArea f ]+++canonify :: Lock -> Lock+canonify = addTools . stabilise . delTools . delOOB+delTools :: Lock -> Lock+delTools = liftLock delTools'+    where+	delTools' :: GameState -> GameState+	delTools' st =+	    case listToMaybe [ idx | (idx,pp) <- enumVec $ placedPieces st+			      , isTool $ placedPiece pp ] of+		Nothing -> st+		Just idx -> delTools' $ delPiece idx st+addTools :: Lock -> Lock+addTools (f,st) =+    let st' = clearToolArea f st+    in (f, foldr addpp st' $ initTools f)+stabilise :: Lock -> Lock+stabilise = liftLock stabilise'+    where+	stabilise' :: GameState -> GameState+	stabilise' st =+	    let st' = stepPhysics st+	    in if st == st' then st else stabilise' st'++delOOB :: Lock -> Lock+delOOB l@(f,st) = case listToMaybe [ idx |+	(idx,_) <- enumVec $ placedPieces st+	, not $ isFrame idx+	, all (not.inBounds f) $ fullFootprint st idx+	, null $ springsEndAtIdx st idx] of+    Nothing -> l+    Just idx -> delOOB $ liftLock (delPiece idx) l
+ MainBoth.hs view
@@ -0,0 +1,22 @@+-- 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 Main where++import Init+import qualified SDLUI (UIM)+import SDLUIMInstance ()+import qualified CursesUI (UIM)+import CursesUIMInstance ()+import MainState++main = main' +    (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState)))+    (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState)))
+ MainCurses.hs view
@@ -0,0 +1,20 @@+-- 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 Main where++import Init+import qualified CursesUI (UIM)+import CursesUIMInstance ()+import MainState++main = main' +    (Nothing :: (Maybe (CursesUI.UIM MainState -> IO (Maybe MainState))))+    (Just (doUI::CursesUI.UIM MainState -> IO (Maybe MainState)))
+ MainSDL.hs view
@@ -0,0 +1,20 @@+-- 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 Main where++import Init+import qualified SDLUI+import SDLUIMInstance ()+import MainState++main = main' +    (Just (doUI::SDLUI.UIM MainState -> IO (Maybe MainState)))+    (Nothing :: (Maybe (SDLUI.UIM MainState -> IO (Maybe MainState))))
+ MainState.hs view
@@ -0,0 +1,370 @@+-- 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 MainState where++import Control.Monad.State+import Control.Applicative+import qualified Data.Vector as Vector+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad.Writer+import Control.Monad.Trans.Error+import Control.Monad.Trans.Maybe+import Data.Maybe+import Data.Char+import Data.List+import Control.Concurrent.STM+import Control.Concurrent+import System.Directory+import System.FilePath+import Data.Time.Clock+import Data.Array+import Data.Function (on)++import Hex+import Mundanities+import AsciiLock+import GameStateTypes+import Physics+import Command+import Frame+import Lock+import Cache+import Database+import Protocol+import Metagame+import ServerAddr+import InputMode++class (Applicative m, MonadIO m) => UIMonad m where+    runUI :: m a -> IO a+    initUI :: m Bool+    endUI :: m ()+    drawMainState :: StateT MainState m ()+    drawAlerts :: [Alert] -> m ()+    drawMessage :: String -> m ()+    drawError :: String -> m ()+    showHelp :: InputMode -> m ()+    getInput :: InputMode -> m [ Command ]+    getChRaw :: m ( Maybe Char )+    unblockInput :: m (IO ())+    setUIBinding :: InputMode -> Command -> Char -> m ()+    getDrawImpatience :: m ( Int -> IO () )+    warpPointer :: HexPos -> m ()+    suspend,redraw :: m ()++    doUI :: m a -> IO (Maybe a)+    doUI m = runUI $ do+	ok <- initUI+	if ok then m >>= (endUI >>).return.Just else return Nothing++-- | this could be neatened using GADTs+data MainState +    = PlayState+	{ psCurrentState::GameState+	, psFrame::Frame+	, psLastAlerts::[Alert]+	, wrenchSelected::Bool+	, psSolved::Bool+	, psGameStateMoveStack::[(GameState, PlayerMove)]+	, psUndoneStack::[(GameState, PlayerMove)]+	, psTitle::Maybe String+	, psIsSub::Bool+	, psMarks::Map Char MainState+	}+    | ReplayState+	{ rsCurrentState::GameState+	, rsMoveStack::[PlayerMove]+	, rsGameStateMoveStack::[(GameState, PlayerMove)]+	, rsTitle::Maybe String+	, rsMarks::Map Char MainState+	}+    | EditState+	{ esGameStateStack::[GameState]+	, esUndoneStack::[GameState]+	, esFrame::Frame+	, esPath::Maybe FilePath+	, esTested::Maybe (GameState,Solution)+	, lastSavedState::Maybe (GameState, Bool)+	, selectedPiece::Maybe PieceIdx+	, selectedPos::HexPos+	, lastModPos::HexPos+	, esMarks::Map Char GameState+	}+    | MetaState+	{ curServer :: ServerAddr+	, undeclareds :: [Undeclared]+	, cacheOnly :: Bool+	, curAuth :: Maybe Auth+	, codenameStack :: [Codename]+	, newAsync :: TVar Bool+	, asyncError :: TVar (Maybe String)+	, randomCodenames :: TVar [Codename]+	, userInfos :: Map Codename (TVar FetchedRecord, UTCTime)+	, indexedLocks :: Map LockSpec (TVar FetchedRecord)+	, retiredLocks :: Maybe [LockSpec]+	, curLockPath :: FilePath+	, curLock :: Maybe (Lock,Maybe Solution)+	, listOffset :: Int+	}++newPlayState (frame,st) title sub = PlayState st frame [] False False [] [] title sub Map.empty+newReplayState st soln title = ReplayState st soln [] title Map.empty+newEditState (frame,st) msoln mpath = EditState [st] [] frame mpath+    ((\s->(st,s))<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty+initMetaState = do+    flag <- atomically $ newTVar False+    errtvar <- atomically $ newTVar Nothing+    rnamestvar <- atomically $ newTVar []+    (saddr, auth, path) <- confFilePath "metagame.conf" >>=+	liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile+    let names = maybeToList $ authUser <$> auth+    undecls <- if nullSaddr saddr then return [] else+	confFilePath ("undeclared" ++ [pathSeparator] ++ saddrStr saddr) >>=+	liftM (fromMaybe []) . readReadFile+    mlock <- fullLockPath path >>= readLock+    return $ MetaState saddr undecls False auth names flag errtvar rnamestvar Map.empty Map.empty Nothing path mlock 0++readLock :: FilePath -> IO (Maybe (Lock, Maybe Solution))+readLock path = runMaybeT $ msum+	[ (\l->(l,Nothing)) <$> (MaybeT $ readReadFile path)+	, do+	    (mlock,msoln) <- lift $ readAsciiLockFile path+	    lock <- MaybeT $ return mlock+	    return $ (lock,msoln) ]+-- writeLock :: FilePath -> Lock -> IO ()+-- writeLock path lock = fullLockPath path >>= flip writeReadFile lock+fullLockPath path = if isAbsolute path+    then return path+    else (++(pathSeparator:path)) <$> confFilePath "locks"++writeMetaState (MetaState { curServer=saddr, undeclareds=undecls, curAuth=auth, curLockPath=path }) = do+    confFilePath "metagame.conf" >>= flip writeReadFile (saddr, auth, path)+    unless (nullSaddr saddr) $+	confFilePath ("undeclared" ++ [pathSeparator] ++ saddrStr saddr) >>= flip writeReadFile undecls++ms2im :: MainState -> InputMode+ms2im mainSt = case mainSt of+    PlayState {} -> IMPlay+    ReplayState {} -> IMReplay+    EditState {} -> IMEdit+    MetaState {} -> IMMeta++getTitle :: UIMonad uiM => StateT MainState uiM (Maybe String)+getTitle = ms2im <$> get >>= \im -> case im of+    IMEdit -> do+	mpath <- gets esPath+	unsaved <- editStateUnsaved+	isTested <- isJust <$> getCurTestSoln+	return $ Just $ "editing " ++ fromMaybe "[unnamed lock]" mpath ++ +	    (if isTested then " (Tested)" else "") +++	    (if unsaved then " [+]" else "    ")+    IMPlay -> gets psTitle+    IMReplay -> gets rsTitle+    _ -> return Nothing++editStateUnsaved :: UIMonad uiM => StateT MainState uiM Bool+editStateUnsaved = (isNothing <$>) $ runMaybeT $ do+    (sst,tested) <- MaybeT $ gets lastSavedState+    st <- lift $ gets $ head.esGameStateStack+    guard $ sst == st+    nowTested <- isJust <$> lift getCurTestSoln+    guard $ tested == nowTested++getCurTestSoln :: UIMonad uiM => StateT MainState uiM (Maybe Solution)+getCurTestSoln = runMaybeT $ do+    (st',soln) <- MaybeT $ gets esTested+    st <- lift $ gets $ head.esGameStateStack+    guard $ st == st'+    return soln++instance Error () where noMsg = ()++mgetOurName :: (UIMonad uiM) => MaybeT (StateT MainState uiM) Codename+mgetOurName = MaybeT $ (authUser <$>) <$> gets curAuth+mgetCurName :: (UIMonad uiM) => MaybeT (StateT MainState uiM) Codename+mgetCurName = MaybeT $ listToMaybe <$> gets codenameStack ++getUInfoFetched :: UIMonad uiM => Integer -> Codename -> StateT MainState uiM FetchedRecord+getUInfoFetched staleTime name =+    gets ((Map.lookup name) . userInfos) >>=+	\x -> case x of+	    Nothing -> set+	    Just (tvar, time) -> do+		now <- liftIO getCurrentTime+		if floor (diffUTCTime now time) > staleTime+		    then set+		    else liftIO $ atomically $ readTVar tvar+    where set = do+	    tvar <- setUInfoTVar name+	    liftIO $ atomically $ readTVar tvar++mgetUInfo :: UIMonad uiM => Codename -> MaybeT (StateT MainState uiM) UserInfo+mgetUInfo name = do+    RCUserInfo (_,uinfo) <- MaybeT $ (fetchedRC <$>) $ getUInfoFetched defaultStaleTime name+    return uinfo+    where defaultStaleTime = 300++setUInfoTVar :: UIMonad uiM => Codename -> StateT MainState uiM (TVar FetchedRecord)+setUInfoTVar name = do+    now <- liftIO getCurrentTime+    tvar <- getRecordCachedFromCur True $ RecUserInfo name+    modify $ \ms -> ms {userInfos = Map.insert name (tvar, now) $ userInfos ms}+    return tvar++invalidateUInfo :: UIMonad uiM => Codename -> StateT MainState uiM ()+invalidateUInfo name = +    modify $ \ms -> ms {userInfos = Map.delete name $ userInfos ms}++mgetLock :: UIMonad uiM => LockSpec -> MaybeT (StateT MainState uiM) Lock+mgetLock ls = do+    tvar <- msum [ MaybeT $ (Map.lookup ls) <$> gets indexedLocks +	, lift $ do+	    tvar <- getRecordCachedFromCur True $ RecLock ls +	    modify $ \ms -> ms { indexedLocks = Map.insert ls tvar $ indexedLocks ms }+	    return tvar ]+    RCLock lock <- MaybeT $ (fetchedRC<$>) $ liftIO $ atomically $ readTVar tvar+    return $ reframe lock++refreshUInfoUI :: (UIMonad uiM) => StateT MainState uiM ()+refreshUInfoUI = void.runMaybeT $ do+    modify $ \ms -> ms { listOffset = 0 }+    mourNameSelected >>= flip when getRandomNames+    lift $ modify $ \ms -> ms {retiredLocks = Nothing}+    lift.lift $ drawMessage ""+    where+	getRandomNames = do+	    rnamestvar <- gets randomCodenames+	    flag <- gets newAsync+	    saddr <- gets curServer+	    void $ liftIO $ forkIO $ do+		resp <- makeRequest saddr $+		    ClientRequest protocolVersion Nothing $ GetRandomNames 19+		case resp of+		    ServedRandomNames names -> atomically $ do +			    writeTVar rnamestvar names+			    writeTVar flag True+		    _ -> return ()++mourNameSelected :: (UIMonad uiM) => MaybeT (StateT MainState uiM) Bool+mourNameSelected = liftM2 (==) mgetCurName mgetOurName++purgeInvalidUndecls :: (UIMonad uiM) => StateT MainState uiM ()+purgeInvalidUndecls = do+    undecls' <- gets undeclareds >>= filterM ((not<$>).invalid)+    modify $ \ms -> ms { undeclareds = undecls' }+    where+	invalid (Undeclared _ ls (ActiveLock name idx)) =+	    (fromMaybe False <$>) $ runMaybeT $ do+		uinfo <- mgetUInfo name+		ourName <- mgetOurName+		msum [ do+			linfo <- MaybeT $ return $ userLocks uinfo ! idx+			return $ public linfo +			    || ourName `elem` accessedBy linfo +			    || lockSpec linfo /= ls+		    , return True+		    ]++curServerAction :: UIMonad uiM => Protocol.Action -> StateT MainState uiM ServerResponse+curServerAction act = do+    saddr <- gets curServer+    auth <- gets curAuth+    cOnly <- gets cacheOnly+    if cOnly then return $ ServerError "Can't contact server in cache-only mode"+	else lift $ withImpatience $ liftIO $ makeRequest saddr $ ClientRequest protocolVersion auth act++curServerActionAsync :: UIMonad uiM => Protocol.Action -> StateT MainState uiM ()+curServerActionAsync act = do+    saddr <- gets curServer+    auth <- gets curAuth+    flag <- gets newAsync+    errtvar <- gets asyncError+    cOnly <- gets cacheOnly+    void $ liftIO $ forkIO $ do+	resp <- if cOnly then return $ ServerError "Can't contact server in cache-only mode"+		else makeRequest saddr $ ClientRequest protocolVersion auth act+	case resp of+	    ServerError err -> atomically $ writeTVar errtvar $ Just err+	    _ -> return ()+	atomically $ writeTVar flag True++checkAsyncErrors :: UIMonad uiM => StateT MainState uiM ()+checkAsyncErrors = void.runMaybeT $ do+    errtvar <- lift $ gets asyncError+    err <- MaybeT $ liftIO $ atomically $ readTVar errtvar+    lift.lift $ drawError err+    liftIO $ atomically $ writeTVar errtvar Nothing++getRecordCachedFromCur :: UIMonad uiM => Bool -> Record -> StateT MainState uiM (TVar FetchedRecord)+getRecordCachedFromCur flagIt rec = do+    saddr <- gets curServer+    auth <- gets curAuth+    cOnly <- gets cacheOnly+    flag <- gets newAsync+    liftIO $ getRecordCached saddr auth+	(if flagIt then Just flag else Nothing) cOnly rec++getFreshRecBlocking :: UIMonad uiM => Record -> StateT MainState uiM (Maybe RecordContents)+getFreshRecBlocking rec = do+    tvar <- getRecordCachedFromCur False rec+    cOnly <- gets cacheOnly+    fetched <- lift $ withImpatience $ liftIO $ atomically $ do+	fetched@(FetchedRecord fresh _ _) <- readTVar tvar+	check $ fresh || cOnly+	return fetched+    case fetchError fetched of+	Nothing -> return $ fetchedRC fetched+	Just err -> lift (drawError err) >> return Nothing++-- |draw indication that we're waiting for the server while we do so+withImpatience :: UIMonad uiM => uiM a -> uiM a+withImpatience m = do+    drawImpatience <- getDrawImpatience+    finishedTV <- liftIO $ atomically $ newTVar False+    let waitImpatiently ticks = do+	    wakeTV <- atomically $ newTVar False+	    forkIO $ threadDelay (10^6) >> atomically (writeTVar wakeTV True)+	    finished <- atomically $ do+		wake <- readTVar wakeTV+		finished <- readTVar finishedTV+		check $ wake || finished+		return finished+	    when (not finished) $ drawImpatience (ticks+1) >> waitImpatiently (ticks+1)+    liftIO $ forkIO $ waitImpatiently 0+    m <* (liftIO $ atomically $ writeTVar finishedTV True)++getRelScore :: (UIMonad uiM) => Codename -> StateT MainState uiM (Maybe Int)+getRelScore name = runMaybeT $ do+    ourName <- mgetOurName+    guard $ ourName /= name+    uinfo <- mgetUInfo name+    ourUInfo <- mgetUInfo ourName+    return $ countUnaccessedBy ourUInfo name - countUnaccessedBy uinfo ourName+    where+	countUnaccessedBy ui name = length $ filter (not.snd) $ getAccessInfo ui name ++getNotesReadOn :: UIMonad uiM => LockInfo -> StateT MainState uiM [NoteInfo]+getNotesReadOn lockinfo = (fromMaybe [] <$>) $ runMaybeT $ do+    ourName <- mgetOurName+    ourUInfo <- mgetUInfo ourName+    return $ filter (\n -> isNothing (noteBehind n)+	    || n `elem` notesRead ourUInfo) $ lockSolutions lockinfo++testAuth :: UIMonad uiM => StateT MainState uiM ()+testAuth = (isJust <$> gets curAuth >>=) $ flip when $ do+    resp <- curServerAction $ Authenticate+    case resp of+	ServerMessage msg -> (lift $ drawMessage $ "Server: " ++ msg)+	ServerError err -> do+	    lift $ drawMessage err+	    modify $ \ms -> ms {curAuth = Nothing}+	_ -> return ()
+ Maxlocksize.hs view
@@ -0,0 +1,15 @@+-- 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 Maxlocksize where++-- | Locks bigger than 11 won't fit in an 80x25 terminal+maxlocksize :: Int+maxlocksize = 11
+ Metagame.hs view
@@ -0,0 +1,148 @@+-- 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 Metagame where++import Control.Applicative+import Data.Array+import Data.Binary+import Control.Monad+import Data.List (delete)+import Data.Char++import GameStateTypes+import Lock++notesNeeded = 3+maxLocks = 3++type Codename = String++validCodeName name = length name == 3 && all validChar name+    where validChar c = isAscii c && isPrint c && not (isLower c) && c /= ' '++data UserInfo = UserInfo {codename::Codename, userLocks::Array LockIndex (Maybe LockInfo), notesRead::[NoteInfo]}+    deriving (Eq, Ord, Show, Read)++initUserInfo name = UserInfo name (array (0,maxLocks-1) $ zip [0..maxLocks-1] (repeat Nothing)) []++data LockInfo = LockInfo {lockSpec::LockSpec, public::Bool, notesSecured::[NoteInfo], lockSolutions::[NoteInfo], accessedBy::[Codename]}+    deriving (Eq, Ord, Show, Read)++initLockInfo ls = LockInfo ls False [] [] []++getAccessInfo :: UserInfo -> Codename -> [(Bool,Bool)]+-- | getAccessInfo ui name = [(ith lock is public, ith lock is accessed by name) | i]+getAccessInfo ui name =+    let mlinfos = elems $ userLocks ui+	accessedSlot = maybe accessedAllExisting accessedLock+	accessedAllExisting = all (maybe True accessedLock) mlinfos+	accessedLock linfo = public linfo || name `elem` accessedBy linfo +    in map (\mlinfo -> (maybe False public mlinfo, accessedSlot mlinfo)) mlinfos++data UserInfoDelta+    = AddRead NoteInfo+    | DelRead NoteInfo+    | PutLock LockSpec LockIndex+    | LockDelta LockIndex LockDelta+    deriving (Eq, Ord, Show, Read)+data LockDelta+    = SetPubNote NoteInfo+    | AddSecured NoteInfo+    | DelSecured NoteInfo+    | AddSolution NoteInfo+    | AddAccessed Codename+    | SetPublic+    deriving (Eq, Ord, Show, Read)++data NoteInfo = NoteInfo {noteAuthor::Codename, noteBehind::Maybe ActiveLock, noteOn::ActiveLock} +    deriving (Eq, Ord, Show, Read)++data ActiveLock = ActiveLock {lockOwner::Codename, lockIndex :: LockIndex}+    deriving (Eq, Ord, Show, Read)++data Undeclared = Undeclared Solution LockSpec ActiveLock+    deriving (Eq, Ord, Show, Read)++-- | permanent serial number of a lock+type LockSpec = Int++-- | which of a user's three locks (0,1, or 2)+type LockIndex = Int++-- | solved state+type Hint = GameState++lockIndexChar :: LockIndex -> Char+lockIndexChar i = toEnum $ i + fromEnum 'A' +charLockIndex c = fromEnum (toUpper c) - fromEnum 'A'++applyDeltas :: UserInfo -> [UserInfoDelta] -> UserInfo+applyDeltas = foldr applyDelta++applyDelta :: UserInfoDelta -> UserInfo -> UserInfo+applyDelta (AddRead n) info = info { notesRead = n:(notesRead info) }+applyDelta (DelRead n) info = info { notesRead = delete n (notesRead info) }+applyDelta (PutLock ls li) info = info { userLocks = userLocks info // [(li, Just $ initLockInfo ls)] }+applyDelta (LockDelta li ld) info =+    info { userLocks = userLocks info // [(li, liftM (applyLockDelta ld) (userLocks info ! li))] }+applyLockDelta (SetPubNote n) lockinfo = lockinfo { lockSolutions = map+    (\n' -> if n' == n then n {noteBehind=Nothing} else n') (lockSolutions lockinfo) }+applyLockDelta (AddSecured n) lockinfo = lockinfo { notesSecured = n:(notesSecured lockinfo) }+applyLockDelta (DelSecured n) lockinfo = lockinfo { notesSecured = delete n $ notesSecured lockinfo }+applyLockDelta (AddSolution n) lockinfo = lockinfo { lockSolutions = n:(lockSolutions lockinfo) }+applyLockDelta (AddAccessed name) lockinfo = lockinfo { accessedBy = name:(delete name $ accessedBy lockinfo) }+applyLockDelta SetPublic lockinfo = lockinfo { public = True, lockSolutions = [], accessedBy = []}++instance Binary UserInfo where+    put (UserInfo name locks notes) = put name >> put locks >> put notes+    get = liftM3 UserInfo get get get++instance Binary UserInfoDelta where+    put (AddRead note) = put (0::Word8) >> put note+    put (DelRead note) = put (1::Word8) >> put note+    put (PutLock ls li) = put (2::Word8) >> put ls >> put li+    put (LockDelta li ld) = put (3::Word8) >> put li >> put ld+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> AddRead <$> get+	    1 -> DelRead <$> get+	    2 -> PutLock <$> get <*> get+	    3 -> LockDelta <$> get <*> get++instance Binary LockDelta where+    put (SetPubNote note) = put (0::Word8) >> put note+    put (AddSecured note) = put (1::Word8) >> put note+    put (DelSecured note) = put (2::Word8) >> put note+    put (AddSolution note) = put (3::Word8) >> put note+    put (AddAccessed name) = put (4::Word8) >> put name+    put SetPublic = put (5::Word8)+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> SetPubNote <$> get+	    1 -> AddSecured <$> get+	    2 -> DelSecured <$> get+	    3 -> AddSolution <$> get+	    4 -> AddAccessed <$> get+	    5 -> return SetPublic++instance Binary LockInfo where+    put (LockInfo spec pk notes solved accessed) = put spec >> put pk >> put notes >> put solved >> put accessed+    get = liftM5 LockInfo get get get get get ++instance Binary NoteInfo where+    put (NoteInfo author behind on) = put author >> put behind >> put on+    get = liftM3 NoteInfo get get get++instance Binary ActiveLock where+    put (ActiveLock owner idx) = put owner >> put idx+    get = liftM2 ActiveLock get get
+ Mundanities.hs view
@@ -0,0 +1,72 @@+-- 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 Mundanities where+import Control.Applicative+import Control.Arrow+import Control.Monad+import qualified Control.Exception as E+import System.Directory+import System.FilePath+import Data.Maybe+import Data.List+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Paths_intricacy++-- | This is "catchIOError" in >=base-4.4, but we reimplement it to support+-- older bases.+catchIO :: IO a -> (IOError -> IO a) -> IO a+catchIO = E.catch++readReadFile :: (Read a) => FilePath -> IO (Maybe a)+readReadFile file =+    (tryRead . BSC.unpack <$> BS.readFile file)+	`catchIO` (const $ return Nothing)+tryRead :: (Read a) => String -> Maybe a+tryRead = (fst <$>) . listToMaybe . reads++readStrings :: FilePath -> IO [String]+readStrings = (lines . BSC.unpack <$>) . BS.readFile++writeReadFile :: (Show a) => FilePath -> a -> IO ()+writeReadFile file x = do+    mkdirhierto file+    BS.writeFile file $ BSC.pack $ show x++writeStrings :: FilePath -> [String] -> IO ()+writeStrings file x = do+    mkdirhierto file+    BS.writeFile file $ BSC.pack $ unlines x++confFilePath :: FilePath -> IO FilePath+confFilePath str =+    (++(pathSeparator:str)) <$> getAppUserDataDirectory "intricacy"++getDataPath :: FilePath -> IO FilePath+getDataPath = getDataFileName++makeConfDir :: IO ()+makeConfDir = confFilePath "" >>= createDirectoryIfMissing False++mkdirhierto :: FilePath -> IO ()+mkdirhierto = mkdirhier . takeDirectory++mkdirhier :: FilePath -> IO ()+mkdirhier path = do+    exists <- doesDirectoryExist path+    unless exists $ mkdirhierto path >> createDirectory path++getDirContentsRec :: FilePath -> IO [FilePath]+getDirContentsRec path = flip catchIO (const $ return []) $ do+    contents <- map ((path++[pathSeparator])++) <$> filter ((/='.').head) <$> getDirectoryContents path+    annotated <- (\p -> (,) p <$> doesDirectoryExist p) `mapM` contents+    let (dirs,files) = join (***) (map fst) $ partition snd annotated+    (files++) . concat <$> getDirContentsRec `mapM` dirs
+ NEWS view
@@ -0,0 +1,53 @@+0.3:+    Minor fixes; first version uploaded to hackage+0.2.8:+    Implemented click-and-drag movement in play and edit modes.+0.2.7:+    Improvements to curses UI - handle resizing; show keys; allow rebinding.+    Fixed some bugs with viewing notes.+0.2.6.3:+    Update default server address+0.2.6.2:+    Fix silly crash bug introduced by 0.2.6.1+0.2.6.1:+    Add mouse control of tools+0.2.6:+    Minor UI tweaks.+0.2.5:+    Shortened tutorial drastically. Other levels now in 'tutorial-extra/'.+    Improved video setup handling.+    Fixed bug with text disappearing on resize.+0.2.4:+    Improve handling inaccessible servers.+    Added background.+    Fixed bug with prompts being quickly dismissed when using the mouse.+0.2.3:+    Minor graphical improvements.+0.2.2:+    Visible changes:+	scoring tweak: empty slots are accessed iff all non-empty slots are;+	'q'uit confirmation now reminds you what you're quitting from;+	we now consider testedness when deciding if a lock is modified;+	added detailed game info to the README;+	added hover text for UI buttons.+    Bugs fixed:+	editor, lockfile reader, and validity checker were not in accordance+	    on what is allowed as the root of a spring;+	SDL UI was redrawing the screen on every mouse movement;+	curses UI wasn't refreshing properly on async flag.+0.2.1:+    New features:+	The "reset tools" command has become a "test lock" command. Successful+	    tests are saved along with the lock, meaning you can then place the+	    lock without having to test it again.++	You can now use marks in 'play' mode, and there's a default mark for the+	    initial state, effectively giving a "reset" command.++    Bugs fixed: +	stale notes weren't getting refreshed+	retired display got stuck on changing codename+	you couldn't move into the bolthole with keyboard commands+    +0.2:+    First public release
+ Physics.hs view
@@ -0,0 +1,267 @@+-- 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 Physics where++import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as Vector+import Control.Monad.State+import Control.Monad.Writer+import Data.Foldable (foldrM)+import Data.List+import Data.Vector (Vector, (!), (//))++import Hex+import Util+import GameState+import GameStateTypes++-- | a list of forces to try in order:+newtype ForceChoice = ForceChoice {getForceChoice :: [Force]}++type ForceChoices = Vector.Vector ForceChoice++forceIdx :: Force -> PieceIdx+forceIdx force = case force of (Push idx _) -> idx+			       (Torque idx _) -> idx++isPush,isTorque,forceIsNull :: Force -> Bool+isPush (Push _ _) = True+isPush _ = False+isTorque = not . isPush+forceIsNull (Push _ dir) = dir == zero+forceIsNull (Torque _ dir) = dir == 0++getForcedpp :: GameState -> Force -> PlacedPiece+getForcedpp s f = getpp s (forceIdx f)++-- |PlayerMove: if not NullPM, the direction should be non-zero+data PlayerMove = NullPM | HookPush HexDir | HookTorque TorqueDir | WrenchPush HexDir+    deriving (Eq, Ord, Show, Read)++toolForces :: GameState -> PlayerMove -> ForceChoices+toolForces st pm = Vector.fromList $+    [ ForceChoice (wmom++wmove)+    | (widx, PlacedPiece _ (Wrench mom)) <- epps+    , let wmom = if mom == zero then [] else [Push widx mom]+    , let wmove = case pm of {WrenchPush v -> [Push widx v]; _ -> []}+    , not $ null (wmom++wmove)+    ] ++ case pm of+	HookTorque ht -> [ ForceChoice [Torque hidx ht] | hidx <- hidxs ]+	HookPush hp -> [ ForceChoice [Push hidx hp] | hidx <- hidxs ]+	_ -> []+    where+	epps = enumVec $ placedPieces st+	hidxs = [ hidx | (hidx, PlacedPiece _ (Hook _ _)) <- epps ]++-- |Dominance: a propagand of a source force F can not block any progagand of+-- a source force which dominates F.+-- F dominates F' iff F and F' are spring forces, and the end of F is an+-- ancestor of the root of F'.+-- Note that by acyclicity of the connection digraph, domination is+-- antisymmetric.+type Dominance = Int -> Int -> Bool++envForces :: GameState -> (ForceChoices, Dominance)+envForces st@(GameState _ conns) =+    let rootedForces :: Vector (Maybe PieceIdx, Force)+	rootedForces = Vector.fromList [ (Just rootIdx, Push endIdx dir)+	    | c@(Connection (rootIdx,_) (endIdx,_) (Spring outDir natLen)) <- conns+	    , let curLen = connectionLength st c+	    , natLen /= curLen+	    , let dir = if natLen > curLen then outDir else neg outDir ]++    in ( Vector.map (ForceChoice . replicate 1 . snd) rootedForces, +	\f1 f2 -> Just True == do+		rootIdx <- fst $ rootedForces!f2+		return $ connGraphPathExists st (forceIdx.snd $ rootedForces!f1) rootIdx )+	++setTools :: PlayerMove -> GameState -> GameState+setTools pm st =+    let hf = case pm of+	    HookTorque dir -> TorqueHF dir+	    HookPush v -> PushHF v+	    _ -> NullHF+    in adjustPieces (\p -> case p of+		Hook arm _ -> Hook arm hf+		_ -> p) st++physicsTick :: PlayerMove -> GameState -> Writer [Alert] GameState+physicsTick pm st =+    let tfs = toolForces st pm+	(efs, dominates) = envForces st+    in do+	st' <- resolveForces tfs Vector.empty (\_ _->False) $ setTools pm st+	resolveForces Vector.empty efs dominates $ setTools NullPM st'++type Source = Int+data SourcedForce = SForce Source Force Bool Bool+    deriving (Eq, Ord, Show)+resolveForces :: ForceChoices -> ForceChoices -> Dominance -> GameState -> Writer [Alert] GameState+resolveForces plForces eForces eDominates st =+    let pln = Vector.length plForces+	dominates i j = case map (< pln) [i,j] of+		[True,False] -> True+		[False,False] -> eDominates (i-pln) (j-pln)+		_ -> False+	initGrps = fmap (propagate st True) plForces Vector.+++		fmap (propagate st False) eForces +	blockInconsistent :: Int -> Int -> StateT (Vector (Writer Any [Force])) (Writer [Alert]) ()+	blockInconsistent i j = do+	    grps <- mapM gets [(!i),(!j)]+	    blocks <- lift $ checkInconsistent i j $ map (fst.runWriter) grps+	    modify $ Vector.imap (\k -> if k `elem` blocks then (tell (Any True) >>) else id)+	checkInconsistent :: Int -> Int -> [[Force]] -> Writer [Alert] [Int]+	checkInconsistent i j fss = +	    let st' = foldr applyForce st $ nub $ concat fss+		inconsistencies = [ [f,f']+		    | [f,f'] <- sequence fss+		    , if forceIdx f == forceIdx f'+			then f /= f'+			else not.null $ collisions st' (forceIdx f) (forceIdx f') ]+	    in do+		tell $ map AlertBlockingForce $ concat inconsistencies+		return $ if null inconsistencies then []+		    else if i==j then [i]+		    else if dominates i j then [j]+		    else if dominates j i then [i]+		    else [i,j]++	stopWrench idx = setPiece idx (Wrench zero)+	stopBlockedWrenches fs st' = foldr stopWrench st' [+	    idx | f <- fs, let idx = forceIdx f, isWrench.placedPiece $ getpp st' idx ]+    in do +	let unresisted = [ s | (s, (_, Any False)) <- enumVec $ fmap runWriter initGrps ]++	-- check for inconsistencies within, and between pairs of, forcegroups+	grps <- sequence [ blockInconsistent i j+			| [i,j] <- sequence [unresisted,unresisted]+			, i <= j ]+		    `execStateT` initGrps++	let [blocked, unblocked] = map (nub.concat.(map (fst.runWriter)).Vector.toList) $+		(\(x,y) -> [x,y]) $ Vector.partition (getAny.snd.runWriter) grps+	tell $ map AlertBlockedForce blocked+	return $ stopBlockedWrenches blocked $ foldr applyForce st unblocked+    +applyForce :: Force -> GameState -> GameState+applyForce f s =+    let idx = forceIdx f+	pp' = applyForceTo (getpp s idx) f+	pp'' = case (placedPiece pp',f) of+		   ( Wrench _ , Push _ dir ) -> pp' {placedPiece = Wrench dir}+		   _ -> pp'+	in +	s { placedPieces = (placedPieces s) // [(idx, pp'')] }++collisionsWithForce :: GameState -> Force -> PieceIdx -> [HexPos]+collisionsWithForce st (Push idx dir) idx' =+    intersect (map (dir<+>) $ footprintAtIgnoring st idx idx') (footprintAtIgnoring st idx' idx)+collisionsWithForce st force idx' =+    collisions (applyForce force st) (forceIdx force) idx'++applyForceTo :: PlacedPiece -> Force -> PlacedPiece+applyForceTo (PlacedPiece pos piece) (Push _ dir) =+    PlacedPiece (dir <+> pos) piece+applyForceTo (PlacedPiece pos (Pivot arms)) (Torque _ dir) =+    PlacedPiece pos (Pivot $ map (rotate dir) arms)+applyForceTo (PlacedPiece pos (Hook arm hf)) (Torque _ dir) =+    PlacedPiece pos (Hook (rotate dir arm) hf)+applyForceTo pp _ = pp++-- A force on a piece which resists it is immediately blocked+pieceResists :: GameState -> Force -> Bool +pieceResists st force =+    let idx = forceIdx force+	PlacedPiece _ piece = getpp st idx+        springs = springsEndAtIdx st idx+	fixed = case piece of+		     (Pivot _) -> isPush force+		     (Block _) -> null springs+		     (Wrench mom) -> case force of+			    Push _ v -> v /= mom+			    _ -> True+		     (Hook _ hf) -> case force of +			    Push _ v -> hf /= PushHF v+			    Torque _ dir -> hf /= TorqueHF dir+		     _ -> False+    in fixed++-- |transmittedForce: convert pushes into torques as appropriate+transmittedForce :: GameState -> Source -> HexPos -> HexDir -> Force+transmittedForce st idx cpos dir =+    let pp@(PlacedPiece _ piece) = getpp st idx+	rpos = cpos <-> placedPos pp+	armPush = case+		(dir `hexDot` ((rotate 1 rpos) <-> rpos)) `compare`+		(dir `hexDot` ((rotate (-1) rpos) <-> rpos)) of+	    GT -> Torque idx 1+	    LT -> Torque idx $ -1+	    EQ -> Push idx dir+    in case piece of+	    Pivot _ -> armPush+	    Hook _ (TorqueHF _) -> armPush+	    _ -> (Push idx dir)++-- |propagateForce: return forces a force causes via bumps and fully+-- compressed/extended springs+propagateForce :: GameState -> Bool -> Force -> [ForceChoice]+propagateForce st@(GameState _ conns) isPlSource force =+    bumps ++ springTransmissions+    where+	idx = forceIdx force+	bumps = [ ForceChoice $ map (transmittedForce st idx' cpos) dirs |+	    idx' <- ppidxs st+	    , idx' /= idx+	    , cpos <- collisionsWithForce st force idx'+	    , let dirs = case force of+		    Push _ dir -> [dir]+		    Torque _ dir -> [push,claw]+			where push = arm <-> rotate (-dir) arm+			      claw = rotate dir arm <-> arm+			      arm = cpos <-> placedPos (getpp st idx) ]+	springTransmissions =+	    case force of+		 Push _ dir -> [ ForceChoice [Push idx' dir] |+			c@(Connection (ridx,_) (eidx,_) (Spring sdir _)) <- conns+			, let root = idx == ridx+			, let end = idx == eidx+			, root || end+			, let idx' = if root then eidx else ridx+			, let pull = (root && dir == neg sdir) || (end && dir == sdir)+			, let push = (root && dir == sdir) || (end && dir == neg sdir)+			, (push && if isPlSource then springFullyCompressed st c else not $ springExtended st c) ||+			    (pull && if isPlSource then springFullyExtended st c else not $ springCompressed st c) ||+			    (not push && not pull) ]+		 _ -> []++-- |propagate: find forcegroup generated by a forcechoice, and note if the+-- group is blocked due to resistance. If there are multiple forces in a+-- forcechoice and the first results in a block due to resistance, try the+-- next instead.+propagate :: GameState -> Bool -> ForceChoice -> Writer Any [Force]+propagate st isPlSource fch = Set.toList `liftM` propagate' isPlSource Set.empty fch where+    propagate' isPlForce ps (ForceChoice (f:backups)) =+	if f `Set.member` ps then return ps+	else+	    let (ps', failed) = if pieceResists st f && (not isPlForce)+		    then (ps, Any True)+		    else runWriter $ foldrM+			    (flip $ propagate' False)+			    (f `Set.insert` ps)+			    $ propagateForce st isPlSource f+	    in if getAny failed+		then if null backups+		    then tell (Any True) >> return ps'+		    else propagate' isPlForce ps $ ForceChoice backups+		else return ps'+    propagate' _ _ (ForceChoice []) = error "null ForceChoice"
+ Protocol.hs view
@@ -0,0 +1,144 @@+-- 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 Protocol where++import Data.Binary+import Control.Monad++import BinaryInstances+import Metagame+import Lock++type ProtocolVersion = Int+protocolVersion = 1 :: ProtocolVersion++data ClientRequest = ClientRequest ProtocolVersion (Maybe Auth) Action+    deriving (Eq, Ord, Show, Read)++type VersionedUInfo = (Int, UserInfo)++data Action+    = Authenticate+    | Register+    | ResetPassword Password+    | GetServerInfo+    | GetLock LockSpec+    | GetRetired Codename+    | GetUserInfo Codename (Maybe Int)+    | GetHint NoteInfo+    | GetSolution NoteInfo+    | DeclareSolution Solution LockSpec ActiveLock LockIndex+    | SetLock Lock LockIndex Solution+    | GetRandomNames Int+    deriving (Eq, Ord, Show, Read)++data Auth = Auth {authUser :: Codename, authPasswd :: Password}+    deriving (Eq, Ord, Show, Read)+type Password = String++needsAuth :: Action -> Bool+needsAuth GetServerInfo = False+needsAuth (GetLock _) = False+needsAuth (GetUserInfo _ _) = False+needsAuth (GetRetired _) = False+needsAuth (GetRandomNames _) = False+needsAuth _ = True++data ServerResponse+    = ServerAck+    | ServerMessage String+    | ServerError String+    | ServedServerInfo ServerInfo+    | ServedLock Lock+    | ServedRetired [LockSpec]+    | ServedUserInfo VersionedUInfo+    | ServedUserInfoDeltas [UserInfoDelta]+    | ServedSolution Solution+    | ServedHint Hint+    | ServedRandomNames [Codename]+    | ServerCodenameFree+    | ServerFresh+    deriving (Eq, Ord, Show, Read)++data ServerInfo = ServerInfo {serverLockSize :: Int, serverInfoString::String}+    deriving (Eq, Ord, Show, Read)+defaultServerInfo = ServerInfo 8 ""++instance Binary ClientRequest where+    put (ClientRequest pv mauth act) = putPackedInt pv >> put mauth >> put act+    get = liftM3 ClientRequest getPackedInt get get++instance Binary Action where+    put Authenticate = put (0::Word8)+    put Register = put (1::Word8)+    put GetServerInfo = put (2::Word8)+    put (GetLock lspec) = put (3::Word8) >> put lspec+    put (GetUserInfo name version) = put (4::Word8) >> put name >> put version+    put (GetHint lspec) = put (5::Word8) >> put lspec+    put (GetSolution lspec) = put (6::Word8) >> put lspec+    put (DeclareSolution soln lspec alock idx) = put (7::Word8) >> put soln >> put lspec >> put alock >> put idx+    put (SetLock lock li soln) = put (8::Word8) >> put lock >> put li >> put soln+    put (GetRandomNames n) = put (9::Word8) >> put n+    put (ResetPassword pw) = put (10::Word8) >> put pw+    put (GetRetired name) = put (11::Word8) >> put name+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> return Authenticate+	    1 -> return Register+	    2 -> return GetServerInfo+	    3 -> liftM GetLock get+	    4 -> liftM2 GetUserInfo get get+	    5 -> liftM GetHint get+	    6 -> liftM GetSolution get+	    7 -> liftM4 DeclareSolution get get get get+	    8 -> liftM3 SetLock get get get+	    9 -> liftM GetRandomNames get+	    10 -> liftM ResetPassword get+	    11 -> liftM GetRetired get++instance Binary Auth where+    put (Auth name pw) = put name >> put pw+    get = liftM2 Auth get get++instance Binary ServerResponse where+    put ServerAck = put (0::Word8)+    put (ServerMessage mesg) = put (1::Word8) >> put mesg+    put (ServerError err) = put (2::Word8) >> put err+    put (ServedServerInfo sinfo) = put (3::Word8) >> put sinfo+    put (ServedLock lock) = put (4::Word8) >> put lock+    put (ServedUserInfo info) = put (5::Word8) >> put info+    put (ServedUserInfoDeltas info) = put (6::Word8) >> put info+    put (ServedSolution soln) = put (7::Word8) >> put soln+    put (ServedHint hint) = put (8::Word8) >> put hint+    put (ServedRandomNames names) = put (9::Word8) >> put names+    put (ServerCodenameFree) = put (10::Word8)+    put (ServerFresh) = put (11::Word8)+    put (ServedRetired lss) = put (12::Word8) >> put lss+    get = do+	tag <- get :: Get Word8+	case tag of+	    0 -> return ServerAck+	    1 -> liftM ServerMessage get+	    2 -> liftM ServerError get+	    3 -> liftM ServedServerInfo get+	    4 -> liftM ServedLock get+	    5 -> liftM ServedUserInfo get+	    6 -> liftM ServedUserInfoDeltas get+	    7 -> liftM ServedSolution get+	    8 -> liftM ServedHint get+	    9 -> liftM ServedRandomNames get+	    10 -> return ServerCodenameFree+	    11 -> return ServerFresh+	    12 -> liftM ServedRetired get+instance Binary ServerInfo where+    put (ServerInfo sz str) = put sz >> put str+    get = liftM2 ServerInfo get get
+ README view
@@ -0,0 +1,216 @@+Intricacy+=========+A game of competitive puzzle-design.++http://mbays.freeshell.org/intricacy/+++Compiling+=========+Dependencies:+    EITHER+	sdl+	sdl-ttf+	sdl-gfx+    OR+	curses++To compile the game on *nix with SDL graphics:+    Install ghc, cabal, and development packages for the SDL dependencies+    above, then run+	cabal update && cabal install+    which should result in various haskell packages being compiled and+    installed, probably in ~/.cabal/ . The game can then be run as+	~/.cabal/bin/intricacy +    Running cabal install as root should install it somewhere global.++To compile a curses-only (ascii graphics) build:+	cabal install -f -SDL++To compile the server:+	cabal install -f Server -f -Game++    The server will be installed in+	~/.cabal/bin/intricacy-server+    The server runs on port 27001 by default. It writes the game database to+    a directory 'intricacydb' under the directory from which it is run.++To compile for windows:+    This should work as above once you have the dependencies installed+    properly. Good luck with that. The mingw32-compiled libraries in winlibs+    may or may not help.++To compile for OSX, or android or whatever else wacky system:+    No idea, sorry. But please tell me if you manage!+++Playing+=======+Press 'T' on the starting screen to play the tutorials, which should lead you+to discover the main game mechanics. When you've finished or had enough of the+tutorials, select a codename with 'C' and register it with 'R'. The rest you+can hopefully figure out, but see below if you'd rather read about it.+++Configuration+=============+You can change keybindings in SDL mode by right-clicking on the corresponding+button and pressing a key.++The buttons in the top right when solving/editing locks in SDL mode are as+follows:+    * The three hexes toggles between two modes for colouring pieces; in one+	mode (three yellow hexes), the colours are determined by the nature of+	the pieces; in the other mode, adjacent pieces always get different+	colours.+    * The lone hex with optional arrow toggles "blockage annotations". These+	are there to help you figure out what's going on when you can't+	understand why a piece refuses to move. An orange arrow indicates a+	blocked force, and a purple arrow a force which blocked another force.++Config files are saved in ~/.intricacy/ on unixoids, or something like+"...\Application Data\intricacy\" on windows. In particular, the locks you+create in the lock editor are saved in there (and you can organise them into+directories by including (back)slashs in the lock name). You can edit them in+a text editor if you want - see AsciiLock.hs for what the characters mean.+++Rough description of the game mechanics+=======================================+* Locks consist of blocks, pivots and balls. Blocks can be connected to other+    blocks by springs. Pivots have arms. When picking a lock, you control two+    tools - a hook, which acts as a mobile one-armed pivot, and a wrench,+    which acts as a mobile block with momentum.+* To open a lock, the "bolthole" (the area in the top-right) must be empty.+* Each turn, the tools push and rotate according to the player's commands, and+    then each spring which is compressed or extended beyond its natural length+    pushes/pulls on the block at its end.+* If two forces try to move a piece in two different directions, or try to+    move two pieces into the same hex, one or both is blocked.+* If a pivot/hook is trying to turn and there's a piece in the way of one of+    its arms, it will at first try to push the piece away - but if that force+    is blocked, it will try instead to pull the piece round with the arm as it+    turns.+* If two springs are trying to push two blocks into the same hex, they will+    generally both be blocked. However, if one of the forces is also pushing+    against a fixed piece such as a tool, it won't block the other force.+++Full details of the metagame mechanics+======================================+(Where by the 'game' I mean the lock-picking bit, and by the 'metagame' I mean+the bit with the 3-letter codenames and the three lock slots and notes and so+on.)++Scoring is always relative - each player has a score relative to each other+player. That score is the number of the second player's lock slots to which+the first player has access, minus the number of the first player's lock slots+to which the second player has access.++A player accesses a lock slot when one of the following holds+    * the player has solved the lock in the slot, and declared the solution;+    * the player has read three notes on the lock in the slot;+    * there's no lock in the slot, and the player has accessed all the slots+	which do have locks in them.++A player reads every note in every lock the player accesses. When a lock is+replaced ('retired'), each note secured by the lock becomes 'public', and is+read by every player.++Note this means that once three notes on a lock become public, every player+accesses the lock. The lock is then 'public' (and its owner should replace+it!).++To declare a solution, you must secure a note on it behind a non-public lock+in one of your three lock slots. Once the note is placed, it can't be moved.+++Full details of the game mechanics+==================================+Springs are directed; one of the blocks it is connected to is the 'root', the+other the 'end'. A block is stationary if it is not the end of any spring. The+directed graph whose nodes are the blocks and whose edges are the springs is+required to be acyclic. A spring may also be rooted in a pivot.++I will now attempt to describe in full excrutiating detail the game physics,+i.e. the algorithm used to determine what happens on a turn. You shouldn't+need to read this to play the game! Experimenting and turning on blockage+annotations should be enough.++The following description corresponds to the code in Physics.hs. The algorithm+is the result of an extended process of experiment and iterated+simplification; see notes/game in the source distribution if you're perverse+enough to want to read a scattered stream-of-consciousness account of the+process.++Each turn is separated into two phases. In the first phase, the forces arising+from the player's move are 'resolved', possibly resulting in some movement. In+the second phase, forces arising from stretched or compressed springs are+resolved, possibly resulting in some movement.++Here we abuse physics terminology, and use the term 'force' to refer to either+a directional force in the usual sense, which we call a 'push', or a+rotational force, which we call a 'torque'. A force is always on a piece, in+some direction. Only the obvious six hex directions and the two obvious+rotational directions occur; the magnitude is always 1. ++Player moves result in forces on the tools in the obvious way. A wrench which+is moving gets a push in that direction each turn (sorry, Newton!). A spring+which is not at its relaxed length results in a push on the end piece.++To _resolve_ these initial forces:+    * each initial force is 'propagated to a force group'+    * if a group is 'inconsistent' with another group: if one of the group is+	'dominated' by the other, it is 'blocked'; else both are blocked+    * each force in each unblocked force group is 'applied'++To _apply_ a push: move the piece in the given direction.+To _apply_ a torque: rotate the piece in the given direction.++To _propagate_ a force:+    * If applying the force would result in an overlap with another piece,+	push that piece - but if it's an arm, twist the pivot instead when+	that makes sense.+    * If the force is a torque and an arm is pushing on another piece, we have+	a special rule: if the obvious push ends up propagating to a resisted+	force (see below), then it is replaced with a 'clawing' push. e.g. in+	the following situation:+	    \ O #+	     o+	if the pivot is twisted clockwise, the ball will first be pushed east,+	but when that force propagates to a push on the stationary block to+	its east which is resisted, processing will back up and a push on the+	ball southeast will be tried instead.+    * A spring connecting two blocks transmits a push on one block to the+	other unless the direction is such that the push is tending to+	compress/extend the spring and the spring isn't already fully+	compressed/extended.++A force is _resisted_ if it is a push on a pivot or on a block which isn't the+    end of a spring, or it's a torque on a block, or it's a force on a hook+    which isn't already getting that force this phase as the result of a+    player move, or it's a force on a wrench which isn't a push in the+    direction it's already moving.++To _propagate an initial force to a force group_:+    * Propagate the force as above, then recursively propagate the resulting+	forces, checking for resistance as we go. The force group consists of+	all the resulting propagated forces.+    * On resistance: back up to try clawing as described above if appropriate,+	else consider the whole force group resisted - so the resulting force+	group is empty.++Two forces are _inconsistent_ when+    * they act on the same piece in different directions, or+    * applying both at once results in overlapping pieces.++Two force groups are _inconsistent_ iff there is some force from the first+    which is inconsistent with some force from the second.++A force group _dominates_ another iff their initial forces are spring forces,+    and the root of the first spring is an ancestor of the root of the second+    spring, where an ancestor of a block B is recursively defined to be a block+    which is the root of a spring which ends at B, or an ancestor of such a+    block.++-- mbays@sdf.org 2013
+ SDLRender.hs view
@@ -0,0 +1,462 @@+-- 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 SDLRender where++import Graphics.UI.SDL+import Graphics.UI.SDL.Primitives+import qualified Graphics.UI.SDL.TTF as TTF+import Data.Monoid+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import qualified Data.Map as Map+import Data.List (maximumBy)+import Data.Function (on)++import Hex+import GameState+import GameStateTypes+import BoardColouring+import Physics+import Command++-- aaPolygon seems to be a bit buggy in sdl-gfx-0.6.0+aaPolygon' surf verts col =+    aaLines surf (verts ++ take 1 verts) col+-- aaCircle too+aaCircle' surf x y rad col =+    if (rad == 1) then pixel surf x y col+    else aaCircle surf x y rad col++aaLines surf verts col =+    sequence_ [ aaLine surf x y x' y' col |+	((x,y),(x',y')) <- zip (take (length verts - 1) verts) (drop 1 verts) ]++rimmedPolygon surf verts fillCol rimCol = do+    filledPolygon surf verts fillCol+    aaPolygon' surf verts $ opaquify rimCol+    return ()++rimmedCircle surf centre@(SVec x y) rad fillCol rimCol = do+    filledCircle surf (fromIntegral x) (fromIntegral y) (fromIntegral rad) fillCol+    aaCircle' surf (fromIntegral x) (fromIntegral y) (fromIntegral rad) $ opaquify rimCol+    return ()++type Glyph = SVec -> Int -> Surface -> IO ()++ysize :: Int -> Int+ysize size = round $ fromIntegral size / sqrt 3++corner :: Integral i => SVec -> Int -> Int -> (i,i)+corner (SVec x y) size hextant = (fromIntegral $ x+dx, fromIntegral $ y+dy)+    where+	[dx,dy] = f hextant+	f 0 = [size, -ysize size]+	f 1 = [0, -2*ysize size]+	f 2 = [-size, -ysize size]+	f n | n < 6 = let [x,y] = f (5-n) in [x,-y]+	    | n < 0 = f (6-n)+	    | otherwise = f (n`mod`6)++innerCorner :: Integral i => SVec -> Int -> HexDir -> (i,i)+innerCorner (SVec x y) size dir = (fromIntegral $ x+dx, fromIntegral $ y+dy)+    where+	[dx,dy] = f dir+	f dir+	    | dir == hu = [2*isize, 0]+	    | dir == hv = [-isize, -ysize size]+	    | dir == hw = [-isize, ysize size]+	    | not (isHexDir dir) = error "innerCorner: not a hexdir"+	    | otherwise = map (\z -> -z) $ f $ neg dir+	isize = size `div` 3++edge :: Integral i => SVec -> Int -> HexDir -> (i,i)+edge (SVec x y) size dir = (fromIntegral $ x+dx, fromIntegral $ y+dy)+    where+	[dx,dy] = f dir+	f dir+	    | dir == hu = [size, 0]+	    | dir == hv = [-size`div`2, -3*ysize size`div`2]+	    | dir == hw = [-size`div`2, 3*ysize size`div`2]+	    | not (isHexDir dir) = error "edge: not a hexdir"+	    | otherwise = map (\z -> -z) $ f $ neg dir++tileGlyph :: Tile -> Pixel -> Glyph++tileGlyph (BlockTile adjs) col centre size surf =+    rimmedPolygon surf corners col $ bright col+	where +	    corners = concat [+		if or $ map adjAt [0,1]+		then [corner centre size $ hextant dir]+		else if adjAt $ -1+		    then []+		    else [innerCorner centre size dir]+		| dir <- hexDirs+		, let adjAt r = rotate r dir `elem` adjs+		]++tileGlyph (SpringTile extn dir) col centre size surf =+    aaLines surf points $ bright col+	where+	    n = 3*case extn of+		Stretched -> 1+		Relaxed -> 2+		Compressed -> 3+	    dir' = if dir == zero then hu else dir+	    (sx,sy) = corner centre size (hextant dir' - 1)+	    (offx,offy) = corner centre size (hextant dir')+	    (ex,ey) = corner centre size (hextant dir' - 3)+	    points = [ (x+dx,y+dy)+		| i <- [0..n]+		, i`mod`3 /= 1+		, let (x,y) = if i`mod`3==0 then (sx,sy) else (offx,offy)+		, let (dx,dy) = ((i*(ex-sx))`div`n, (i*(ey-sy))`div`n) ]++tileGlyph (PivotTile dir) col centre size surf = do+    rimmedCircle surf centre rad col $ bright col+    when (dir /= zero)+	$ void $ aaLine surf `uncurry` from `uncurry` to $ bright col+    return ()+	where+	    rad = (7*size)`div`8+	    from = edge centre rad $ neg dir+	    to = edge centre rad dir++tileGlyph (ArmTile dir _) col centre size surf =+    void $ aaLine surf `uncurry` from `uncurry` to $ bright col+	where+	    dir' = if dir == zero then hu else dir+	    from = edge centre size $ neg dir'+	    to = innerCorner centre size dir'++tileGlyph HookTile col centre size surf =+    rimmedCircle surf centre rad col $ bright col+	where+	    rad = (7*size)`div`8++tileGlyph (WrenchTile mom) col centre size surf = do+    rimmedCircle surf centre (size`div`3) col $ bright col+    when (mom /= zero) $+	let +	    (fx,fy) = innerCorner centre size $ neg mom+	    (tx,ty) = edge centre size $ neg mom+	    shifts = map (map (`div` 2)) $+		[ [ x1-x0, y1-y0 ]+		| rot <- [-1,0,1]+		, let (x0,y0) = innerCorner centre size $ neg mom+		, let (x1,y1) = innerCorner centre size $ rotate rot $ neg mom+		]+	in sequence_+	    [ aaLine surf (fx+dx) (fy+dy) (tx+dx) (ty+dy) $ col+	    | [dx,dy] <- shifts ]++tileGlyph BallTile col centre size surf =+    rimmedCircle surf centre rad (faint col) (obscure col)+    where rad = (7*size)`div`8++blockedArm :: HexDir -> TorqueDir -> Pixel -> Glyph+blockedArm armdir tdir col centre size surf =+    void $ aaLine surf `uncurry` from `uncurry` to $ col+	where+	    from = innerCorner centre size $ rotate (2*tdir) armdir+	    to = edge centre size $ rotate tdir armdir++blockedBlock :: Tile -> HexDir -> Pixel -> Glyph+blockedBlock tile dir col centre size =+    tileGlyph tile col (shift <+> centre) size+	where+	    shift = SVec (x'-x) (y'-y)+	    (x,y) = innerCorner centre size dir+	    (x',y') = edge centre size dir++blockedPush :: HexDir -> Pixel -> Glyph+blockedPush dir col centre size surf = do+{-+    void $ rimmedPolygon surf verts (obscure col) (dim col)+	where verts =+		[ innerCorner centre size $ rotate 1 dir+		, innerCorner centre size $ rotate (-1) dir+		, innerCorner centre size dir ]+-}+    void $ aaLine surf `uncurry` base `uncurry` tip $ col+    --void $ aaLine surf `uncurry` from' `uncurry` to' $ col+    void $ aaLine surf `uncurry` tip `uncurry` (arms!!0) $ col+    void $ aaLine surf `uncurry` tip `uncurry` (arms!!1) $ col+    where+	--base@(bx,by) = innerCorner centre size dir+	SVec bx' by' = centre+	base@(bx,by) = (fromIntegral bx',fromIntegral by')+	tip@(tx,hy) = edge centre size dir+	arms = [(bx + (tx-bx)`div`2 + dir*(hy-by)`div`4,+	    by + (hy-by)`div`2 - dir*(tx-bx)`div`4) | dir <- [-1,1]]++	--from' = corner centre size $ hextant dir+	--to' = corner centre size $ (hextant dir) - 1+	+collisionMarker :: Glyph+collisionMarker centre size surf =+    rimmedCircle surf centre (size`div`3) (bright orange) $ bright orange++hollowGlyph :: Pixel -> Glyph+hollowGlyph col centre size surf =+    aaPolygon' surf corners $ opaquify col+    where corners = map (corner centre size) [0..5]+hollowInnerGlyph col centre size surf =+    aaPolygon' surf corners $ opaquify col+    where corners = [ innerCorner centre size dir | dir <- hexDirs ]++filledHexGlyph :: Pixel -> Glyph+filledHexGlyph col centre size surf =+    rimmedPolygon surf corners col $ brightish col+    where corners = map (corner centre size) [0..5]++buttonGlyph :: Pixel -> Glyph+buttonGlyph = tileGlyph (BlockTile [])++useFiveColourButton :: Bool -> Glyph+useFiveColourButton using centre size surf = do+    mapM_ (\h -> tileGlyph (BlockTile [])+	    (dim $ colourWheel (if using then h`div`2 else 1))+	    (SVec `uncurry` corner centre (size`div`2) h) (size`div`2) surf)+	[0,2,4]++showBlocksButton :: Bool -> Glyph+showBlocksButton showing centre size surf = do+    tileGlyph (BlockTile []) (dim red) centre size surf+    when showing $ blockedPush hu (bright orange) centre size surf++whsButtonsButton :: WrHoSel -> Glyph+whsButtonsButton whs centre size surf = do+    when (whs /= WHSHook) $+	tileGlyph (WrenchTile zero) col (miniCentre 0) miniSize surf+    when (whs /= WHSWrench) $ do+	tileGlyph HookTile col (miniCentre 4) miniSize surf+	tileGlyph (ArmTile hv False) col (miniCentre 2) miniSize surf+    where+	miniSize = size `div` 2+	miniCentre h = SVec `uncurry` corner centre miniSize h+	col = dim white++cursor :: Glyph+cursor = hollowGlyph $ bright white++unfreshGlyph centre@(SVec x y) size surf = do+    let col = bright red+    hollowInnerGlyph col centre size surf+    sequence_ [pixel surf (fromIntegral $ x+(i*size`div`4)) (fromIntegral y) col+	| i <- [-1..1] ]++playerGlyph col centre size surf = filledHexGlyph col centre size surf++setPixelAlpha alpha (Pixel v) = Pixel $ v `div` 0x100 * 0x100 + alpha+bright = setPixelAlpha 0xff+brightish = setPixelAlpha 0xc0+dim = setPixelAlpha 0xa0+obscure = setPixelAlpha 0x80+faint = setPixelAlpha 0x40+invisible = setPixelAlpha 0x00++pixelToRGBA (Pixel v) =+    let (r,v') = divMod v 0x1000000+	(g,v'') = divMod v' 0x10000+	(b,a) = divMod v'' 0x100+    in (r,g,b,a)+rgbaToPixel (r,g,b,a) = Pixel $ a+0x100*(b+0x100*(g+0x100*r))+opaquify p =+    let (r,g,b,a) = pixelToRGBA p+	[r',g',b'] = map (\v -> (v*a)`div`0xff) [r,g,b]+    in rgbaToPixel (r',g',b',0xff)++black = Pixel 0x01000000+white = Pixel 0xffffff00+orange = Pixel 0xff7f0000++colourWheel :: Int -> Pixel+colourWheel n = Pixel $ (((((r * 0x100) + g) * 0x100) + b) * 0x100) + a+    where [r,g,b] = map (\on -> if on then 0xff else 0) $ colourWheel' n+	  a = 0x00+	  colourWheel' 0 = [True, False, False]+	  colourWheel' 1 = [True, True, False]+	  colourWheel' n = let [a,b,c] = colourWheel' $ n-2 in [c,a,b]++red = colourWheel 0+yellow = colourWheel 1+green = colourWheel 2+cyan = colourWheel 3+blue = colourWheel 4+purple = colourWheel 5++colourOf colouring idx = +    case Map.lookup idx colouring of+	    Nothing -> white+	    Just n -> colourWheel n++ownedTileGlyph :: PieceColouring -> [PieceIdx] -> OwnedTile -> Glyph+ownedTileGlyph colouring highlight (owner,t) =+    let col = colourOf colouring owner+    in tileGlyph t $ (if owner `elem` highlight then bright else dim) col++data SVec = SVec { cx, cy :: Int }+    deriving (Eq, Ord, Show)+instance Monoid SVec where+    mempty = SVec 0 0+    mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y') +instance Grp SVec where+    neg (SVec x y) = SVec (-x) (-y)+type CCoord = PHS SVec++hexVec2SVec :: Int -> HexVec -> SVec+hexVec2SVec size (HexVec x y z) =+    SVec ((x-z) * size) (-y * 3 * ysize size)++sVec2dHV :: Int -> SVec -> (Double,Double,Double)+sVec2dHV size (SVec sx sy) =+    let sx',sy',size' :: Double+	[sx',sy',size',ysize'] = map fromIntegral [sx,sy,size,ysize size]+	y' = -sy' / ysize' / 3+	x' = ((sx' / size') - y') / 2+	z' = -((sx' / size') + y') / 2+    in (x',y',z')++sVec2HexVec :: Int -> SVec -> HexVec+sVec2HexVec size sv =+    let (x',y',z') = sVec2dHV size sv+	unrounded = Map.fromList [(1,x'),(2,y'),(3,z')]+	rounded = Map.map round unrounded+	maxdiff = fst $ maximumBy (compare `on` snd) $+	    [ (i, abs $ c'-c) | i <- [1..3],+		let c' = unrounded Map.! i, let c = fromIntegral $ rounded Map.! i]+	[x,y,z] = map snd $ Map.toList $+	    Map.adjust (\x -> x - (sum $ Map.elems rounded)) maxdiff rounded+    in HexVec x y z++data RenderContext = RenderContext+    { renderSurf :: Surface+    , renderBGSurf :: Maybe Surface+    , renderHCentre :: HexPos+    , renderSCentre :: SVec+    , renderSize :: Int+    , renderFont :: Maybe TTF.Font+    }+type RenderM = ReaderT RenderContext IO++displaceRender :: SVec -> RenderM a -> RenderM a+displaceRender disp = local displace+    where displace rc = rc { renderSCentre = renderSCentre rc <+> disp }++recentreAt :: HexVec -> RenderM a -> RenderM a+recentreAt v m = do+    size <- asks renderSize+    displaceRender (hexVec2SVec size v) m++rescaleRender :: RealFrac n => n -> RenderM a -> RenderM a+rescaleRender r = local resize+    where resize rc = rc { renderSize = round $ r * (fromIntegral $ renderSize rc) }++withFont :: Maybe TTF.Font -> RenderM a -> RenderM a+withFont font = local refont+    where refont rc = rc { renderFont = font }++erase :: RenderM ()+erase = fillRectBG Nothing++fillRectBG :: Maybe Rect -> RenderM ()+fillRectBG mrect = do+    surf <- asks renderSurf+    mbgsurf <- asks renderBGSurf+    void $ liftIO $ maybe+	(fillRect surf mrect black)+	(\bgsurf -> blitSurface bgsurf mrect surf mrect)+	mbgsurf++drawBasicBG :: Int -> RenderM ()+drawBasicBG maxR = sequence_ [ drawAtRel (hollowGlyph $ colAt v) v | v <- hexDisc maxR ]+    where+	colAt v@(HexVec hx hy hz) = let+		[r,g,b] = map (\h -> fromIntegral $ ((0xff*)$ abs h)`div`maxR) [hx,hy,hz]+		a = fromIntegral $ (0xb0 * (maxR - abs (hexLen v)))`div`maxR+	    in rgbaToPixel (r,g,b,a)++drawAt :: Glyph -> HexPos -> RenderM ()+drawAt gl pos = do+	centre <- asks renderHCentre+	drawAtRel gl (pos <-> centre)+drawAtRel gl v = do+	(surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize+	let cpos = scrCentre <+> (hexVec2SVec size v)+	liftIO $ gl cpos size surf++messageCol = white+accessedCol = green+dimWhiteCol = Pixel 0xa0a0a000+buttonTextCol = white+errorCol = red++pixelToColor p =+    let (r,g,b,_) = pixelToRGBA p+    in Color (fromIntegral r) (fromIntegral g) (fromIntegral b)++renderStrColAtLeft = renderStrColAt' False+renderStrColAt = renderStrColAt' True+renderStrColAt' :: Bool -> Pixel -> String -> HexVec -> RenderM ()+renderStrColAt' centred c str v = void $ runMaybeT $ do+    font <- MaybeT $ asks renderFont+    fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c+    (surf, scrCentre, size) <- lift $ asks $+	liftM3 (,,) renderSurf renderSCentre renderSize+    let SVec x y = scrCentre <+> (hexVec2SVec size v)+	    <+> neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) <+>+		if centred+		    then SVec ((surfaceGetWidth fsurf)`div`2) 0+		    else SVec 0 0)+    void $ liftIO $ blitSurface fsurf Nothing surf (Just $ Rect x y 0 0)++blankRow v = do+    (surf, scrCentre, size) <- asks $+	liftM3 (,,) renderSurf renderSCentre renderSize+    let SVec _ y = scrCentre <+> (hexVec2SVec size v)+	w = surfaceGetWidth surf+	h = ceiling $ fromIntegral size * 2 * sqrt 3+    fillRectBG $ Just $ Rect 0 (y-h`div`2) w h++drawCursorAt :: Maybe HexPos -> RenderM ()+drawCursorAt (Just pos) = drawAt cursor pos+drawCursorAt _ = return ()++drawBlocked :: GameState -> PieceColouring -> Bool -> Force -> RenderM ()+drawBlocked st colouring blocking (Torque idx dir) = do+    let (pos,arms) = case getpp st idx of+	    PlacedPiece pos (Pivot arms) -> (pos,arms)+	    PlacedPiece pos (Hook arm _) -> (pos,[arm])+	    _ -> (pos,[])+	col = if blocking then bright $ purple else dim $ colourOf colouring idx+    sequence_ [ drawAt (blockedArm arm dir col) (arm <+> pos) |+	arm <- arms ]+drawBlocked st colouring blocking (Push idx dir) = do+    let footprint = plPieceFootprint $ getpp st idx+	fullfootprint = fullFootprint st idx+	col = bright $ if blocking then purple else orange+    sequence_ [ drawAt (blockedPush dir col) pos+	| pos <- footprint+	, (dir<+>pos) `notElem` fullfootprint ]+    -- drawAt (blockedPush dir $ bright orange) $ placedPos $ getpp st idx++blitAt :: Surface -> HexVec -> RenderM ()+blitAt surface v = do+    (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize+    let SVec x y = scrCentre <+> (hexVec2SVec size v)+	w = surfaceGetWidth surface+	h = surfaceGetHeight surface+    void $ liftIO $ blitSurface surface Nothing surf $ Just $+	Rect (x-w`div`2) (y-h`div`2) (w+1) (h+1)
+ SDLUI.hs view
@@ -0,0 +1,520 @@+-- 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
+ SDLUIMInstance.hs view
@@ -0,0 +1,590 @@+-- 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/.++{-# LANGUAGE FlexibleInstances #-}+module SDLUIMInstance () 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.Concurrent (threadDelay)+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.Function (on)+import Data.Foldable (for_)+--import Debug.Trace (traceShow)++import MainState+import Hex+import Command+import GameStateTypes+import Lock+import KeyBindings+import Mundanities+import Metagame+import Protocol+import Cache+import Database+import ServerAddr+import Util+import InputMode+import SDLRender+import SDLUI++instance UIMonad (StateT UIState IO) where+    runUI m = evalStateT m nullUIState+    drawMainState = do+	lift $ clearButtons >> clearSelectables+	s <- get+	let mode = ms2im s+	lift $ waitFrame+	drawMainState' s+	lift . drawTitle =<< getTitle+	lift $ do+	    drawButtons mode+	    drawUIOptionButtons mode+	    drawMsgLine+	    refresh+	where+	drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel }) = do+	    canUndo <- null <$> gets psGameStateMoveStack+	    canRedo <- null <$> gets psUndoneStack+	    lift $ do+		let selTools = [ idx |+			(idx, PlacedPiece pos p) <- enumVec $ placedPieces st+			, or [wsel && isWrench p, not wsel && isHook p] ]+		drawMainGameState selTools False alerts st+		registerUndoButtons canUndo canRedo+	drawMainState' (ReplayState { rsCurrentState=st } ) = do+	    canUndo <- null <$> gets rsGameStateMoveStack+	    canRedo <- null <$> gets rsMoveStack+	    lift $ do+		drawMainGameState [] False [] st+		registerUndoButtons canUndo canRedo+		renderToMain $ drawCursorAt Nothing+	drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack,+		selectedPiece=selPiece, selectedPos=selPos }) = lift $ do+	    drawMainGameState (maybeToList selPiece) True [] st+	    renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing+	    registerUndoButtons (null sts) (null undostack)+	    when (isJust selPiece) $ mapM_ registerButtonGroup+		[ singleButton (periphery 2 <+> 3<*>hw<+>hu) CmdDelete 0+		-- , singleButton (periphery 2 <+> 3<*>hw) CmdMerge 4+		]+	    drawPaintButtons+	drawMainState' (MetaState saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path mlock offset) = do+	    let ourName = authUser <$> auth+	    let selName = listToMaybe names+	    let home = isJust ourName && ourName == selName+	    lift $ renderToMain $ (erase >> drawCursorAt Nothing)+	    lift $ maybe (drawEmptyMiniLock miniLockPos)+		(\lock -> do+		    drawMiniLock lock miniLockPos+		    registerSelectable miniLockPos 3 SelOurLock+		    registerButtonGroup $ singleButton (miniLockPos <+> 2<*>neg hv <+> hu) CmdPrevLock 4+		    registerButtonGroup $ singleButton (miniLockPos <+> 2<*>neg hv <+> hu <+> neg hw) CmdNextLock 4+		    )+		(fst<$>mlock)+	    lift $ do+		smallFont <- gets dispFontSmall+		renderToMain $ withFont smallFont $ renderStrColAtLeft messageCol+			(saddrStr saddr ++ if cOnly then " (cache only)" else "")+		    $ serverPos <+> hu+		renderToMain $ renderStrColAtLeft messageCol path $ lockLinePos <+> hu+		when (offset>0) $+		    registerButtonGroup $ singleButton (nextPagePos<+>neg hu) CmdPrevPage 4++	    when (length names > 1) $ lift $ registerButtonGroup $ singleButton+		(codenamePos <+> 2<*>neg hu <+> hw) CmdBackCodename 0++	    runMaybeT $ do+		name <- MaybeT (return selName)+		FetchedRecord fresh err muirc <- lift $ getUInfoFetched 300 name+		lift $ do+		    lift $ do+			unless fresh $ do+			    smallFont <- gets dispFontSmall+			    renderToMain $ withFont smallFont $ renderStrColAtLeft (opaquify $ dim errorCol) "(stale)" $ serverWaitPos+			maybe (return ()) (setMsgLineNoRefresh errorCol) err+			when (fresh && (isNothing ourName || home)) $+			    registerButtonGroup $ singleButton (codenamePos <+> 2<*>hu)+				(if isNothing muirc || home then CmdRegister else CmdAuth) 2+		    (if isJust muirc then drawName else drawNullName) name codenamePos+		    lift $ registerSelectable codenamePos 0 SelSelectedCodeName+		    drawRelScore name (codenamePos<+>hu)+		    for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of +			    Just retired -> do+				fillArea locksPos+				    (map (locksPos<+>) $ zero:[rotate n $ 4<*>hu<->4<*>hw | n <- [0,2,3,5]])+				    [ \pos -> (lift $ registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos+				    | ls <- retired ]+				lift $ registerButtonGroup $ singleButton retiredPos CmdShowRetired pubWheelAngle+				lift $ registerButtonGroup $ singleButton (retiredPos <+> hw) (CmdPlayLockSpec Nothing) 4+			    Nothing -> do+				sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo |+				    (i,mlockinfo) <- assocs $ userLocks uinfo ]+				let mmiscpos = (serverPos <+> 2<*>neg hv)+				when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do+				    registerButtonGroup+					([ Button mmiscpos (CmdSolve Nothing), Button (mmiscpos<+>hu) (CmdViewSolution Nothing)], (2,2))+				let tested = maybe False (isJust.snd) mlock+				when (isJust mlock && home) $ lift $ registerButtonGroup $+					singleButton (miniLockPos <+> 2<*>hv <+> neg hu) (CmdPlaceLock Nothing) $ if tested then 2 else 0+				lift $ registerButtonGroup $ singleButton retiredPos CmdShowRetired pubWheelAngle++	    when home $ do+		unless (null undecls) $ do+		    lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos<+>2<*>hv)+		    lift $ registerButtonGroup $ singleButton (undeclsPos<+>2<*>hv<+>neg hu) (CmdDeclare Nothing) 2+		    fillArea (undeclsPos<+>hv)+			(map (undeclsPos<+>) $ hexDisc 1 ++ [hu<+>neg hw, neg hu<+>hv])+			[ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos+			| undecl@(Undeclared _ _ al) <- undecls ]+		rnames <- liftIO $ atomically $ readTVar rnamestvar+		unless (null rnames) $+		    fillArea randomNamesPos+			(map (randomNamesPos<+>) $ hexDisc 2)+			[ \pos -> (lift $ registerSelectable pos 0 (SelRandom name)) >> drawName name pos+			| name <- rnames ]++	    when (ourName /= selName) $ void $ runMaybeT $ do+		when (isJust ourName) $+		    lift.lift $ registerButtonGroup $ singleButton (codenamePos <+> neg hu <+> hw) CmdHome 4+		sel <- MaybeT $ return selName+		us <- MaybeT $ return ourName+		ourUInfo <- mgetUInfo us+		selUInfo <- mgetUInfo sel+		let accesses = map (uncurry getAccessInfo) [(ourUInfo,sel),(selUInfo,us)]+		lift $ do +		    fillArea (codenamePos<+>3<*>hv<+>hw) (map ((codenamePos<+>3<*>hv)<+>) [zero,hw,neg hv])+			[ \pos -> (lift $ registerSelectable pos 0 SelOurAL) >>+			    drawNameWithCharAndCol us white (lockIndexChar i) col pos+			| i <- [0..2]+			, let (pub,access) = accesses !! 0 !! i+			, let col+				| pub = obscure pubColour +				| access = obscure $ scoreColour $ -3 +				| otherwise = dim $ scoreColour 3 ]+		    fillArea (codenamePos<+>2<*>neg hw) (map ((codenamePos<+>3<*>neg hw)<+>) [zero,hw,neg hv])+			[ \pos -> (lift $ registerSelectable pos 0 (SelLock $ ActiveLock sel i)) >>+			    drawNameWithCharAndCol sel white (lockIndexChar i) col pos+			| i <- [0..2]+			, let (pub,access) = accesses !! 1 !! i+			, let col+				| pub = obscure pubColour +				| access = obscure $ scoreColour $ 3 +				| otherwise = dim $ scoreColour $ -3 ]+	drawMainState' _ = return ()++    drawMessage = say+    drawError = sayError++    drawAlerts alerts = return ()++    showHelp _ = return ()++    getChRaw = do+	events <- liftIO getEvents+	case listToMaybe $ [ key | KeyDown key <- events ] of+	    Nothing -> getChRaw+	    Just (Keysym _ _ ch) -> return $ Just ch++    setUIBinding mode cmd ch =+	modify $ \s -> s { uiKeyBindings =+		Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdgs ++ [bdg])+		    mode [(ch,cmd)] $ uiKeyBindings s }++    initUI = liftM isJust (runMaybeT $ do+	catchIOErrorMT $ SDL.init [InitVideo]+	catchIOErrorMT TTF.init+	lift $ do+	    readUIConfigFile+	    initVideo 0 0+	    liftIO $ setCaption "intricacy" "intricacy"+	    w <- gets scrWidth+	    h <- gets scrHeight+	    liftIO $ warpMouse (fromIntegral $ w`div`2) (fromIntegral $ h`div`2)+	    renderToMain $ erase+	    liftIO $ enableUnicode True+	    liftIO $ enableKeyRepeat 250 30+	    readBindings+	)+	where+	    catchIOErrorMT m = MaybeT $ liftIO $ catchIO (m >> return (Just ())) (\_ -> return Nothing)++    endUI = do+	writeUIConfigFile+	writeBindings+	liftIO $ quit++    unblockInput = return $ pushEvent VideoExpose+    suspend = return ()+    redraw = return ()++    getDrawImpatience = do+	curState <- get+	let pos = serverWaitPos+	return $ \ticks -> void $ flip runStateT curState $ do +	    when (ticks>2) $ renderToMain $ do+		mapM (drawAtRel (filledHexGlyph $ bright black)) [ pos <+> i<*>hu | i <- [0..3] ]+		withFont (dispFontSmall curState) $+		    renderStrColAtLeft errorCol ("waiting..."++replicate (ticks`mod`3) '.') $ pos+	    refresh++    warpPointer pos = do+	(scrCentre, size) <- getGeom+	centre <- gets dispCentre+	let SVec x y = hexVec2SVec size (pos<->centre) <+> scrCentre+	liftIO $ warpMouse (fromIntegral x) (fromIntegral y)+	lbp <- gets leftButtonDown+	rbp <- gets rightButtonDown+	let [lbp',rbp'] = fmap (fmap (\_ -> (pos<->centre))) [lbp,rbp]+	modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'}++    getInput mode = do+	events <- liftIO $ getEvents+	oldUIState <- get+	cmds <- concat <$> mapM processEvent events+	newUIState <- get+	return $ cmds ++ if uistatesMayVisiblyDiffer oldUIState newUIState then [CmdRefresh] else []+	where+	    uistatesMayVisiblyDiffer uis1 uis2 =+		uis1 { mousePos = (zero,False), lastFrameTicks=0 }+		/= uis2 {mousePos = (zero,False), lastFrameTicks=0 }+	    processEvent (KeyDown (Keysym _ _ ch)) = case mode of+		IMTextInput -> return [CmdInputChar ch]+		_ -> do+		    setting <- gets settingBinding+		    if isJust setting && ch /= '\0'+		    then do+			modify $ \s -> s {settingBinding = Nothing}+			when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch+			return []+		    else do+			uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+			let mCmd = lookup ch $ uibdgs ++ bindings mode+			sequence_+			    [ modify $ \s -> s { paintTileIndex = pti }+				| (pti,pt) <- zip [0..] paintTiles+				, (isNothing pt && mCmd == Just CmdWait) ||+				    (isJust $ do+					pt' <- pt+					CmdTile t <- mCmd+					guard $ ((==)`on`tileType) t pt') ]+			return $ maybeToList mCmd+	    processEvent (MouseMotion {}) = do+		(oldMPos,_) <- gets mousePos+		(pos@(mPos,_),(sx,sy,sz)) <- getMousePos+		updateMousePos mode pos+		lbp <- gets leftButtonDown+		rbp <- gets rightButtonDown+		centre <- gets dispCentre+		let drag :: Maybe HexVec -> Maybe Command+		    drag bp = do+			fromPos@(HexVec x y z) <- bp+			-- check we've dragged at least a full hex's distance:+			guard $ not.all (\(a,b) -> abs ((fromIntegral a) - b) < 1.0) $ [(x,sx),(y,sy),(z,sz)]+			let dir = hexVec2HexDirOrZero $ mPos <-> fromPos+			guard $ dir /= zero+			return $ CmdDrag (fromPos<+>centre) dir+		case mode of+		    IMEdit -> case drag rbp of+			Just cmd -> return [cmd]+			Nothing -> if mPos /= oldMPos+			    then do+				pti <- getEffPaintTileIndex+				return $ [ CmdMoveTo $ mPos <+> centre ] +++				    (if isJust lbp then [ CmdPaintFromTo (paintTiles!!pti) (oldMPos<+>centre) (mPos<+>centre) ] else [])+			    else return []+		    IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp]+		    _ -> return []+		where+		    mouseFromTo from to = do+			let dir = hexVec2HexDirOrZero $ to <-> from+			if dir /= zero+			    then (CmdDir WHSSelected dir:) <$> mouseFromTo (from <+> dir) to+			    else return []+	    processEvent (MouseButtonDown _ _ ButtonLeft) = do+		pos@(mPos,central) <- gets mousePos+		modify $ \s -> s { leftButtonDown = Just mPos }+		rb <- isJust <$> gets rightButtonDown+		mcmd <- cmdAtMousePos pos mode (Just False)+		let hotspotAction = listToMaybe+			$ map (\cmd -> return [cmd]) (maybeToList mcmd)+			++ [ (modify $ \s -> s {paintTileIndex = i}) >> return []+			    | i <- take (length paintTiles) [0..]+			    , mPos == paintButtonStart <+> i<*>hv ]+			++ [ toggleUIOption uiOB1 >> updateHoverStr >> return []+			    | mPos == uiOptPos uiOB1 ]+			++ [ toggleUIOption uiOB2 >> updateHoverStr >> return []+			    | mPos == uiOptPos uiOB2 ]+			++ [ toggleUIOption uiOB3 >> updateHoverStr >> return []+			    | mPos == uiOptPos uiOB3 ]++		if rb+		then return [ CmdWait ]+		else flip fromMaybe hotspotAction $ case mode of+		    IMEdit -> do+			pti <- getEffPaintTileIndex+			return $ [ drawCmd (paintTiles!!pti) False ]+		    IMPlay -> do+			centre <- gets dispCentre+			return $ [ CmdManipulateToolAt $ mPos <+> centre ]+		    _ -> return []+	    processEvent (MouseButtonUp _ _ ButtonLeft) = do+		modify $ \s -> s { leftButtonDown = Nothing }+		return []+	    processEvent (MouseButtonDown _ _ ButtonRight) = do+		pos@(mPos,_) <- gets mousePos+		modify $ \s -> s { rightButtonDown = Just mPos }+		(fromMaybe [] <$>) $ runMaybeT $ msum+		    [ do+			cmd <- MaybeT $ cmdAtMousePos pos mode Nothing+			modify $ \s -> s { settingBinding = Just cmd }+			return []+		    , do+			cmd <- MaybeT $ cmdAtMousePos pos mode (Just True)+			return [cmd]+		    , case mode of+			IMPlay -> do+			    centre <- gets dispCentre+			    return $ [ CmdManipulateToolAt $ mPos <+> centre ]+			_ -> return [ CmdSelect ] ]+	    processEvent (MouseButtonUp _ _ ButtonRight) = do+		modify $ \s -> s { rightButtonDown = Nothing }+		return [ CmdUnselect ]+	    processEvent (MouseButtonDown _ _ ButtonWheelUp) = doWheel 1+	    processEvent (MouseButtonDown _ _ ButtonWheelDown) = doWheel $ -1+	    processEvent (MouseButtonDown _ _ ButtonMiddle) = do+		(mPos,_) <- gets mousePos+		modify $ \s -> s { middleButtonDown = Just mPos }+		rb <- isJust <$> gets rightButtonDown+		return $ if rb then [ CmdDelete ] else []+	    processEvent (MouseButtonUp _ _ ButtonMiddle) = do+		modify $ \s -> s { middleButtonDown = Nothing }+		return []+	    processEvent (VideoResize w h) = do+		initVideo w h+		return [ CmdRedraw ]+	    processEvent VideoExpose = return [ CmdRedraw ]+	    processEvent Quit = return [ CmdForceQuit ]+		+	    processEvent _ = return []++	    doWheel dw = do+		rb <- isJust <$> gets rightButtonDown+		mb <- isJust <$> gets middleButtonDown+		if rb || mode == IMPlay && not mb+		    then return [ CmdRotate dw ]+		    else if mb +			then return [ if dw == 1 then CmdUndo else CmdRedo ]+			else do+			modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) }+			return []+		++	    drawCmd mt True = CmdPaint mt+	    drawCmd (Just t) False = CmdTile t+	    drawCmd Nothing _ = CmdWait++	    getMousePos :: UIM ((HexVec,Bool),(Double,Double,Double))+	    getMousePos = do+		(scrCentre, size) <- getGeom+		(x,y,_) <- lift getMouseState+		let sv = (SVec (fromIntegral x) (fromIntegral y)) <+> neg scrCentre+		let mPos@(HexVec x y z) = sVec2HexVec size sv+		let (sx,sy,sz) = sVec2dHV size sv+		let isCentral = all (\(a,b) -> abs ((fromIntegral a) - b) < 0.5) $+			[(x,sx),(y,sy),(z,sz)]+		return ((mPos,isCentral),(sx,sy,sz))+	    updateMousePos mode newPos = do+		oldPos <- gets mousePos+		when (newPos /= oldPos) $ do+		    modify $ \ds -> ds { mousePos = newPos }+		    updateHoverStr ++	    updateHoverStr = do+		p@(mPos,isCentral) <- gets mousePos+		hstr <- runMaybeT $ msum+		    [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys+		    , guard (mPos == uiOptPos uiOB1) >> describeUIOptionButton uiOB1+		    , guard (mPos == uiOptPos uiOB2) >> describeUIOptionButton uiOB2+		    , guard (mPos == uiOptPos uiOB3) >> describeUIOptionButton uiOB3 ]+		modify $ \ds -> ds { hoverStr = hstr }+	    describeCommandAndKeys :: Command -> UIM String+	    describeCommandAndKeys cmd = do+		uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings+		return $ describeCommand cmd ++ " ["+		    ++ concat (intersperse ","+			(map showKey $ findBindings (uibdgs ++ bindings mode) cmd))+		    ++ "]"++getEvents = do+    e <- waitEvent+    es <- pollEvents+    return $ e:es++pollEvents = do+    e <- pollEvent+    case e of+	NoEvent -> return []+	_ -> do+	    es <- pollEvents+	    return $ e:es+++fillArea :: HexVec -> [HexVec] -> [HexVec -> StateT MainState UIM ()] -> StateT MainState UIM () +fillArea centre area draws = do+    selDraws <- do+	    offset <- gets listOffset+	    let na = length area+		nd = length draws+	    when (nd > (na*(offset+1))) $ lift $+		registerButtonGroup $ singleButton nextPagePos CmdNextPage 4+	    return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws+    sequence_ $ map (uncurry ($)) $+	zip selDraws $ sortBy+		(compare `on` (hexLen . (<->centre)))+		area++drawOldLock ls pos = void.runMaybeT $ msum [ do+	lock <- mgetLock ls+	lift.lift $ drawMiniLock lock pos+    , lift.lift.renderToMain $+	    renderStrColAt messageCol (show ls) pos+    ]+    ++drawName name pos = nameCol name >>= drawNameCol name pos+drawNullName name pos = drawNameCol name pos $ invisible white+drawNameCol name pos col = do+    lift.renderToMain $ do +	drawAtRel (playerGlyph col) pos+	renderStrColAt messageCol name pos+drawRelScore name pos = do+    col <- nameCol name+    relScore <- getRelScore name+    flip (maybe (return ())) relScore $ \score ->+	lift.renderToMain $ renderStrColAt col+	    ((if score > 0 then "+" else "") ++ show score) pos++drawNote note pos = case noteBehind note of+    Just al -> drawActiveLock al pos+    Nothing -> drawPublicNote (noteAuthor note) pos+drawActiveLock (ActiveLock name i) =+    drawNameWithChar name white (lockIndexChar i)+drawPublicNote name =+    drawNameWithChar name pubColour 'P'+drawNameWithChar name charcol char pos = do+    col <- nameCol name+    drawNameWithCharAndCol name charcol char col pos+drawNameWithCharAndCol name charcol char col pos = do+    size <- fromIntegral.snd <$> lift getGeom+    let up = SVec 0 $ - (ysize size - size`div`2)+    let down = SVec 0 $ ysize size+    smallFont <- lift $ gets dispFontSmall+    lift.renderToMain $ do+	drawAtRel (playerGlyph col) pos+	displaceRender up $ +	    renderStrColAt messageCol name pos+	displaceRender down $ withFont smallFont $+	    renderStrColAt charcol [char] pos+pubWheelAngle = 5+pubColour = colourWheel pubWheelAngle -- ==purple+nameCol name = do+    ourName <- (authUser <$>) <$> gets curAuth+    relScore <- getRelScore name+    return $ dim $ case relScore of+	    Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000+	    Just score -> scoreColour score+scoreColour :: Int -> Pixel+scoreColour score = Pixel $ case score of+	0 -> 0x80800000+	1 -> 0x70a00000 +	2 -> 0x40c00000+	3 -> 0x00ff0000+	(-1) -> 0xa0700000 +	(-2) -> 0xc0400000+	(-3) -> 0xff000000++drawLockInfo :: ActiveLock -> Maybe LockInfo -> StateT MainState UIM ()+drawLockInfo al@(ActiveLock name i) Nothing = do+    let centre = hw<+>neg hv <+> 7*(i-1)<*>hu+    lift $ drawEmptyMiniLock centre+    drawNameWithCharAndCol name white (lockIndexChar i) (invisible white) centre+    lift $ registerSelectable centre 3 $ SelLockUnset al+drawLockInfo al@(ActiveLock name i) (Just lockinfo) = do+    let centre = locksPos <+> 7*(i-1)<*>hu+    let accessedByPos = centre <+> 3<*>(hv <+> neg hw)+    let accessedPos = centre <+> 2<*>(hw <+> neg hv)+    let notesPos = centre <+> 3<*>(hw <+> neg hv)+    ourName <- (authUser <$>) <$> gets curAuth+    runMaybeT $ msum [+	do+	    lock <- mgetLock $ lockSpec lockinfo+	    lift.lift $ do+		drawMiniLock lock centre+		registerSelectable centre 3 $ SelLock al+	, lift $ do+		drawActiveLock al centre+		lift $ registerSelectable centre 3 $ SelLock al+	]++    lift.renderToMain $ renderStrColAt dimWhiteCol "Accessed by:" $ accessedByPos <+> hv+    if public lockinfo+    then lift.renderToMain $ renderStrColAt pubColour "Everyone!" accessedByPos+    else if null $ accessedBy lockinfo+	then lift.renderToMain $ renderStrColAt messageCol "No-one" accessedByPos+	else fillArea accessedByPos+		[ accessedByPos <+> d | j <- [0..2], i <- [-2..3]+		    , i-j > -4, i-j < 3+		    , let d = j<*>hw <+> i<*>hu ]+		$ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos+		    | note <- lockSolutions lockinfo ] +++		[ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos+		    | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]+    +    undecls <- gets undeclareds+    if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName+    then lift.renderToMain $ +	(if public lockinfo+	    then renderStrColAt pubColour "Accessed!"+	    else renderStrColAt green "Solved!")+	accessedPos+    else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls+    then lift.renderToMain $ renderStrColAt yellow "Undeclared" accessedPos+    else do+	read <- take 3 <$> getNotesReadOn lockinfo+	unless (ourName == Just name) $ do+	    lift.renderToMain $ renderStrColAt (if length read == 3 then accessedCol else dimWhiteCol)+		"Read:" $ accessedPos <+> (-3)<*>hu+	    fillArea (accessedPos<+>neg hu) [ accessedPos <+> i<*>hu | i <- [-1..1] ]+		$ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawName (noteAuthor note) pos+		    | note <- read ] ++ (repeat $ lift . renderToMain . drawAtRel (hollowGlyph $ dim green))++    lift.renderToMain $ renderStrColAt dimWhiteCol "Holds notes:" $ notesPos <+> hv+    if null $ notesSecured lockinfo+	then lift.renderToMain $ renderStrColAt messageCol "None" notesPos+	else fillArea notesPos+		[ notesPos <+> d | j <- [0..2], i <- [-2..3]+		    , i-j > -4, i-j < 3+		    , let d = j<*>hw <+> i<*>hu ]+		[ \pos -> (lift $ registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos+		    | note <- notesSecured lockinfo ]+
+ Server.hs view
@@ -0,0 +1,394 @@+-- 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 Main where++import Network.Fancy++import Control.Concurrent (threadDelay)+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.State+import Control.Monad.Trans.Error+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans+import Control.Monad.IO.Class+import System.Random+import Data.Maybe+import Data.Word+import Data.Foldable (for_)+import Data.Time.Clock+import System.IO+import System.FilePath+import qualified Data.ByteString.Lazy as L+import qualified Data.Binary as B+import Data.Array+import Control.Exception+import System.IO.Error+import Data.List+import Data.Function (on)+import Pipes+import qualified Pipes.Prelude as P++import System.Environment+import System.Console.GetOpt++import Protocol+import Metagame+import Lock+import Frame+import Database+import AsciiLock+import Mundanities++port = 27001 -- 27001 == ('i'<<8) + 'y'++data Opt = RequestDelay Int+    deriving (Eq, Ord, Show)+options =+    [ Option ['d'] ["delay"] (ReqArg (RequestDelay . read) "MICROSECS") "delay before sending response (for testing) (default: 0)"+    --, Option ['d'] ["dir"] (ReqArg (DBDir . read)) "directory for server database [default: intricacydb]"+    ]+parseArgs :: [String] -> IO ([Opt],[String])+parseArgs argv =+    case getOpt Permute options argv of+	(o,n,[]) -> return (o,n)+	(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+    where header = "Usage: intricacy-server [OPTION...]"++main = do +    argv <- getArgs+    (opts,_) <- parseArgs argv+    let delay = fromMaybe 0 $ listToMaybe [ d | RequestDelay d <- opts ]+    withDB setDefaultServerInfo+    writeFile lockFilePath ""+    streamServer serverSpec{address = IPv4 "" port, threading=Inline} $ handler delay+    sleepForever++-- database path is relative to current directory: ./intricacydb/+dbpath = "intricacydb"+withDB = flip runReaderT dbpath++setDefaultServerInfo = do+    alreadySet <- recordExists RecServerInfo+    unless alreadySet $ putRecord RecServerInfo (RCServerInfo defaultServerInfo)++logit = putStrLn++handler :: Int -> Handle -> Address -> IO ()+handler delay hdl addr = handle ((\e -> return ()) :: SomeException -> IO ()) $+    handler' hdl addr+    where handler' hdl addr = do+	    response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do+		request <- B.decode <$> L.hGetContents hdl +		let hostname = case addr of+			IP n _ -> n+			IPv4 n _ -> n+			IPv6 n _ -> n+			Unix path -> path+		    hashedHostname = take 8 $ hash hostname+		now <- liftIO getCurrentTime+		logit $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request+		response <- handleRequest request+		when (delay > 0) $ threadDelay delay+		now' <- liftIO getCurrentTime+		logit $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response+		return response+	    L.hPut hdl $ B.encode response++showRequest :: ClientRequest -> String+showRequest (ClientRequest ver mauth act) = show ver ++ " "+    ++ maybe "" (\(Auth name pw) -> "Auth:" ++ name ++ ":" ++ take 4 pw) mauth ++ " "+    ++ showAction act+showAction :: Action -> String+showAction (SetLock lock idx soln) = "SetLock " ++ show idx ++ " lock:"+    ++ (if not $ validLock $ reframe lock then " [INVALID LOCK] " else "\n" ++ unlines (lockToAscii lock))+    ++ "[SOLN]"+showAction (DeclareSolution soln ls target idx) = "DeclareSolution [SOLN] "+    ++ (concat $ intersperse " " $ [show ls,show target,show idx])+showAction act = show act+showResponse :: ServerResponse -> String+showResponse (ServedLock lock) = "ServedLock lock:\n" ++ unlines (lockToAscii lock)+showResponse (ServedSolution soln) = "ServedSolution [SOLN]"+showResponse resp = show resp++-- | We lock the whole database during each request, using haskell's native+-- file locking, meaning that we have at any time one writer *xor* any number+-- of readers.+withDBLock lockMode m = do+    h <- getDBLock lockMode+    ret <- m+    hClose h+    return ret+    where getDBLock lockMode =+	    catchIO (openFile lockFilePath lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode)+lockFilePath = dbpath ++ [pathSeparator] ++ "lockfile"++handleRequest :: ClientRequest -> IO ServerResponse+handleRequest req@(ClientRequest pv auth action) = do+    let lockMode = case action of+	    Authenticate -> ReadMode+	    GetServerInfo -> ReadMode+	    GetLock _ -> ReadMode+	    GetUserInfo _ _ -> ReadMode+	    GetRetired _ -> ReadMode+	    GetSolution _ -> ReadMode+	    GetRandomNames _ -> ReadMode+	    _ -> ReadWriteMode+    eresp <- withDBLock lockMode $ runErrorT handleRequest'+    case eresp of+	Left error -> return $ ServerError error+	Right resp -> return resp+    where+	handleRequest' = do+	    when (pv /= protocolVersion) $ throwError "Bad protocol version"+	    case action of+		Authenticate -> do +		    checkAuth auth +		    return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)+		Register -> newUser auth >> return ServerAck+		ResetPassword passwd -> resetPassword auth passwd >> return ServerAck+		GetServerInfo -> ServedServerInfo <$> getServerInfo+		GetLock ls -> ServedLock <$> getLock ls+		GetRetired name -> ServedRetired <$> getRetired name+		GetUserInfo name mversion -> (do+			RCUserInfo (curV,info) <- getRecordErrored $ RecUserInfo name+			(fromJust<$>)$ runMaybeT $ msum [ do+			    v <- MaybeT $ return mversion+			    msum [ guard (v >= curV) >> return ServerFresh+				, do +				    guard (v >= curV - 10) +				    RCUserInfoDeltas deltas <- lift $ getRecordErrored $ RecUserInfoLog name+				    return $ ServedUserInfoDeltas $ take (curV-v) deltas+				]+			    , return $ ServedUserInfo (curV,info)+			    ]+		    ) `catchError` \_ -> return ServerCodenameFree+		GetSolution note -> do +		    uinfo <- getUserInfoOfAuth auth+		    let uname = codename uinfo+		    onLinfo <- getALock $ noteOn note+		    behindMLinfo <- maybe (return Nothing) ((Just<$>).getALock) $ noteBehind note+		    if uname == lockOwner (noteOn note)+			|| uname == noteAuthor note+		    then ServedSolution <$> getSolution note+		    else if case behindMLinfo of+				Nothing -> True+				Just behindInfo -> uname `elem` accessedBy behindInfo+			    || note `elem` notesRead uinfo+			then if public onLinfo || uname `elem` accessedBy onLinfo+			    then ServedSolution <$> getSolution note+			    else throwError "You can't wholly decipher that note."+			else throwError "You don't have access to that note."+		DeclareSolution soln ls target idx -> do+		    info <- getUserInfoOfAuth auth+		    lock <- getLock ls+		    tinfo <- getALock target+		    when (ls /= lockSpec tinfo) $ throwError "Lock no longer in use!"+		    when (public tinfo) $ throwError "Lock solution already public knowledge!"+		    let name = codename info+		    let behind = ActiveLock name idx+		    let note = NoteInfo name (Just behind) target+		    when (name `elem` map noteAuthor (lockSolutions tinfo)) $+			throwError "Note already taken on that lock!"+		    when (name == lockOwner target) $+			throwError "That's your lock!"+		    behindLock <- getALock behind+		    when (public behindLock) $ throwError "Your lock is cracked!"+		    unless (checkSolution lock soln) $ throwError "Bad solution"+		    erroredDB $ putRecord (RecNote note) (RCSolution soln)+		    execStateT (declareNote note behind) [] >>= applyDeltasToRecords+		    return ServerAck+		SetLock lock@(frame,_) idx soln -> do+		    info <- getUserInfoOfAuth auth+		    let name = codename info+		    let al = ActiveLock name idx+		    ServerInfo serverSize _ <- getServerInfo+		    when (frame /= BasicFrame serverSize) $ throwError $+			"Server only accepts size "++show serverSize++" locks."+		    unless (validLock $ reframe lock) $ throwError "Invalid lock!"+		    unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"+		    unless (checkSolution lock soln) $ throwError "Bad solution"++		    RCLockHashes hashes <- getRecordErrored RecLockHashes+			    `catchError` const (return (RCLockHashes []))+		    let hashed = hash $ show lock+		    when (hashed `elem` hashes) $ throwError "Lock has already been used"+		    ls <- erroredDB $ newLockRecord lock+		    erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes++		    let oldLockInfo = userLocks info ! idx+		    execStateT (do+			    when (isJust $ oldLockInfo) $+				lift (getALock al) >>= retireLock+			    addDelta name $ PutLock ls idx+			) [] >>= applyDeltasToRecords++		    for_ oldLockInfo $ \oldui -> do+			lss <- getRetired name+			erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ (lockSpec oldui):lss+		    return ServerAck+		GetRandomNames n -> do+		    names <- erroredDB $ listUsers+		    gen <- erroredIO $ getStdGen+		    let l = length names+			namesArray = listArray (0,l-1) names+			negligible name = do+			    uinfo <- getUserInfo name+			    return $ all (maybe True public . (userLocks uinfo !)) [0..2]++		    -- huzzah for pipes!+		    shuffled <- P.toListM $+			    mapM_ Pipes.yield (nub $ randomRs (0,l-1) gen)+			>-> P.take l -- give up once we've permuted all of [0..l-1]+			>-> P.map (namesArray !)+			>-> P.filterM ((not <$>) . negligible) -- throw away negligibles+			>-> P.take n -- try to take as many as we were asked for+		    liftIO newStdGen+		    return $ ServedRandomNames shuffled+		_ -> throwError "BUG: bad request"+	erroredIO :: IO a -> ErrorT String IO a+	erroredIO c = do+	    ret <- liftIO $ catchIO (Right <$> c) (return.Left)+	    case ret of+		Left e -> throwError $ "Server IO error: " ++ show e+		Right x -> return x+	erroredDB :: DBM a -> ErrorT String IO a+	erroredDB = erroredIO . withDB+	getRecordErrored :: Record -> ErrorT String IO RecordContents+	getRecordErrored rec = do+	    mrc <- lift $ withDB $ getRecord rec +	    case mrc of+		Just rc -> return rc+		Nothing -> throwError $ "Bad record on server! Record was: " ++ show rec+	getLock ls = do +	    RCLock lock <- getRecordErrored $ RecLock ls+	    return lock+	getSolution note = do +	    RCSolution soln <- getRecordErrored $ RecNote note+	    return soln+	getServerInfo = do+	    RCServerInfo sinfo <- getRecordErrored $ RecServerInfo+	    return sinfo+	getRetired name = do+	    RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> (erroredDB $ getRecord $ RecRetiredLocks name)+	    return lss+	getALock (ActiveLock name idx) = do+	    info <- getUserInfo name+	    checkValidLockIndex idx+	    case ((!idx).userLocks) info of+		Nothing -> throwError "Lock not set"+		Just lockinfo -> return lockinfo+	checkValidLockIndex idx =+	    unless (0<=idx && idx < maxLocks) $ throwError "Bad lock index"+	getUserInfo name = do +	    RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name+	    return info+	getUserInfoOfAuth auth = do +	    checkAuth auth+	    let Just (Auth name _) = auth+	    getUserInfo name+	    +	checkAuth :: Maybe Auth -> ErrorT String IO ()+	checkAuth Nothing = throwError "Authentication required"+	checkAuth (Just (Auth name pw)) = do+	    exists <- checkCodeName name+	    unless exists $ throwError "No such user"+	    RCPassword pw' <- getRecordErrored (RecPassword name)+	    when (pw /= pw') $ throwError "Wrong password"+	newUser :: Maybe Auth -> ErrorT String IO ()+	newUser Nothing = throwError "Require authentication"+	newUser (Just (Auth name pw)) = do+	    exists <- checkCodeName name+	    when exists $ throwError "Codename taken"+	    erroredDB $ putRecord (RecPassword name) (RCPassword pw)+	    erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))+	    erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])+	resetPassword Nothing pw = throwError "Authentication required"+	resetPassword auth@(Just (Auth name _)) newpw = do+	    checkAuth auth+	    erroredDB $ putRecord (RecPassword name) (RCPassword newpw)+	checkCodeName :: Codename -> ErrorT String IO Bool+	checkCodeName name = do+	    unless (validCodeName name) $ throwError "Invalid codename"+	    liftIO $ withDB $ recordExists $ RecPassword name+	--- | TODO: journalling so we can survive death during database writes?+	applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ErrorT String IO ()+	applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas+		| group <- groupBy ((==) `on` fst) nds +		, let name = fst $ head group+		, let deltas = map snd group ]+	applyDeltasToRecord name deltas = do+	    erroredDB $ modifyRecord (RecUserInfoLog name) $+		\(RCUserInfoDeltas deltas') -> RCUserInfoDeltas $ deltas ++ deltas'+	    erroredDB $ modifyRecord (RecUserInfo name) $+		\(RCUserInfo (v,info)) -> RCUserInfo $+		    (v+length deltas, applyDeltas info deltas)+	declareNote note@(NoteInfo _ _ target) behind@(ActiveLock name idx) = do+	    accessLock name target =<< getCurrALock target+	    addDelta (lockOwner target) $ LockDelta (lockIndex target) $ AddSolution note+	    addDelta name $ LockDelta idx $ AddSecured note+	    accessed <- accessedBy <$> getCurrALock behind+	    mapM_ (addReadNote note) (name:accessed)+	addReadNote note@(NoteInfo _ _ target) name = do+	    info <- getCurrUserInfo name+	    tlock <- getCurrALock target+	    unless (name `elem` accessedBy tlock || note `elem` notesRead info) $ do+		addDelta name $ AddRead note+		checkSuffReadNotes target name+	accessLock name target@(ActiveLock tname ti) tlock = do+	    addDelta tname $ LockDelta ti $ AddAccessed name+	    mapM_ (`addReadNote` name) $ notesSecured tlock+	publiciseLock al@(ActiveLock name idx) lock = do+	    addDelta name $ LockDelta idx SetPublic+	    retireLock lock+	retireLock lock = do+	    mapM_ scrapNote $ lockSolutions lock+	    mapM_ publiciseNote $ notesSecured lock+	scrapNote note@(NoteInfo _ (Just al@(ActiveLock name idx)) _) = do+	    addDelta name $ LockDelta idx (DelSecured note)+	    unreadNote note+	scrapNote _ = return ()+	unreadNote note@(NoteInfo name (Just al) _) = do+	    lock <- getCurrALock al+	    mapM_ (\name' -> addDelta name' (DelRead note)) $ name:(accessedBy lock)+	publiciseNote note@(NoteInfo _ _ al@(ActiveLock name idx)) = do+	    unreadNote note+	    addDelta name $ LockDelta idx $ SetPubNote note+	    publified <- checkSuffPubNotes al+	    unless publified $ do+	    lock <- getCurrALock al+	    accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)+		<$> (sequence +		    [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] )+	    forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al+	checkSuffReadNotes target name = do+	    info <- getCurrUserInfo name+	    tlock <- getCurrALock target+	    let countRead = fromIntegral $ length $+		    filter (\n -> isNothing (noteBehind n) || n `elem` notesRead info) $ lockSolutions tlock+	    when (countRead == notesNeeded && not (public tlock) && name /= lockOwner target) $+		accessLock name target tlock+	checkSuffPubNotes al@(ActiveLock name idx) = do+	    info <- getCurrUserInfo name+	    let Just lock = userLocks info ! idx+	    let countPub = fromIntegral $ length $+		    filter (isNothing.noteBehind) $ lockSolutions lock+	    if (countPub == notesNeeded)+		then publiciseLock al lock >> return True+		else return False+	-- | XXX we apply deltas right-to-left, so in the order of adding+	addDelta name delta = modify ((name,delta):)+	getCurrUserInfo name = do+	    info <- lift $ getUserInfo name+	    (applyDeltas info . map snd . filter ((==name).fst)) <$> get+	getCurrALock al@(ActiveLock name idx) =+	     (fromJust.(!idx).userLocks) <$> getCurrUserInfo name
+ ServerAddr.hs view
@@ -0,0 +1,32 @@+-- 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 ServerAddr where++import Data.List+import Data.Maybe+import Control.Applicative++data ServerAddr = ServerAddr {hostname::String, port::Int}+    deriving (Eq, Ord, Show, Read)+nullSaddr (ServerAddr host _) = null host++defaultPort=27001 -- == ('i'<<8) + 'y'+defaultServerAddr = ServerAddr "mbays.mdns.org" defaultPort++saddrStr (ServerAddr h p) = h ++ if p==defaultPort then "" else ':':show p++strToSaddr str =+    case elemIndex ':' str of+	Nothing -> Just $ ServerAddr str defaultPort+	Just idx -> do+	    let (addr,portstr) = splitAt idx str+	    port <- fst <$> listToMaybe (reads (drop 1 portstr))+	    return $ ServerAddr addr port
+ Setup.hs view
@@ -0,0 +1,12 @@+-- 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/.++import Distribution.Simple+main = defaultMain
+ Util.hs view
@@ -0,0 +1,16 @@+-- 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 Util where+import qualified Data.Vector as Vector+import Data.Vector (Vector)++enumVec :: Vector a -> [(Int,a)]+enumVec = Vector.toList . Vector.indexed
+ VeraMono.ttf view

binary file changed (absent → 49224 bytes)

+ intricacy.cabal view
@@ -0,0 +1,99 @@+name:                intricacy+version:             0.3+synopsis:            A game of competitive puzzle-design+homepage:            http://mbays.freeshell.org/intricacy+license:             GPL-3+license-file:        COPYING+author:              Martin Bays+maintainer:          mbays@sdf.org+-- copyright:           +category:            Game+build-type:          Simple+cabal-version:       >=1.8+data-files: VeraMono.ttf tutorial/*.lock tutorial/*.text+extra-doc-files: README NEWS tutorial-extra/*.lock tutorial-extra/README++description:+    A networked game with client-server architecture. The core game is a+    lockpicking-themed turn-based puzzle game on a hex grid. Players design+    puzzles (locks) and solve those designed by others. A metagame encourages+    the design of maximally difficult puzzles, within tight size constraints.+    The client supports Curses and SDL, with all graphics in SDL mode drawn by+    code using SDL-gfx. The network protocol is based on the 'binary' package,+    and is intended to be reasonably efficient. TVars are used to give+    transparent local caching and background network operations. Also+    incorporates an implementation of a graph 5-colouring algorithm (see+    GraphColouring.hs).++source-repository head+   type:     git+   location: http://mbays.freeshell.org/intricacy/.git++Flag SDL +    Description: Enable SDL UI+    Default: True+Flag Curses +    Description: Enable Curses UI+    Default: True+Flag Game+    Description: Build game+    Default: True+    Manual: True+Flag Server+    Description: Build server+    Default: False+    Manual: True++executable intricacy+  if flag(Game)+      extensions: DoAndIfThenElse+      build-depends: base >=4.3, base < 5+        , mtl >=2.0, transformers >=0.2, stm >= 2.1+        , directory >= 1.0, filepath >= 1.0, time >= 1.2+        , bytestring >=0.10+        , array >=0.3, containers >=0.4, vector >=0.9+        , binary >=0.5, network-fancy >= 0.1.5+        , cryptohash >= 0.8+      if flag(SDL)+          build-depends: SDL >=0.6.5, SDL-ttf >=0.6, SDL-gfx >=0.6+          if os(windows)+              Extra-Lib-Dirs:    winlibs+              Extra-Libraries:   SDL_ttf SDL SDL_gfx freetype+              ghc-options: -optl-mwindows+  else+      Buildable: False+  if flag(Curses)+      build-depends: hscurses >=1.4+  if flag(SDL)+      if flag(Curses)+        main-is: MainBoth.hs+      else+        main-is: MainSDL.hs+  else+      if flag(Curses)+        main-is: MainCurses.hs++  other-modules: AsciiLock, BinaryInstances, BoardColouring, Cache, Command,+      CursesRender, CursesUI, CursesUIMInstance, CVec, Database, Debug,+      EditGameState, Frame, GameState, GameStateTypes, GraphColouring, Hex, Init,+      InputMode, Interact, InteractUtil, KeyBindings, Lock, MainState,+      Maxlocksize, Metagame, Mundanities, Physics, Protocol, SDLRender, SDLUI,+      SDLUIMInstance, ServerAddr, Util++executable intricacy-server+  if flag(Server)+      extensions: DoAndIfThenElse+      build-depends: base >=4.3, base < 5+        , mtl >=2.0, transformers >=0.2, stm >= 2.1+        , directory >= 1.0, filepath >= 1.0, time >= 1.2+        , bytestring >=0.10+        , array >=0.3, containers >=0.4, vector >=0.9+        , binary >=0.5, network-fancy >= 0.1.5+        , cryptohash >= 0.8+        , random >= 1.0, pipes >= 4+  else+    Buildable: False+  main-is:  Server.hs+  other-modules: AsciiLock, BinaryInstances, BoardColouring, CVec, Database,+      Debug, Frame, GameState, GameStateTypes, GraphColouring, Hex, Lock,+      Maxlocksize, Metagame, Mundanities, Physics, Protocol, Util
+ tutorial-extra/5-springChains.lock view
@@ -0,0 +1,17 @@+        % % % % % % % % %          +       %                 % % % %   +      %                   %     %  +     %                     %     % +    % S S S S " S S S S & & & & & %+   %   o -   "   # # #       %   % +  %   /         #     %       % %  + %             #     %       [ %   +%           #       %       [   %  + %           " S S %       [   %   +  % S S S S " "   %       #   %    + % %           % % S S S S " %     +% * '                       %      + % @ %                     %       +  % % %                   %        +       %                 %         +        % % % % % % % % %
+ tutorial-extra/6-snookered.lock view
@@ -0,0 +1,17 @@+        " " " " " " " " "          +       " S S S # S S S % " " " "   +      "       #         % "     "  +     "       #     &     % "     " +    "       # O O   &     % % % % "+   "       # O O   & "     % "   " +  "       #       & " " "     " "  + "   & & & & & & & % C C # #   "   +" & &       & & & . o         % "  + " O O O O O & & o - '       % "   +  " O O O O   &   . o         "    + " " O O O   & & O % \       "     +" * ' O O   & &   %   o     "      + " @ " O   &     # Z #     "       +  " " "         # # Z     "        +       "   # # # # # Z   "         +        " " " " " " " " "
+ tutorial-extra/7-plunger.lock view
@@ -0,0 +1,17 @@+        " " " " " " " " "          +       "     #       # # " " " "   +      "   #   #     # #   "     "  +     "     #   ]   # #     " %   " +    "   #   # % % # # & & & %     "+   "     #   ]   % #   7   % "   " +  "   #   # " " # '   7   % % " "  + "     #   ]   " o % %   '   % "   +"       # % % # '   7 . o     % "  + "   #   ]   % o   7         1 "   +  "   # " " # ' # #         1 "    + " "   #   " o   7         # "     +" * '     % '   7           "      + " @ "   % o % %           "       +  " " " %     7           "        +       "     7           "         +        " " " " " " " " "
+ tutorial-extra/8-cogs.lock view
@@ -0,0 +1,17 @@+        " " " " " " " " "          +       " # # # # [ # # # " " " "   +      " # # # # [ # S S % "     "  +     " # # # # [       % % "     " +    " # # # # [           % % %   "+   " #   \   % % % %     %   "   " +  "       o - ' % [     . o   " "  + "   # # / . o   [ # #     `   "   +"   # # # # \ ` # # [     . o   "  + "   # #   ' o - ' [         ` "   +  "     . o / . o %       #   "    + " "       ` #   ` %     #   "     +" * '     # # # % % % % #   "      + " @ "   # # #   % # # #   "       +  " " "   # # % % # # #   "        +       "                 "         +        " " " " " " " " "
+ tutorial-extra/README view
@@ -0,0 +1,4 @@+Some harder tutorial levels.++To play these, either run intricacy on them, or move them into the 'tutorial'+directory, or see user 'TUT' on the main server.
+ tutorial/1-winning.lock view
@@ -0,0 +1,11 @@+       " " " " " "       +      "           " " "  +     "             "   " +    " S S S S S S # # # "+   "             #   " " +  "                   "  + " "                 "   +" * '               "    + " @ "             "     +  " " "           "      +       " " " " " "
+ tutorial/1-winning.text view
@@ -0,0 +1,1 @@+use tools to pull bolt, then Open the lock
+ tutorial/2-hook.lock view
@@ -0,0 +1,11 @@+       " " " " " "       +      " # # # # # " " "  +     " # # # # # # "   " +    " # # S S S S & & & "+   " # # ] #     & & " " +  " # # # ] # # #     "  + " "   # # ]         "   +" * ' &     ] # % % "    + " @ " Z     % Z % "     +  " " " Z       Z "      +       " " " " " "
+ tutorial/2-hook.text view
@@ -0,0 +1,1 @@+the hook is a versatile tool; move and rotate it to push the springs aside
+ tutorial/3-wrench.lock view
@@ -0,0 +1,17 @@+        " " " " " " " " "          +       "                 " " " "   +      "   % S S S S S &   "     "  +     "     O   %       &   "     " +    " % % % %   o -   & & & & & & "+   "         %   %           "   " +  "           %   % %   # # # " "  + "             %             # "   +"               % % %   # # # # "  + "             % %             "   +  "             %         O   "    + " "         &   % %   % % % "     +" * ' & & & & &     \     % "      + " @ "         & & & o   % "       +  " " "         &       % "        +       "         &     % "         +        " " " " " " " " "
+ tutorial/3-wrench.text view
@@ -0,0 +1,1 @@+you have less fine control over the wrench; it moves until stopped
+ tutorial/4-plug.lock view
@@ -0,0 +1,17 @@+        & & & & & & & & &          +       & #             [ & & & &   +      &   #           [   &     &  +     &     #         (     & # # & +    &       #       (   # # #     &+   & # # # # #     (   #   7 &   & +  &         %     (       7   & &  + &           Z   (       % % % &   +&             Z (       # S S % &  + &             "               &   +  &             ]             &    + & &             ] % % % % % &     +& * '             # %       &      + & @ &               %     &       +  & & &               %   &        +       &               % &         +        & & & & & & & & &
+ tutorial/4-plug.text view
@@ -0,0 +1,1 @@+Co-ordinate the tools. Keyboard control advised; rebind with ^B or right-click.