Main.hs

{-# LANGUAGE DataKinds, TemplateHaskell, TypeFamilies, QuasiQuotes #-}
import TICTACTOE

game :: ([tq| x o x
              o o x
              ☐ ☐ x |])
game = (?)

TH.hs

{-# LANGUAGE TypeFamilies, DataKinds, GADTs, StandaloneDeriving, TemplateHaskell, GeneralizedNewtypeDeriving #-}
module TH where

import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Monad
import Data.List
import Data.Maybe

type family TICTACTOE (x1 :: CELL) (x2 :: CELL) (x3 :: CELL) (y1 :: CELL) (y2 :: CELL) (y3 :: CELL) (z1 :: CELL) (z2 :: CELL) (z3 :: CELL) :: GAME

data GAME = START | PROGRESS | WINNERA | WINNERB | DRAW
data CELL = NOBODY | PLAYERA | PLAYERB

data SOLVE (a :: GAME) where
  GameStarting :: SOLVE START
  GameProgress :: SOLVE PROGRESS
  Draw         :: SOLVE DRAW
  WinnerA      :: SOLVE WINNERA
  WinnerB      :: SOLVE WINNERB

deriving instance Show (SOLVE a)

data THG = N | A | B | D
  deriving (Show, Eq, Ord)

newtype Gam = Gam [THG]
  deriving (Show, Eq, Ord)

tq :: QuasiQuoter
tq = QuasiQuoter {
      quoteExp = error "not quotable"
    , quotePat = error "not quotable"
    , quoteType = dt
    , quoteDec = error "not quotable"
    }
  where
    dt :: String -> TypeQ
    dt s = appT (conT ''SOLVE)
         $ foldl (\x y -> appT x (conT y))
                 (conT ''TICTACTOE)
                 ((>>=) s gam)
    gam :: Char -> [Name]
    gam 'x' = ['PLAYERA]
    gam 'o' = ['PLAYERB]
    gam '☐' = ['NOBODY]
    gam _ = []

tictactoe :: Q [Dec]
tictactoe = mapM gmOf $ concat $ map (mkGame (Gam [N, N, N, N, N, N, N, N, N]) A) [0..8]
  where
    mkGame :: Gam -> THG -> Int -> [Gam]
    mkGame (Gam gm) t i = if gm !! i /= N
      then []
      else let ng = Gam (set i t gm)
               moreg :: [Gam]
               moreg = if winner gm == N
                       then concat $ map (mkGame ng (ot t)) [0..8]
                       else []
           in nub . sort $ ((ng :: Gam) : (moreg :: [Gam]))
    ot A = B
    ot B = A
    set i t gm = let
      (h, r) = splitAt i gm
      in (h ++ (t : tail r))
    gmOf :: Gam -> DecQ
    gmOf (Gam gm) = tySynInstD ''TICTACTOE (map move gm) (winth (winner gm))
    move A = conT 'PLAYERA
    move B = conT 'PLAYERB
    move N = conT 'NOBODY
    winth A = conT 'WINNERA
    winth B = conT 'WINNERB
    winth N = conT 'PROGRESS
    winth D = conT 'DRAW
    winner gm = let
      c1 = (col 0 gm)
      c2 = (col 1 gm)
      c3 = (col 2 gm)
      r1 = (row 0 gm)
      r2 = (row 1 gm)
      r3 = (row 2 gm)
      d1 = (diL gm)
      d2 = (diR gm)
      res = catMaybes [c1, c2, c3, r1, r2, r3, d1, d2]
      in if null res
        then if any (== N) gm
          then N
          else D
        else head res
    col n gm =
      if gm !! (0 + n) == A && gm !! (3 + n) == A && gm !! (6 + n) == A
      then Just A
      else if gm !! (0 + n) == B && gm !! (3 + n) == B && gm !! (6 + n) == B
        then Just B
        else Nothing
    row n gm =
      if gm !! (0 + (n * 3)) == A && gm !! (1 + (n * 3)) == A && gm !! (2 + (n * 3)) == A
      then Just A
      else if gm !! (0 + (n * 3)) == B && gm !! (1 + (n * 3)) == B && gm !! (2 + (n * 3)) == B
        then Just B
        else Nothing
    diL gm = if gm !! 0 == A && gm !! 4 == A && gm !! 8 == A
      then Just A
      else if gm !! 0 == B && gm !! 4 == B && gm !! 8 == B
        then Just B
        else Nothing
    diR gm = if gm !! 2 == A && gm !! 4 == A && gm !! 6 == A
      then Just A
      else if gm !! 2 == B && gm !! 4 == B && gm !! 6 == B
        then Just B
        else Nothing

TICTACTOE.hs

{-# LANGUAGE TypeFamilies, DataKinds, GADTs, StandaloneDeriving, TemplateHaskell, GeneralizedNewtypeDeriving #-}
module TICTACTOE (TICTACTOE, CELL(..), (?), SOLVE(..), tq) where

import GHC.TypeLits

import TH

class Game (a :: GAME) where
  (?) :: SOLVE a

instance Game START where
  (?) = GameStarting
instance Game PROGRESS where
  (?) = GameProgress
instance Game DRAW where
  (?) = Draw
instance Game WINNERA where
  (?) = WinnerA
instance Game WINNERB where
  (?) = WinnerB

type instance TICTACTOE NOBODY NOBODY NOBODY NOBODY NOBODY NOBODY NOBODY NOBODY NOBODY = START

tictactoe