{-# LANGUAGE TypeFamilies #-}

module Control.CP.FD.OvertonFD.Sugar (
) where

import Data.Set(Set)
import qualified Data.Set as Set

import Control.CP.Debug
import Control.Mixin.Mixin
import Control.CP.Solver
import Control.CP.FD.FD
import Control.CP.FD.SimpleFD
import Data.Expr.Data
import Data.Expr.Sugar
-- import Control.CP.FD.Expr.Util
import Control.CP.FD.Model
import Control.CP.FD.Graph
import Control.CP.FD.OvertonFD.OvertonFD

newVars :: Term s t => Int -> s [t]
newVars 0 = return []
newVars n = do
  l <- newVars $ n-1
  n <- newvar
  return $ n:l

instance FDSolver OvertonFD where
  type FDIntTerm OvertonFD = FDVar
  type FDBoolTerm OvertonFD = FDVar

  type FDIntSpec OvertonFD = FDVar
  type FDBoolSpec OvertonFD = FDVar
  type FDColSpec OvertonFD = [FDVar]
  
  type FDIntSpecType OvertonFD = ()
  type FDBoolSpecType OvertonFD = ()
  type FDColSpecType OvertonFD = ()

  fdIntSpec_const (Const i) = ((),do
    v <- newvar
    add $ OHasValue v $ fromInteger i
    return v)
  fdIntSpec_term i = ((),return i)
  
  fdBoolSpec_const (BoolConst i) = ((),do
    v <- newvar 
    add $ OHasValue v $ if i then 1 else 0
    return v)
  fdBoolSpec_term i = ((),return i)

  fdColSpec_list l = ((),return l)
  fdColSpec_size (Const s) = ((),newVars $ fromInteger s)
  fdColSpec_const l = ((),error "constant collections not yet supported by overton interface")

  fdColInspect = return

  fdSpecify = specify <@> simple_fdSpecify
  fdProcess = process <@> simple_fdProcess

  fdEqualInt v1 v2 = addFD $ OSame v1 v2
  fdEqualBool v1 v2 = addFD $ OSame v1 v2
  fdEqualCol v1 v2 = do
    if length v1 /= length v2
      then setFailed
      else sequence_ $ zipWith (\a b -> addFD $ OSame a b) v1 v2

  fdIntVarSpec = return . Just
  fdBoolVarSpec = return . Just
  fdSplitIntDomain b = do
    d <- fd_domain b
    return $ (map (b `OHasValue`) d, True)
  fdSplitBoolDomain b = do
    d <- fd_domain b
    return $ (map (b `OHasValue`) $ filter (\x -> x==0 || x==1) d, True)

-- processBinary :: (EGVarId,EGVarId,EGVarId) -> (FDVar -> FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()
processBinary (v1,v2,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec v2) (getDefIntSpec va)

-- processUnary :: (EGVarId,EGVarId) -> (FDVar -> FDVar -> OConstraint) -> FDInstance OvertonFD ()
processUnary (v1,va) f = addFD $ f (getDefIntSpec v1) (getDefIntSpec va)

specify :: Mixin (SpecFn OvertonFD)
specify s t edge = case (debug ("overton-specify("++(show edge)++")") edge) of
  EGEdge { egeCons = EGChannel, egeLinks = EGTypeData { intData=[i], boolData=[b] } } -> 
    ([(1000,b,True,do
      s <- getIntSpec i
      case s of
        Just ss -> return $ SpecResSpec ((),return (ss,Nothing))
        _ -> return SpecResNone
     )],[(1000,i,True,do
      s <- getBoolSpec b
      case s of
        Just ss -> return $ SpecResSpec ((),return (ss,Nothing))
        _ -> return SpecResNone
     )],[])
  _ -> s edge

-- process :: Mixin (EGEdge -> FDInstance OvertonFD ())
process s t con info = case (con,info) of
    (EGIntValue c, ([],[a],[])) -> case c of
      Const v -> addFD $ OHasValue (getDefIntSpec a) (fromInteger v)
      _ -> error "Overton solver does not support parametrized values"
    (EGPlus, ([],[a,b,c],[])) -> processBinary (b,c,a) OAdd
    (EGMinus, ([],[a,b,c],[])) -> processBinary (a,c,b) OAdd
    (EGMult, ([],[a,b,c],[])) -> processBinary (b,c,a) OMult
    (EGAbs, ([],[a,b],[])) -> processUnary (b,a) OAbs
    (EGDiff, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ ODiff (getDefIntSpec a) (getDefIntSpec b)
    (EGLess True, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLess (getDefIntSpec a) (getDefIntSpec b)
    (EGLess False, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OLessEq (getDefIntSpec a) (getDefIntSpec b)
    (EGEqual, ([FDSpecInfoBool {fdspBoolVal = Just (BoolConst True)}],[a,b],[])) -> addFD $ OSame (getDefIntSpec a) (getDefIntSpec b)
    _ -> s con info