{-# LANGUAGE TupleSections #-}

module Interpreter where

import Data.Function
import qualified Data.Map as M

{- VAM 2P, done the lazy way -}
data StrTable =
  StrTable Int (M.Map Int String)

data Datum
  = Atom Int -- unifies a constant
  | Struct (Int, Int) -- unifies a structure with arity
  -- | VoidVar -- unifies with anything
  -- | LocalVar Int -- unifies with a local variable (possibly making a new one when it's not in use yet)
  -- | Ref Int -- unifies with the referenced value on the heap (not to be used in code)
  deriving (Show, Eq, Ord)

data Instr
  = U Datum -- something unifiable
  | NoGoal -- trivial goal
  | Goal -- we start a new goal, set up backtracking etc
  | Call -- all seems okay, call the goal
  | LastCall -- tail call the goal
  | Cut -- remove all alternative clauses of the current goal
  deriving (Show)

type Code = [Instr]

type Alts = [(Code, Code)] -- clauses to try and the corresponding goals to restore

data GolAlts =
  GA Code Alts -- goal + choicepoints
  deriving (Show)

type Defs = M.Map (Int, Int) [Code]

data Interp =
  Interp
    { defs :: Defs -- global definitions for lookup
    , hed :: Code -- current head
    , gol :: GolAlts -- current goal with local choicepoints
    , stk :: [GolAlts] -- stack of caller GolAlts
    }
  deriving (Show)

prove :: Code -> Defs -> Either (Interp, String) Bool
prove g ds =
  let i0 = Interp {defs = ds, hed = g, gol = GA [LastCall] [], stk = []}
      run (Left x) = x
      run (Right x) = run $ proveStep Right Left x
   in run (Right i0)

{- this gonna need Either String Bool for errors later -}
proveStep :: (Interp -> a) -> (Either (Interp, String) Bool -> a) -> Interp -> a
proveStep c f i = go i
  where
    ifail msg = f $ Left (i, msg)
    withDef f
      | Just d <- defs i M.!? f = ($ d)
      | otherwise = const $ ifail $ "no definition: " ++ show f
    {- Backtracking: try a fallback clause, restoring goal -}
    backtrack i@Interp {gol = GA _ ((s, gs):as)} = c i {hed = s, gol = GA gs as}
    {- B: no next clause, pop stack and continue backtracking at the caller -}
    backtrack i@Interp {gol = GA _ [], stk = GA g ss:sss} =
      backtrack i {hed = error "failed hed", gol = GA g ss, stk = sss}
    {- B: we ran out of possibilities and there's nothing else to backtrack. No solution found. -}
    backtrack i@Interp {gol = GA _ [], stk = []} = f (Right False)
    {- Unification -}
    go i@Interp {hed = (U a:hs), gol = GA (U b:gs) ss} -- unify constants
     = unify a b
      where
        uok = c i {hed = hs, gol = GA gs ss}
        unify (Atom a) (Atom b)
          | a == b = uok
        unify (Struct a) (Struct b)
          | a == b = uok
        unify _ _ = backtrack i
    {- Resolution: Final success -}
    go i@Interp {hed = [NoGoal], gol = GA [LastCall] _, stk = []} =
      f (Right True)
    {- R: Goal succeeded; continue at parent frame -}
    go i@Interp { hed = [NoGoal]
                , gol = GA [LastCall] _
                , stk = GA (Goal:U (Struct f):gs) ss:sss
                } =
      withDef f $ \(hs:ohs) ->
        c i {hed = hs, gol = GA gs (map (, gs) ohs ++ ss), stk = sss}
    {- R: Start matching next goal -}
    go i@Interp { hed = [NoGoal]
                , gol = GA (Call:Goal:U (Struct f):gs) ss
                } =
      withDef f $ \(hs:ohs) ->
        c i {hed = hs, gol = GA gs (map (, gs) ohs ++ ss)}
    {- R: Goal head matching succeeded, make a normal call -}
    go i@Interp { hed = (Goal:U (Struct f):ngs)
                , gol = GA (Call:gs) ss
                , stk = sss
                } =
      withDef f $ \(hs:ohs) ->
        c i {hed = hs, gol = GA ngs (map (, ngs) ohs), stk = GA gs ss : sss}
    {- R: Successful match continued by tail call -}
    go i@Interp { hed = (Goal:U (Struct f):ngs)
                , gol = GA [LastCall] ss
                } =
      withDef f $ \(hs:ohs) ->
        c i {hed = hs, gol = GA ngs (map (, ngs) ohs ++ ss)}
    {- The End -}
    go _ = ifail "impossible instruction combo"