Battleship.hs http://chrispenner.ca/posts/adjunction-battleship

Battleship.hs

{-# language DeriveFunctor #-}
{-# language TypeFamilies #-}
{-# language MultiParamTypeClasses #-}
{-# language InstanceSigs #-}
{-# language FlexibleContexts #-}
module Main where
import Data.Functor (void)
import Data.Functor.Adjunction
import Data.Functor.Rep
import Data.Distributive
import Control.Arrow ((&&&))

tfUnit :: a -> (e -> (e, a))
tfUnit a e = (e, a)
tfCounit :: (e, e -> a) -> a
tfCounit (e, eToA) = eToA e

tfLeftAdjunct :: ((e, a) -> b) -> a -> (e -> b)
tfLeftAdjunct f = fmap f . tfUnit

tfRightAdjunct :: (a -> (e -> b)) -> (e, a) -> b
tfRightAdjunct f = tfCounit . fmap f

data Row = A | B | C deriving (Show, Eq)
data Column = I | II | III deriving (Show, Eq)
data CoordF a = CoordF Row Column a deriving (Show, Eq, Functor)
type Coord = CoordF ()

data Vessel = Ship | Sub | Sunk | Empty deriving (Show, Eq)

data Board a = Board
  (a, a, a)
  (a, a, a)
  (a, a, a)
  deriving (Eq, Functor)

instance (Show a) => Show (Board a) where
  show (Board top middle bottom) =
    "    I    II    III\n"
    ++ "A  " ++ show top ++ "\n"
    ++ "B  " ++ show middle ++ "\n"
    ++ "C  " ++ show bottom ++ "\n"

instance Representable Board where
  type Rep Board = Coord
  index (Board (a, _, _) _ _) (CoordF A I _) = a
  index (Board (_, a, _) _ _) (CoordF A II _) = a
  index (Board (_, _, a) _ _) (CoordF A III _) = a
  index (Board _ (a, _, _) _) (CoordF B I _) = a
  index (Board _ (_, a, _) _) (CoordF B II _) = a
  index (Board _ (_, _, a) _) (CoordF B III _) = a
  index (Board _ _ (a, _, _)) (CoordF C I _) = a
  index (Board _ _ (_, a, _)) (CoordF C II _) = a
  index (Board _ _ (_, _, a)) (CoordF C III _) = a

  tabulate desc = Board
    (desc (CoordF A I ()), desc (CoordF A II ()), desc (CoordF A III ()))
    (desc (CoordF B I ()), desc (CoordF B II ()), desc (CoordF B III ()))
    (desc (CoordF C I ()), desc (CoordF C II ()), desc (CoordF C III ()))

instance Distributive Board where
  distribute = distributeRep

startBoard :: Board Vessel
startBoard = Board
  (Empty, Empty, Empty)
  (Empty, Empty, Empty)
  (Empty, Empty, Empty)

myBoard1 :: Board Vessel
myBoard1 = Board
  (Empty, Empty, Ship)
  (Sub, Empty, Sub)
  (Ship, Empty, Empty)

define :: Coord -> Vessel
define (CoordF A III _) = Ship
define (CoordF B I _) = Sub
define (CoordF B III _) = Sub
define (CoordF C I _) = Ship
define _ = Empty

myBoard2 :: Board Vessel
myBoard2 = tabulate define

instance Adjunction CoordF Board where
  unit :: a -> Board (CoordF a)
  unit a = tabulate (\(CoordF row col ()) -> CoordF row col a)

  counit :: CoordF (Board a) -> a
  counit (CoordF row col board) = index board (CoordF row col ())

-- leftAdjunct :: (CoordF a -> b) -> a -> Board b
myBoard3 :: Board Vessel
myBoard3 = leftAdjunct define ()

-- rightAdjunct :: (a -> Board b) -> CoordF a -> b
myIndex :: Board a -> CoordF () -> a
myIndex board = rightAdjunct (const board)

-- zapWithAdjunction :: Adjunction f u => (a -> b -> c) -> u a -> f b -> c
-- zapWithAdjunction :: (a -> b -> c) -> Board a -> CoordF b -> c

data Weapon = Torpedo | DepthCharge deriving (Show, Eq)

checkHit :: Vessel -> Weapon -> Bool
checkHit Ship Torpedo = True
checkHit Sub DepthCharge = True
checkHit _ _ = False

shoot :: Board Vessel -> CoordF Weapon -> Bool
shoot = zapWithAdjunction checkHit

hitMap :: Board (Bool, Bool)
hitMap = fmap (flip checkHit Torpedo &&& flip checkHit DepthCharge) myBoard1

main :: IO ()
main = do
  print startBoard
  print myBoard1
  print myBoard2
  print (unit Ship :: Board (CoordF Vessel))
  print $ counit . CoordF A III $ myBoard1
  print myBoard3
  print $ myIndex myBoard1 $ CoordF A III ()
  putStrLn "myBoard1"
  print myBoard1
  print $ shoot myBoard1 (CoordF A III Torpedo)
  print $ shoot myBoard1 (CoordF A III DepthCharge)
  putStrLn "hitMap"
  print hitMap