content: {-# LANGUAGE DoRec #-}
  -- | A minimal implementation of Freecell, a soltaire card game, to demonstrate
  -- the Sodium reactive programming system.
  --
  -- BE WARNED! This game can be addictive.
  --
  -- Package dependencies:
  --     random
  --     stb-image
  --     OpenGL
  --     GLUT
  import FRP.Sodium
  import Control.Applicative
  import Control.Monad
  import Data.Traversable (sequenceA)
  import Data.List
  import Data.Maybe
  import Engine
  import System.Random
  import System.FilePath
  import Data.Array.IArray as A
  import Data.Array.ST
  
  data Suit  = Spades | Clubs | Diamonds | Hearts
               deriving (Eq, Ord, Show, Enum, Bounded)
  data Value = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King
               deriving (Eq, Ord, Show, Enum, Bounded)
  data Card  = Card Value Suit
               deriving (Eq, Ord, Show)
  
  instance Enum Card where
      fromEnum (Card v s) = fromEnum v + fromEnum s * 13
      toEnum i = Card (toEnum v) (toEnum s)
        where
          (s, v) = divMod i 13
  
  instance Bounded Card where
      minBound = Card minBound minBound
      maxBound = Card maxBound maxBound 
  
  noOfStacks :: Int
  noOfStacks = 8
  
  noOfCells :: Int
  noOfCells = 4
  
  cardSize :: Vector
  cardSize = (100,150)
  
  overlapY :: Double
  overlapY = 70
  
  data Location = Stack Int | Cell Int | Grave deriving (Eq, Show)
  
  data Bunch = Bunch {
          buInitOrig     :: Point,
          buInitMousePos :: Point,
          buCards        :: [Card],
          buOrigin       :: Location
      }
      deriving Show
  
  data Destination = Destination {
          deLocation :: Location,
          deDropZone :: Rect,
          deMayDrop  :: [Card] -> Bool
      }
  
  validSequence :: [Card] -> Bool
  validSequence xs = and $ zipWith follows xs (drop 1 xs)
  
  follows :: Card -> Card -> Bool
  follows one@(Card v1 _) two@(Card v2 _) = isRed one /= isRed two && (v1 /= Ace && pred v1 == v2)
    where
      isRed :: Card -> Bool
      isRed (Card _ suit) = suit == Hearts || suit == Diamonds
  
  cardSpacing :: Double
  cardSpacing = (2000-cardWidth) / fromIntegral (noOfStacks-1)
    where
      (cardWidth, _) = cardSize
  
  cardSpacingNarrow :: Double
  cardSpacingNarrow = cardSpacing * 0.9
  
  topRow :: Double
  topRow = 1000 - 50 - cardHeight
    where
      (cardWidth, cardHeight) = cardSize
  
  draw :: Point -> Card -> Sprite
  draw pt (Card v s) = ((pt, cardSize), "cards" ++ [pathSeparator] ++ suitName s ++ valueName v ++ ".png")
    where
      suitName Spades = "s"
      suitName Clubs = "c"
      suitName Diamonds = "d"
      suitName Hearts = "h"
      valueName Ace = "1"
      valueName Two = "2"
      valueName Three = "3"
      valueName Four = "4"
      valueName Five = "5"
      valueName Six = "6"
      valueName Seven = "7"
      valueName Eight = "8"
      valueName Nine = "9"
      valueName Ten = "10"
      valueName Jack = "j"
      valueName Queen = "q"
      valueName King = "k"
  
  emptySpace :: Point -> Sprite
  emptySpace pt = ((pt, cardSize), "cards" ++ [pathSeparator] ++ "empty-space.png") 
  
  -- | The vertical stacks of cards, where cards can only be added if they're
  -- descending numbers and alternating red-black.
  stack :: Event MouseEvent -> [Card] -> Location -> Behavior Int -> Event [Card]
        -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch)
  stack eMouse initCards loc@(Stack ix) freeSpaces eDrop = do
      let (cardWidth, cardHeight) = cardSize
          orig@(origX, origY) = (
                  (-1000) + cardWidth*0.5 + fromIntegral ix * cardSpacing,
                  300
              )
          positions = iterate (\(x, y) -> (x, y-overlapY)) orig
      rec
          cards <- hold initCards (eRemoveCards `merge` eAddCards)
          let eAddCards = snapshot (\newCards cards -> cards ++ newCards) eDrop cards
              eMouseSelection = filterJust $ snapshot (\mev cards ->
                      case mev of
                          MouseDown pt@(x, y) | x >= origX - cardWidth && x <= origX + cardWidth ->
                              let n = length cards
                                  bottomY = (origY - cardHeight) - overlapY * fromIntegral (n-1) 
                                  ix = (length cards - 1) `min` floor (((origY + cardHeight) - y) / overlapY)
                                  (left, taken) = splitAt ix cards
                              in  if ix >= 0 && y >= bottomY
                                      then Just (left, Bunch (positions !! ix) pt taken loc)
                                      else Nothing
                          _ -> Nothing
                  ) eMouse cards
              eRemoveCards = fst <$> eMouseSelection   -- Cards left over when we drag
              eDrag        = snd <$> eMouseSelection   -- Cards removed when we drag
      let sprites = map (uncurry draw) . zip positions <$> cards
          dest = (\cards freeSpaces -> Destination {
                      deLocation = loc,
                      deDropZone = (orig `minus` (0, fromIntegral (length cards) * overlapY), cardSize),
                      deMayDrop = \newCards ->
                          validSequence newCards &&
                          -- You get one card for free, but there must be free cells for any
                          -- more than that.
                          (length newCards - 1) <= freeSpaces &&
                          case cards of
                              [] -> True
                              _  -> last cards `follows` head newCards
                  }
              ) <$> cards <*> freeSpaces
      return (sprites, dest, eDrag)
  
  -- | The "free cells" where cards can be temporarily put.
  cell :: Event MouseEvent -> Location -> Event [Card]
       -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch, Behavior Int)
  cell eMouse loc@(Cell ix) eDrop = do
      let (cardWidth, cardHeight) = cardSize
          orig = ((-1000) + cardWidth*0.5 + fromIntegral ix * cardSpacingNarrow, topRow)
          rect = (orig, cardSize)
      rec
          mCard <- hold Nothing $ eRemove `merge` (Just . head <$> eDrop)
          let eMouseSelection = filterJust $ snapshot (\mev mCard ->
                      case (mev, mCard) of
                          (MouseDown pt, Just card) | pt `inside` rect ->
                              Just (Nothing, Bunch (fst rect) pt [card] loc)
                          _ -> Nothing
                  ) eMouse mCard
              eRemove = fst <$> eMouseSelection
              eDrag = snd <$> eMouseSelection
      let sprites = ((:[]) . maybe (emptySpace orig) (draw orig)) <$> mCard
          dest = (\mCard -> Destination {
                  deLocation = loc,
                  deDropZone = rect,
                  deMayDrop = \newCards -> length newCards == 1 && isNothing mCard
              }) <$> mCard
          emptySpaces = (\c -> if isNothing c then 1 else 0) <$> mCard
      return (sprites, dest, eDrag, emptySpaces)
  
  -- | The place where the cards end up at the top right, aces first.
  grave :: Event MouseEvent -> Event [Card]
        -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch)
  grave eMouse eDrop = do
      let xOf ix = 1000 - cardWidth*0.5 - cardSpacingNarrow * fromIntegral (3-ix)
          positions = map (\ix -> (xOf ix, topRow)) [0..3]
          areas = zip positions (repeat cardSize)
          (cardWidth, cardHeight) = cardSize
          wholeRect = (((xOf 0 + xOf 3) * 0.5, topRow), ((cardSpacingNarrow * 3 + cardWidth*2) * 0.5, cardHeight))    
      rec
          let eDropModify = snapshot (\newCards slots ->
                      let newCard@(Card _ suit) = head newCards
                          ix = fromEnum suit
                      in  take ix slots ++ [Just newCard] ++ drop (ix+1) slots 
                  ) eDrop slots
          slots <- hold [Nothing, Nothing, Nothing, Nothing] (eDropModify `merge` eRemove)
          let eMouseSelection = filterJust $ snapshot (\mev slots ->
                      case mev of
                          MouseDown pt ->
                              let isIn = map (pt `inside`) areas
                              in  case trueIxOf isIn of
                                      Just ix ->
                                          case slots !! ix of
                                              Just card@(Card value suit) ->
                                                  let prevCard = if value == Ace then Nothing
                                                                                 else Just (Card (pred value) suit)
                                                      slots' = take ix slots ++ [prevCard] ++ drop (ix+1) slots
                                                  in  Just (slots', Bunch (positions !! ix) pt [card] Grave)
                                              Nothing -> Nothing
                                      Nothing -> Nothing
                          _ -> Nothing
                  ) eMouse slots
              eRemove = fst <$> eMouseSelection
              eDrag = snd <$> eMouseSelection
      let sprites = zipWith (\pos mSlot ->
                  maybe (emptySpace pos) (draw pos) mSlot
              ) positions <$> slots
          dest = (\slots -> Destination {
                  deLocation = Grave,
                  deDropZone = wholeRect,
                  deMayDrop = \newCards -> case newCards of
                      [card@(Card value suit)] ->
                          let ix = fromEnum suit
                          in  case slots !! ix of
                                  Just (Card topValue _) -> value == succ topValue
                                  Nothing                -> value == Ace 
                      _                    -> False
              }) <$> slots
      return (sprites, dest, eDrag)
    where
      -- Index of first true item in the list
      trueIxOf items = doit items 0
        where
          doit [] _ = Nothing
          doit (x:xs) ix = if x then Just ix
                                else doit xs (ix+1)
  
  -- | Draw the cards while they're being dragged.
  dragger :: Event MouseEvent -> Event Bunch -> Reactive (Behavior [Sprite], Event (Point, Bunch))
  dragger eMouse eStartDrag = do
      dragPos <- hold (0,0) $ flip fmap eMouse $ \mev ->
          case mev of
              MouseUp   pt -> pt
              MouseMove pt -> pt
              MouseDown pt -> pt
      rec
          dragging <- hold Nothing $ (const Nothing <$> eDrop) `merge` (Just <$> eStartDrag)
          let eDrop = filterJust $ snapshot (\mev mDragging ->
                      case (mev, mDragging) of
                          -- If the mouse is released, and we are dragging...
                          (MouseUp pt, Just dragging) -> Just (cardPos pt dragging, dragging)
                          _                           -> Nothing
                  ) eMouse dragging
      let sprites = drawDraggedCards <$> dragPos <*> dragging
            where
              drawDraggedCards pt (Just bunch) =
                  let cpos = cardPos pt bunch
                      positions = iterate (\(x, y) -> (x, y-overlapY)) cpos
                  in  zipWith draw positions (buCards bunch) 
              drawDraggedCards _ Nothing = []
      return (sprites, eDrop)
    where
      cardPos pt bunch = (pt `minus` buInitMousePos bunch) `plus` buInitOrig bunch
  
  -- | Determine where dropped cards are routed to.
  dropper :: Event (Point, Bunch) -> Behavior [Destination] -> Event (Location, [Card])
  dropper eDrop dests =
      snapshot (\(pt, bunch) dests ->
                  -- If none of the destinations will accept the dropped cards, then send them
                  -- back where they originated from.
                  let findDest [] = (buOrigin bunch, buCards bunch)
                      findDest (dest:rem) =
                          if pt `inside` deDropZone dest && deMayDrop dest (buCards bunch)
                              then (deLocation dest, buCards bunch)
                              else findDest rem
                  in  findDest dests
              ) eDrop dests
  
  distributeTo :: Event (Location, [Card]) -> [Location] -> [Event [Card]]
  distributeTo eWhere locations = flip map locations $ \thisLoc ->
      filterJust $ (\(loc, cards) ->
              if loc == thisLoc
                  then Just cards
                  else Nothing
          ) <$> eWhere
  
  freecell :: [[Card]] -> Game
  freecell stackCards eMouse time = do
      let stLocs = map Stack [0..noOfStacks-1]
          ceLocs = map Cell [0..noOfCells-1]
      rec
          let eWhere = dropper eDrop (sequenceA (stDests ++ ceDests ++ [grDest]))
              stDrops = eWhere `distributeTo` stLocs
              ceDrops = eWhere `distributeTo` ceLocs
              grDrops = eWhere `distributeTo` [Grave]
          (stSprites, stDests, stDrags) <- unzip3 <$> forM (zip3 stLocs stackCards stDrops) (\(loc, cards, drop) ->
              stack eMouse cards loc emptySpaces drop)
          (ceSprites, ceDests, ceDrags, ceEmptySpaces) <- unzip4 <$> forM (zip ceLocs ceDrops) (\(loc, drop) ->
              cell eMouse loc drop)
          (grSprites, grDest, grDrag) <- grave eMouse (head grDrops)
          -- The total number of empty spaces available in cells - 0 to 4. We need to
          -- know this when we drop a stack of cards, because (the rules of the game say)
          -- this is equivalent to temporarily putting all but one of them in cells.
          let emptySpaces = foldr1 (\x y -> (+) <$> x <*> y) ceEmptySpaces
          (drSprites, eDrop) <- dragger eMouse (foldr1 merge (stDrags ++ ceDrags ++ [grDrag]))
      return $ concat <$> sequenceA (stSprites ++ ceSprites ++ [grSprites] ++ [drSprites])
  
  shuffle :: StdGen -> [Card] -> ([Card], StdGen)
  shuffle rng cards =
      let n = length cards
          (rng', ixes) = mapAccumL (\rng () ->
                  let (ix, rng') = randomR (0, n-1) rng
                  in  (rng', ix)) rng (replicate n ())
          ary = runSTArray $ do
              ary <- newListArray (0, n-1) cards
              forM_ (zip [0..n-1] ixes) $ \(ix1, ix2) -> do
                  when (ix1 /= ix2) $ do
                      one <- readArray ary ix1
                      two <- readArray ary ix2
                      writeArray ary ix1 two
                      writeArray ary ix2 one
              return ary
      in  (A.elems ary, rng')
  
  toStacks :: Int -> [Card] -> [[Card]]
  toStacks noOfStacks cards = foldl (\stacks layer ->
          zipWith (++) (map (:[]) layer ++ repeat []) stacks
      ) (replicate noOfStacks []) (layerize cards)
    where
      layerize :: [Card] -> [[Card]]
      layerize cards = case splitAt noOfStacks cards of
          ([], _) -> []
          (layer, rem) -> layer : layerize rem
  
  main = do
      rng <- newStdGen
      let (cards, rng') = shuffle rng [minBound..maxBound]
      runGame "Freecell" (freecell (toStacks noOfStacks cards))
  
  