module Elab.Eval.Formula where

import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Map.Strict (Map)
import Data.Set (Set)

import Syntax

import {-# SOURCE #-} Elab.WiredIn (inot, ior, iand)
import Elab.Eval (substitute, trueCaseSentinel)

toDnf :: Value -> Maybe Value
toDnf = fmap (dnf2Val . normalise) . val2Dnf where
  val2Dnf (VNe _ _) = Nothing
  val2Dnf x = toDnf x where
    toDnf (VIAnd x y) = idist <$> toDnf (inot x) <*> toDnf (inot y)
    toDnf (VIOr x y) = ior <$> toDnf x <*> toDnf y
    toDnf (VINot x) = inot <$> toDnf x
    toDnf VI0 = pure VI0
    toDnf VI1 = pure VI1
    toDnf v@(VNe _ Seq.Empty) = pure v
    toDnf _ = Nothing

  dnf2Val xs = Set.foldl ior VI0 (Set.map (Set.foldl iand VI1) xs)

type Nf = Set (Set Value)

normalise :: Value -> Nf
normalise = normaliseOr where
  normaliseOr (VIOr x y) = Set.singleton (normaliseAnd x) <> normaliseOr y
  normaliseOr x = Set.singleton (normaliseAnd x)

  normaliseAnd (VIAnd x y) = Set.insert x (normaliseAnd y)
  normaliseAnd x = Set.singleton x

compareDNFs :: Value -> Value -> Bool
compareDNFs (VIOr x y) (VIOr x' y') =
  let (a, a') = swap x y
      (b, b') = swap x' y'
   in compareDNFs a b && compareDNFs a' b'
compareDNFs (VIAnd x y) (VIAnd x' y') =
  let (a, a') = swap x x'
      (b, b') = swap y y'
   in compareDNFs a a' && compareDNFs b b'
compareDNFs x y = x == y

swap :: Ord b => b -> b -> (b, b)
swap x y =
  if x <= y then (x, y) else (y, x)

possible :: Map Head Bool -> Value -> (Bool, Map Head Bool)
possible sc (VINot (VNe n Seq.Empty)) =
  case Map.lookup n sc of
    Just True -> (False, sc)
    _ -> (True, Map.insert n False sc)
possible sc (VNe n Seq.Empty) =
  case Map.lookup n sc of
    Just False -> (False, sc)
    _ -> (True, Map.insert n True sc)
possible sc (VIAnd x y) =
  let (a, sc') = possible sc x
      (b, sc'') = possible sc' y
   in (a && b, sc'')
possible sc (VIOr x y) =
  case possible sc x of
    (True, sc') -> (True, sc')
    (False, _) -> possible sc y
possible sc VI0 = (False, sc)
possible sc VI1 = (True, sc)
possible sc _ = (False, sc)

truthAssignments :: NFEndp -> Map Name (NFType, NFEndp) -> [Map Name (NFType, NFEndp)]
truthAssignments VI0 _ = []
truthAssignments VI1 m = pure m
truthAssignments (VIOr x y) m = truthAssignments x m ++ truthAssignments y m
truthAssignments (VIAnd x y) m = truthAssignments x =<< truthAssignments y m
truthAssignments (VNe (HVar x) Seq.Empty) m = pure (Map.insert x (VI, VI1) (sub x VI1 <$> m))
truthAssignments (VINot (VNe (HVar x) Seq.Empty)) m = pure (Map.insert x (VI, VI0) (sub x VI0 <$> m))
truthAssignments (VCase _ _ (VNe (HVar x) _) _) m = pure (Map.insert x (VI, VVar trueCaseSentinel) m)
truthAssignments _ m = pure m

sub :: Name -> Value -> (NFType, NFEndp) -> (Value, Value)
sub x v (a, b) = (substitute (Map.singleton x v) a, substitute (Map.singleton x v) b)

idist :: Value -> Value -> Value
idist (VIOr x y) z = (x `idist` z) `ior` (y `idist` z)
idist z (VIOr x y) = (z `idist` x) `ior` (z `idist` y)
idist z x = iand z x