module Language.EDSL.SingleStateVar

import Data.List
import Data.List.Quantifiers

%default total
%access public export

namespace TypeLevel

  data Var : Type where
    MkVar : Var

  record StateItem (stateType : Type) where
    constructor MkStateItem
    label : Var
    value : stateType

  Context : (type : Type) -> Type
  Context type = List (StateItem type)

  Lang : Type -> Type -> Type
  Lang mtype stype = (val : mtype)
      -> (ty : Type)
      -> (pre : Context stype)
      -> (post : ty -> Context stype)
      -> Type

  data LANG : (mType : Type) -> (stype : Type) -> Type where
    MkLang : (mType : Type)
          -> (stype : Type)
          -> (rtype : Type)
          -> Lang mType stype
          -> LANG mType stype

  realType : LANG mType stateType -> Type
  realType (MkLang _ _ t  _) = t

  desc : LANG mType stateType -> Lang mType stateType
  desc (MkLang _ _ _ l) = l

  data LangTyM : Type -> Type where
    TyExpr : (ty : type) -> LangTyM type
    TyStmt : LangTyM type

  data LangM : (m : Type -> Type)
            -> (retTy : Type)
            -> (spec : LANG mType stype)
            -> (metaTy : LangTyM mType)
            -> (pre : Context stype)
            -> (post : retTy -> Context stype)
            -> Type
    where
      Value : (value : a) -> LangM m a spec TyStmt (postK value) postK

      Let : LangM m a spec mTyA old oldK
        -> ((val : a) -> LangM m b spec mTyB (oldK val) postK)
        -> LangM m b spec TyStmt old postK

      Expr : {eSig : Lang mType stype}
          -> (expr : eSig val t old newK)
          -> LangM m t (MkLang mType stype rtype eSig) (TyExpr val) old newK

namespace API
  pure : (value : a) -> LangM m a spec TyStmt (postK value) postK
  pure = Value

  (>>=) : LangM m a spec mTyA old oldK
        -> ((val : a) -> LangM m b spec mTyB (oldK val) postK)
        -> LangM m b spec TyStmt old postK
  (>>=) = Let

  expr : {eSig : Lang mtype stype}
      -> (expr : eSig val t old newK)
      -> LangM m t (MkLang mtype stype rtype eSig) (TyExpr val) old newK
  expr = Expr

namespace All
    AllContext : (p : StateItem type -> Type)
              -> (c : Context type)
              -> Type
    AllContext p c = All p c

namespace Element
  InContext : (p : StateItem type -> Type)
           -> (c : Context type)
           -> Type
  InContext p c = Any p c

  update : {predicate : StateItem type -> Type}
        -> (f : (item   : StateItem type)
             -> (bewijs : predicate item)
             -> StateItem type)
        -> (context : Context type)
        -> (index   : InContext predicate context)
        -> Context type
  update f (item :: rest) (Here bewijs) = f item bewijs :: rest
  update f (not_x :: rest) (There komt) = not_x :: update f rest komt

  drop : {predicate : StateItem type -> Type}
      -> (context   : Context type)
      -> (index     : InContext predicate context)
      -> Context type
  drop (item :: rest) (Here bewijs) = rest
  drop (not_x :: rest) (There komt) = not_x :: drop rest komt

  setState : {predicate : StateItem type -> Type}
          -> (item'     : type)
          -> (context   : Context type)
          -> (index     : InContext predicate context)
          -> Context type
  setState item' context index {predicate} {type} =
       update (doUpdate item') context index
    where
      doUpdate : (newState : type)
              -> (item     : StateItem type)
              -> (bewijs   : predicate item)
              -> StateItem type
      doUpdate newState (MkStateItem label state) bewijs = (MkStateItem label newState)

-- -------------------------------------------------------------- [ Evaluation ]
namespace Env
  data Tag : LANG mtype stype ->  Type where
    MkTag : (real : rtype) -> Tag (MkLang mtype stype rtype eSig)

  data Env : (m : Type -> Type) -> LANG mtype stype -> Context stype -> Type where
    Nil  : Env m spec Nil
    (::) : (tag  : Tag spec)
        -> (rest : Env m spec items)
        -> Env m spec (item::items)

  lookup : (env : Env m lang context)
        -> (idx : InContext p context)
        -> Tag lang
  lookup (tag :: rest) (Here prf) = tag
  lookup (tag :: rest) (There later) = lookup rest later

  ||| Update the type level state in the environment.
  update : {ctxt : Context stype}
        -> (env  : Env m lang ctxt)
        -> (idx  : InContext p ctxt)
        -> (up   : (i : StateItem stype) -> p i -> StateItem stype)
        -> Env m lang (update up ctxt idx)
  update (tag :: rest) (Here prf) up = tag :: rest
  update (tag :: rest) (There later) up = tag :: update rest later up

  ||| Drop the state at the given index.
  drop : (env : Env m lang ctxt)
      -> (idx : InContext p ctxt)
      -> Env m lang (drop ctxt idx)
  drop (tag :: rest) (Here prf) = rest
  drop (tag :: rest) (There later) = tag :: drop rest later

namespace Building

  interface Builder (l : LANG mtype stype) (tyBRes : Type) (m : Type -> Type) | l where
     build : (env  : Env m l pre)
          -> (expr : (desc l) val tyExpr pre postK)
          -> (acc  : tyBRes)
          -> (cont : (value' : tyExpr)
                  -> (env' : Env m l (postK value'))
                  -> (acc' : tyBRes)
                  -> m tyRes)
          -> m tyRes

  rawEval : Builder lang tyBRes m
         => (env  : Env m lang pre)
         -> (expr : LangM m tyExpr lang mty pre postK)
         -> (acc  : tyBRes)
         -> (cont : (value : tyExpr)
                 -> (env'  : Env m lang (postK value))
                 -> (acc'  : tyBRes)
                 -> m tyRes)
         -> m tyRes
  rawEval env (Value value) acc cont = cont value env acc
  rawEval env (Let this beIn) acc cont =
    rawEval env this acc (\this', env', acc' =>
                             rawEval env' (beIn this') acc' cont)
  rawEval env (Expr expr) acc cont =
     build env expr acc (\value', env', acc' => cont value' env' acc')

  record BuildResult (tyExpr : Type) (tyBRes : Type) where
    constructor MkResult
    computed : tyExpr
    built    : tyBRes

  runBuild : Applicative m
          => Builder lang tyBRes m
          => (init : tyBRes)
          -> (expr : LangM m tyExpr lang mTy Nil (const Nil))
          -> m (BuildResult tyExpr tyBRes)
  runBuild init expr = rawEval Nil expr init (\val, env', acc' => pure $ MkResult val acc')

  runPure : Builder lang tyBRes Basics.id
         => (init : tyBRes)
         -> (expr : LangM Basics.id tyExpr lang mTy Nil (const Nil))
         -> (BuildResult tyExpr tyBRes)
  runPure init expr = rawEval Nil expr init (\val, env', acc' => MkResult val acc')

-- --------------------------------------------------------------------- [ EOF ]


module Data.HVect

import Decidable.Equality
import Data.List
import public Data.Vect
import Data.Vect.Elem

%default total

||| Heterogeneous vectors where the type index gives, element-wise,
||| the types of the contents.
public export
data HVect : Vect k Type -> Type where
  Nil : HVect []
  (::) : t -> HVect ts -> HVect (t :: ts)

||| Extract an element from an HVect.
|||
||| ```idris example
||| > index 0 (the (HVect _) [1, "string"])
||| 1
||| ```
public export
index : (1 i : Fin k) -> (1 _ : HVect ts) -> index i ts
index FZ (x :: xs) = x
index (FS j) (x :: xs) = index j xs

||| Delete an element from an HVect.
|||
||| ```idris example
||| > deleteAt 0 (the (HVect _) [1, "string"])
||| ["string"]
||| ```
public export
deleteAt : (1 i : Fin (S l)) -> (1 _ : HVect ts) -> HVect (deleteAt i ts)
deleteAt FZ (x :: xs) = xs
deleteAt (FS FZ) (x :: (y :: xs)) = x :: xs
deleteAt (FS (FS j)) (x :: (y :: xs)) = x :: deleteAt (FS j) (y :: xs)

||| Replace an element in an HVect.
|||
||| ```idris example
||| > replaceAt 0 "firstString" (the (HVect _) [1, "string"])
||| ["firstString", "string"]
||| ```
public export
replaceAt : (1 i : Fin k) -> t -> (1 _ : HVect ts) -> HVect (replaceAt i t ts)
replaceAt FZ y (x :: xs) = y :: xs
replaceAt (FS j) y (x :: xs) = x :: replaceAt j y xs

||| Update an element in an HVect.
|||
||| ```idris example
||| > updateAt 0 (const True) (the (HVect _) [1, "string"])
||| [True, "string"]
||| ```
public export
updateAt : (1 i : Fin k) -> (index i ts -> t) -> (1 _ : HVect ts) -> HVect (replaceAt i t ts)
updateAt FZ f (x :: xs) = f x :: xs
updateAt (FS j) f (x :: xs) = x :: updateAt j f xs

||| Append two `HVect`s.
|||
||| ```idris example
||| > (the (HVect _) [1]) ++ (the (HVect _) ["string"])
||| [1, "string"]
||| ```
public export
(++) : (1 _ : HVect ts) -> HVect us -> HVect (ts ++ us)
(++) [] ys = ys
(++) (x :: xs) ys = x :: (xs ++ ys)

public export
Eq (HVect []) where
  [] == [] = True

public export
(Eq t, Eq (HVect ts)) => Eq (HVect (t :: ts)) where
  (x :: xs) == (y :: ys) = x == y && xs == ys

public export
consInjective1 : {0 xs, ys: HVect ts} -> {0 x, y: a} -> (1 _ : x :: xs = y :: ys) -> x = y
consInjective1 Refl = Refl

public export
consInjective2 : {0 xs, ys: HVect ts} -> {0 x, y: a} -> (1 _ : x :: xs = y :: ys) -> xs = ys
consInjective2 Refl = Refl

public export
DecEq (HVect []) where
  decEq [] [] = Yes Refl

public export
(DecEq t, DecEq (HVect ts)) => DecEq (HVect (t :: ts)) where
  decEq (x :: xs) (y :: ys) with (decEq x y)
    decEq (z :: xs) (z :: ys) | Yes Refl with (decEq xs ys)
      decEq (z :: zs) (z :: zs) | Yes Refl | Yes Refl = Yes Refl
      decEq (z :: xs) (z :: ys) | Yes Refl | No contra = No (contra . consInjective2)
    decEq (x :: xs) (y :: ys) | No contra = No (contra . consInjective1)

public export
interface Shows (k : Nat) (ts : Vect k Type) where
  shows : HVect ts -> Vect k String

public export
Shows Z [] where
  shows [] = []

public export
(Show t, Shows len ts) => Shows (S len) (t :: ts) where
  shows (x :: xs) = show x :: shows xs

public export
(Shows len ts) => Show (HVect ts) where
  show xs = "[" ++ (pack . intercalate [','] . map unpack . toList $ shows xs) ++ "]"

||| Extract an arbitrary element of the correct type.
|||
||| ```idris example
||| > get [1, "string"] {p = Here}
||| 1
||| ```
public export
get : (1 _ : HVect ts) -> {auto 1 p : Elem t ts} -> t
get (x :: xs) {p = Here} = x
get (x :: xs) {p = (There p')} = get xs

||| Replace an element with the correct type. (Homogeneous)
|||
||| ```idris example
||| > put 2 [1, "string"]
||| [2, "string"]
||| ```
public export
put : t -> (1 _ : HVect ts) -> {auto 1 p : Elem t ts} -> HVect ts
put y (x :: xs) {p = Here} = y :: xs
put y (x :: xs) {p = (There p')} = x :: put y xs

||| Replace an element with the correct type. (Heterogeneous)
|||
||| ```idris example
||| > htPut True [1, "string"] {p = Here}
||| [True, "string"]
||| ```
public export
htPut : u -> (1 _ : HVect ts) -> {auto 1 p : Elem t ts} -> HVect (replaceByElem ts p u)
htPut y (x :: xs) {p = Here} = y :: xs
htPut y (x :: xs) {p = There p'} = x :: htPut y xs

||| Update an element with the correct type. (Homogeneous)
|||
||| ```idris example
||| > update (const "hello world!") [1, "string"]
||| [1, "hello world!"]
||| ```
public export
update : (t -> t) -> (1 _ : HVect ts) -> {auto 1 p : Elem t ts} -> HVect ts
update f (x :: xs) {p = Here} = f x :: xs
update f (x :: xs) {p = There p'} = x :: update f xs

||| Update an element with the correct type. (Heterogeneous)
|||
||| ```idris example
||| > htUpdate (\_ : String => 2) [1, "string"]
||| [1, 2]
||| ```
public export
htUpdate : (t -> u) -> (1 _ : HVect ts) -> {auto 1 p : Elem t ts} -> HVect (replaceByElem ts p u)
htUpdate f (x :: xs) {p = Here} = f x :: xs
htUpdate f (x :: xs) {p = (There p')} = x :: htUpdate f xs


||| Environments.
|||
||| Module    : Environment.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
module Toolkit.DeBruijn.Environment

import Decidable.Equality

import Data.DPair

import Toolkit.Decidable.Informative

import Toolkit.Data.List.AtIndex
import Toolkit.Data.DList
import Toolkit.Data.DList.AtIndex

import Toolkit.DeBruijn.Context.Item
import Toolkit.DeBruijn.Context
import Toolkit.DeBruijn.Renaming

%default total

||| Sometimes it is bettern to think that we have this thing called an
||| environment and not a `DList`.
|||
||| @t    The Type for Types in our environment.
||| @obj  How we interpret the types in our DSL. Either this is a
|||       dependent type or a function that computes a type.
||| @ctxt The typing context.
public export
Env : (t : Type) -> (obj : t -> Type) -> (ctxt : List t) -> Type
Env = DList

||| Add an object to our execution environment.
||| @env The typing environment.
export
extend : {t : ty}
      -> (env : Env ty e ctxt)
      -> (obj : e t)
      -> Env ty e (t::ctxt)
extend env obj = obj :: env

namespace Elem
  ||| Read an object from our typing environment.
  |||
  ||| @idx Which object.
  ||| @env The execution environment.
  export
  read : (idx : Elem t ctxt)
      -> (env : Env ty e ctxt)
      -> e t
  read Here      (obj::store) = obj
  read (There x) (obj::store) = read x store

  ||| Add an object to our execution environment.
  |||
  ||| @idx Where the object is.
  ||| @obj The new object.
  ||| @env The environment to which the object is added.
  export
  update : (idx : Elem t ctxt)
        -> (obj : e t)
        -> (env : Env ty e ctxt)
        -> Env ty e ctxt
  update Here      obj (_    :: store) = obj  :: store
  update (There x) obj (obj' :: store) = obj' :: update x obj store

namespace IsVar
  ||| Read an object from our typing environment.
  |||
  ||| @idx Which object.
  ||| @env The execution environment.
  export
  read : (idx : IsVar ctxt t)
      -> (env : Env ty e ctxt)
      -> e t
  read (V 0 Here) (elem :: rest)
    = elem
  read (V (S idx) (There later)) (elem :: rest)
    = read (V idx later) rest

  ||| Add an object to our execution environment.
  |||
  ||| @idx Where the object is.
  ||| @obj The new object.
  ||| @env The environment to which the object is added.
  export
  update : (idx : IsVar ctxt t)
        -> (obj : e t)
        -> (env : Env ty e ctxt)
        -> Env ty e ctxt
  update (V 0 Here) obj (elem :: rest)
    = obj :: rest
  update (V (S k) (There later)) obj (elem :: rest)
    = elem :: update (V k later) obj rest

-- [ EOF ]


module TypedContainers.RBTree.Insert

import Data.Nat
import Data.DPair
import Data.List
import TypedContainers.In
import TypedContainers.LawfulOrd
import TypedContainers.RBTree.Base
import TypedContainers.RBTree.Balance
import TypedContainers.Util.Filter

%default total

GoodBadTree :
  {height : Nat} ->
  {kt : Type} ->
  {kord : LawfulOrd kt} ->
  {keys : List kt} ->
  {vt : kt -> Type} ->
  Color ->
  Type
GoodBadTree c = case c of
  Black => Exists \color' => GoodTree {color = color', height, kt, kord, vt, keys}
  Red => BadTree {height, kt, kord, vt, keys}

mutual
  insertLeft :
    (kord : LawfulOrd kt) =>
    {0 colorLeft : Color} ->
    (k : kt) ->
    vt k ->
    (k' : kt) ->
    {0 kp : In (k' ==) keys} ->
    vt k' ->
    {0 ltEq : compare k k' = LT} ->
    {0 keyslEq : keysl = filter (k' >) keys} ->
    GoodTree {height, color = colorLeft, kt, kord, keys = keysl, vt} ->
    {0 keysrEq : keysr = filter (k' <) keys} ->
    GoodTree {height, color = colorRight, kt, kord, keys = keysr, vt} ->
    (
      GoodBadTree colorLeft {height, kt, kord, vt, keys = filter (k' >) (k :: keys)},
      GoodTree {color = colorRight, height, kt, kord, vt, keys = filter (k' <) (k :: keys)}
    )
  insertLeft k v k' v' l r =
    let l' = insertG' k v l in
    let 0 p1 = reversion1 k k' ltEq in
    let 0 p2 = cong (\case { GT => True; _ => False }) p1 in
    let 0 p3 : (k :: filter (k' >) keys = filter (k' >) (k :: keys)) = rewrite p2 in Refl in
    let l'' : GoodBadTree colorLeft {height, kt, kord, vt, keys = filter (k' >) (k :: keys)} =
      rewrite sym p3 in rewrite sym keyslEq in l'
    in
    let 0 p4 : (k' < k = False) = cong (\case { LT => True; _ => False }) p1 in
    let 0 p5 : (filter (k' <) keys = filter (k' <) (k :: keys)) = rewrite p4 in Refl in
    let r' : GoodTree {color = colorRight, height, kt, kord, vt, keys = filter (k' <) (k :: keys)} =
      rewrite sym p5 in rewrite sym keysrEq in r
    in
    (l'', r')

  insertRight :
    (kord : LawfulOrd kt) =>
    {0 colorLeft : Color} ->
    (k : kt) ->
    vt k ->
    (k' : kt) ->
    {0 kp : In (k' ==) keys} ->
    vt k' ->
    {0 gtEq : compare k k' = GT} ->
    {0 keyslEq : keysl = filter (k' >) keys} ->
    GoodTree {height, color = colorLeft, kt, kord, keys = keysl, vt} ->
    {0 keysrEq : keysr = filter (k' <) keys} ->
    GoodTree {height, color = colorRight, kt, kord, keys = keysr, vt} ->
    (
      GoodTree {color = colorLeft, height, kt, kord, vt, keys = filter (k' >) (k :: keys)},
      GoodBadTree colorRight {height, kt, kord, vt, keys = filter (k' <) (k :: keys)}
    )
  insertRight k v k' v' l r =
    let r' = insertG' k v r in
    let 0 p1 = reversion2 k k' gtEq in
    let 0 p2 = cong (\case { LT => True; _ => False }) p1 in
    let 0 p3 : (k :: filter (k' <) keys = filter (k' <) (k :: keys)) = rewrite p2 in Refl in
    let r'' : GoodBadTree colorRight {height, kt, kord, vt, keys = filter (k' <) (k :: keys)} =
      rewrite sym p3 in rewrite sym keysrEq in r'
    in
    let 0 p4 : (k' > k = False) = cong (\case { GT => True; _ => False }) p1 in
    let 0 p5 : (filter (k' >) keys = filter (k' >) (k :: keys)) = rewrite p4 in Refl in
    let l' : GoodTree {color = colorLeft, height, kt, kord, vt, keys = filter (k' >) (k :: keys)} =
      rewrite sym p5 in rewrite sym keyslEq in l
    in
    (l', r'')

  insertG' :
    {0 color : Color} ->
    (kord : LawfulOrd kt) =>
    (k : kt) ->
    vt k ->
    GoodTree {kt, height, color, kord, vt, keys} ->
    GoodBadTree color {height, kt, kord, vt, keys = k :: keys}
  insertG' k v (Empty Refl) =
    let 0 kp : (In (k ==) (k :: [])) = MkIn k (cong (\case {EQ => True; _ => False}) $ reflexivity k) [] in
    Evidence Red (
      RedNode k v
        (rewrite reflexivity k in Empty Refl)
        (rewrite reflexivity k in Empty Refl)
        {keys = k :: [], kp}
    )
  insertG' k v (RedNode k' v' l r {kp}) =
    case the (Subset Ordering (compare k k' ===)) $ Element (compare k k') Refl of
      Element LT ltEq =>
        let (Evidence color' l', r') = insertLeft k v k' v' l r {ltEq, kp, keyslEq = Refl, keysrEq = Refl} in
        BadRedNode k' v' l' r' {kp = MkInCons k keys kp}
      Element EQ p0 =>
        let
          0 p5 : (x : kt) -> (k > x = k' > x)
          p5 x = cong (\case { GT => True; _ => False }) $ equality1 k k' x p0

          0 p6 : (x : kt) -> (k < x = k' < x)
          p6 x = cong (\case { LT => True; _ => False }) $ equality1 k k' x p0
        in
        let 0 p1 : (filter (k >) keys = (filter (k' >) keys)) = filterExtensionality p5 in
        let 0 p2 : (filter (k >) (k :: keys) = filter (k >) keys)
            = rewrite reflexivity k in Refl in
        let 0 p3 : (filter (k <) keys = (filter (k' <) keys)) = filterExtensionality p6 in
        let 0 p4 : (filter (k <) (k :: keys) = filter (k <) keys)
            = rewrite reflexivity k in Refl in
        let l' : GoodTree {kt, kord, vt, keys = filter (k >) (k :: keys)} =
            rewrite trans p2 p1 in l
        in
        let r' : GoodTree {kt, kord, vt, keys = filter (k <) (k :: keys)} =
            rewrite trans p4 p3 in r
        in
        BadRedNode k v l' r' {kp = MkIn k (cong (\case { EQ => True; _ => False }) (reflexivity k)) keys}
      Element GT gtEq =>
        let (l', Evidence color' r') = insertRight k v k' v' l r {gtEq, kp, keyslEq = Refl, keysrEq = Refl} in
        BadRedNode k' v' l' r' {kp = MkInCons k keys kp}
  insertG' k v (BlackNode k' v' l r {kp, height = height', colorLeft, colorRight}) = case the (Subset Ordering (compare k k' ===)) $ Element (compare k k') Refl of
    Element LT ltEq =>
      case l of
        Empty _ =>
          let (Evidence color' l', r') = insertLeft k v k' v' l r {ltEq, kp, keyslEq = Refl, keysrEq = Refl} in
          Evidence Black $ BlackNode k' v' l' r' {kp = MkInCons k keys kp}
        BlackNode _ _ _ _ =>
          let (Evidence color' l', r') = insertLeft k v k' v' l r {ltEq, kp, keyslEq = Refl, keysrEq = Refl} in
          Evidence Black $ BlackNode k' v' l' r' {kp = MkInCons k keys kp}
        RedNode _ _ _ _ =>
          let (l', r') = insertLeft k v k' v' l r {kp, ltEq, keyslEq = Refl, keysrEq = Refl} in
          balanceLeft k' v' l' r' {kord, zkp = MkInCons _ _ kp}
    Element EQ p0 =>
        let
          0 p5 : (x : kt) -> (k > x = k' > x)
          p5 x = cong (\case { GT => True; _ => False }) $ equality1 k k' x p0

          0 p6 : (x : kt) -> (k < x = k' < x)
          p6 x = cong (\case { LT => True; _ => False }) $ equality1 k k' x p0
        in
        let 0 p1 : (filter (k >) keys = (filter (k' >) keys)) = filterExtensionality p5 in
        let 0 p2 : (filter (k >) (k :: keys) = filter (k >) keys)
            = rewrite reflexivity k in Refl in
        let 0 p3 : (filter (k <) keys = (filter (k' <) keys)) = filterExtensionality p6 in
        let 0 p4 : (filter (k <) (k :: keys) = filter (k <) keys)
            = rewrite reflexivity k in Refl in
        let l' : GoodTree {color = colorLeft, height = height', kt, kord, vt, keys = filter (k >) (k :: keys)} =
            rewrite trans p2 p1 in l
        in
        let r' : GoodTree {color = colorRight, height = height', kt, kord, vt, keys = filter (k <) (k :: keys)} =
            rewrite trans p4 p3 in r
        in
        Evidence Black $ BlackNode k v l' r' {kp = MkIn k (cong (\case { EQ => True; _ => False }) (reflexivity k)) keys}
    Element GT gtEq =>
      case r of
        Empty _ =>
          let (l', Evidence color' r') = insertRight k v k' v' l r {gtEq, kp, keyslEq = Refl, keysrEq = Refl} in
          Evidence Black $ BlackNode k' v' l' r' {kp = MkInCons k keys kp}
        BlackNode _ _ _ _ =>
          let (l', Evidence color' r') = insertRight k v k' v' l r {gtEq, kp, keyslEq = Refl, keysrEq = Refl} in
          Evidence Black $ BlackNode k' v' l' r' {kp = MkInCons k keys kp}
        RedNode _ _ _ _ =>
          let (l', r') = insertRight k v k' v' l r {kp, gtEq, keyslEq = Refl, keysrEq = Refl} in
          balanceRight k' v' l' r' {kord, xkp = MkInCons _ _ kp}

public export
insertG :
  {0 color : Color} ->
  (kord : LawfulOrd kt) =>
  (k : kt) ->
  vt k ->
  GoodTree {kt, height, color, kord, vt, keys} ->
  Exists \color' => Exists \height' => GoodTree {color = color', height = height', kt, kord, vt, keys = k :: keys}
insertG k v tree@(Empty Refl) =
  let Evidence color' tree' = insertG' k v tree in
  Evidence color' $ Evidence 0 tree'
insertG k v tree@(BlackNode _ _ _ _ {height = height'}) =
  let Evidence color' tree' = insertG' k v tree in
  Evidence color' $ Evidence (S height') tree'
insertG k v tree@(RedNode _ _ _ _) =
  let BadRedNode k' v' l r {height = height', kp} = insertG' k v tree in
  Evidence Black $ Evidence (S height') $ BlackNode k' v' l r {kp}


public export
data Fuel = Dry | More (Lazy Fuel)

public export
partial
forever : Fuel
forever = More forever


module Meriv.Core.Ast

import Data.List
import Meriv.Core.Util

-- Schema definition

||| Data needed to define an entity
||| of a particular type.
data EntityDec : (ts : List Nat) -> Type where
  MkEntityDec : Nat -> ( t : Nat ) -> { auto p: t `elem` ts = True } -> EntityDec ts

identifier : EntityDec ts -> Nat
identifier (MkEntityDec i _) = i

type : EntityDec ts -> Nat
type (MkEntityDec _ t) = t

Eq (EntityDec ts) where
  (MkEntityDec x y) == (MkEntityDec z w) =
    x == z && y == w

||| Data needed to declare that a type is a
||| subtype of some other type.
data SubtypeDec : (ts : List Nat) -> Type where
  MkSubtypeDec :
      (subtype : Nat)
   -> { auto p1: subtype `elem` ts = True }
   -> (supertype : Nat)
   -> { auto p2: supertype `elem` ts = True }
   -> SubtypeDec ts

Eq (SubtypeDec ts) where
  (MkSubtypeDec x y) == (MkSubtypeDec z w) =
    x == z && y == w

||| Modes for Meriv relational arguments.
data ModeDecl =
    InM
  | OutM
  | BothM

Eq ModeDecl where
  InM   == InM   = True
  OutM  == OutM  = True
  BothM == BothM = True
  _ == _         = False

mutual
  ||| Part of a Meriv Schema needed for typechecking.
  record MvBaseSchema where
    constructor MkBaseSchema
    extends     : Maybe MvBaseSchema
    types'       : List Nat
    subtypes'    : List (SubtypeDec types')
    entities'    : List (EntityDec types')
    relations'   : case extends of
      Just base => List (RelDecl base)
      Nothing   => ()
    rules'       : case extends of
      Just base => List (RuleDecl base)
      Nothing   => ()

    ||| Data needed to declare a Meriv relation.
  record RelDecl (s : MvBaseSchema) where
    constructor MkRelDecl
    name  : String
    argTypes : List (ModeDecl, MvType s)

  Eq (RelDecl s) where
    (MkRelDecl n xs) == (MkRelDecl m ys) =
      xs == ys && n == m

  ||| Data needed to declare a Meriv rule.
  record RuleDecl (s : MvBaseSchema) where
    constructor MkRuleDecl
    -- TODO: Fix this after implementing terms
    clauses : ()

  Eq (RuleDecl s) where
    (MkRuleDecl _) == (MkRuleDecl _) =
      True

  types : (base: MvBaseSchema) -> List Nat
  types base = base.types' ++ maybe [] types base.extends

  -- TODO: I think I need to use a lemma here to supply the proof manually
  subtypes : (base: MvBaseSchema) -> List (SubtypeDec (types base))
  subtypes base = base.subtypes' ++ maybe [] subtypes base.extends

  lemma_extendSubtypes : (p : subsetList xs ys) -> SubtypeDec xs -> SubtypeDec ys
  lemma_extendSubtypes = _

  entities : (base: MvBaseSchema) -> List (EntityDec (types base))
  entities base = base.entities' ++ maybe [] entities base.extends

  relations : (base: MvBaseSchema) -> List (RelDecl base)
  relations base = case base.extends of
    Just parent => parent.relations' ++ maybe [] relations parent.extends
    Nothing     => []

  rules : (base: MvBaseSchema) -> List (RelDecl base)
  rules base = case base.extends of
    Just parent => parent.rules' ++ maybe [] rules parent.extends
    Nothing     => []

  ||| Type of meriv types, given a particular schema.
  data MvType : MvBaseSchema -> Type where
    IntT    : MvType s
    StringT : MvType s
    DoubleT : MvType s
    EntityT :
        (s : MvBaseSchema)
     -> (t : Nat)
     -> { auto p: t `elem` (types s) = True }
     -> MvType s
    RelT :
        (s : MvBaseSchema)
     -> List (ModeDecl, MvType s)
     -> MvType s
    FuncT    :
        MvType s
     -> MvType s
     -> MvType s
    -- RuleT :
    RecordT :
        Set (String, MvType s)
     -> MvType s
    UnionT :
        Set (String, MvType s)
     -> MvType s

  Eq (MvType s) where
    IntT    == IntT    = True
    StringT == StringT = True
    DoubleT == DoubleT = True
    -- (EntityT x y) == (EntityT z w)
    --   = x == z && y == w
    _ == _ = False

  Ord (MvType s) where
    compare x y = EQ

||| Idris type corresponding to a Meriv entity type
||| in a schema.
data Entity : MvBaseSchema -> Nat -> Type where
  MkEntity  :
      (s : MvBaseSchema)
   -> (t : Nat)
   -> { auto p: ((t `elem` types s) = True) }
   -> Entity s t

mutual
  ||| Implementation of a simple record type for Meriv
  data Record : (f : Type -> Type) -> (s : MvBaseSchema) -> (ts: Set (String, MvType s)) -> Type where
    RNil  : Record f s (mkSet [])
    RCons : (label : String) -> MvExpr f s t -> Record f s ts -> Record f s (ts `add` (label,t))

  ||| Implementation of a simple union type.
  data Union : (f : Type -> Type) -> (s : MvBaseSchema) -> (ts: Set (String, MvType s)) -> Type where
    UEmpty  : Union f s (mkSet [])
    UInj : (label : String) -> MvExpr f s t -> { auto p: (label,t) `elem` ts = True } -> Union f s ts

  data VarF : Type -> Type where
    Var    : Nat -> VarF a
    Ground : a   -> VarF a

  data IdF : Type -> Type where
    Id : a -> IdF a

  ||| A Meriv term is a relation with arguments of types ts,
  ||| applied to a list of expressions in order, correpsonding to
  ||| the types ts.
  |||
  ||| Example:
  |||   rel likes: person, food.
  |||   nate: person.
  |||
  |||   likes(nate, X) is a MvTerm.
  |||
  data MvTerm : (f : Type -> Type) -> (s : MvBaseSchema) -> Type where
    MkTerm    :
        { s : MvBaseSchema }
     -> { ts : List (ModeDecl, MvType s) }
     -> MvExpr f s (RelT s ts)
     -> MvExprs f s (map (\(x,y) => y) ts)
     -> MvTerm f s

  record MvClause (s : MvBaseSchema) where
    constructor MkClause
    head : MvTerm VarF s
    body : List (MvTerm VarF s)

  data MvExprs : (f : Type -> Type) -> (s : MvBaseSchema) -> List (MvType s) -> Type where
    NilExprs : MvExprs f s []
    ConsExpr : MvExpr f s t -> MvExprs f s ts -> MvExprs f s (t :: ts)

  data MvExpr : (f : Type -> Type) -> (s : MvBaseSchema) -> MvType s -> Type where
    AppExp    : MvExpr f s (FuncT a b) -> MvExpr f s a -> MvExpr f s b
    -- QueryExp  : (q : Query s rs) -> (MvExprs IdF s rs -> MvExpr IdF s r) -> MvExpr IdF s r
    BaseExp   : f (MvBaseExpr s a) -> MvExpr f s a

  ||| Type of expressions in the Meriv language
  data MvBaseExpr : (s : MvBaseSchema) -> MvType s -> Type where
    IntExp    : Int         -> MvBaseExpr s IntT
    StringExp : String      -> MvBaseExpr s StringT
    DoubleExp : Double      -> MvBaseExpr s DoubleT
    FuncExp   : (MvBaseExpr s a -> MvBaseExpr s b) -> MvBaseExpr s (FuncT a b)
    RelExp    :
          (s : MvBaseSchema)
       -> (identifier: String)
       -> (ts : List (ModeDecl, MvType s))
       -> { auto p: (MkRelDecl identifier ts) `elem` (relations s) = True }
       -> MvBaseExpr s (RelT s ts)
    -- SchemaExp :
    -- RuleExp   :
    --     (s : MvBaseSchema)
    --   ->
    RecordExp : Record s ts -> MvBaseExpr s (RecordT ts)
    UnionExp  : Union s ts  -> MvBaseExpr s (UnionT ts)
    EntityExp :
         (s : MvBaseSchema)
      -> (e : Nat)
      -> (t : Nat)
      -> { auto p1: t `elem` (types s) = True }
      -> { auto p2: MkEntityDec e t `elem` entities s = True }
      -> MvBaseExpr s (EntityT s t)
    InjectEntitySub :
         (s : MvBaseSchema)
      -> (x : Nat) -> { auto p1: x `elem` (types s) = True }
      -> (y : Nat) -> { auto p2: y `elem` (types s) = True }
      -> MvBaseExpr s (EntityT s x)
      -> MvBaseExpr s (EntityT s y)

evaluate : {s : MvBaseSchema} -> {a : MvType s} -> MvExpr IdF s a -> MvExpr IdF s a
evaluate (AppExp (FuncExp f) x) = evaluate $ f x
evaluate x = x

||| Information needed to declare an implcit conversion
||| of Meriv types.
record ConversionDec (s : MvBaseSchema) where
  constructor MkConversionDec
  fromType   : MvType s
  toType     : MvType s
  conversion : MvBaseExpr s fromType -> MvBaseExpr s toType

Eq (ConversionDec s) where
  (MkConversionDec x y _) == (MkConversionDec z w _) =
    x == z && y == w

||| A full schema for the meriv language.
record MvSchema where
  constructor MkSchema
  base  : MvBaseSchema
  conversions : List (ConversionDec base)

||| Evidential subtype relation for Meriv types.
data Subtype : (s : MvSchema) -> MvType (base s) -> MvType (base s) -> Type where
  -- Any type is a sub-type of itself.
  ReflSub  : Subtype s t t
  -- Subtyping is a transitive relation.
  TransSub : {x,y,z : _ } -> Subtype s x y -> Subtype s y z -> Subtype s x z
  -- Subtyping can be preformed by an implicit conversion.
  Inject   :
      (s : MvSchema)
   -> (x : MvType (base s))
   -> (y : MvType (base s))
   -> (z : MvBaseExpr (base s) x -> MvBaseExpr (base s) y)
   -> { auto p: (MkConversionDec x y z) `elem` conversions s = True }
   -> Subtype s x y
  -- Subtyping can be preformed by specifyin a subtype for
  -- an entity type.
  EntitySub :
      (s : MvSchema)
   -> (x : Nat)
   -> (y : Nat)
   -> { auto p1: x `elem` types (base s) = True }
   -> { auto p2: y `elem` types (base s) = True }
   -> { auto p3: MkSubtypeDec x y `elem` subtypes (base s) = True }
   -> Subtype s (EntityT (base s) x {p=p1}) (EntityT (base s) y {p=p2})

||| Helper function to preform a conversion from a subtype to it's supertype,
||| given evidence (Subtype s x y) that a term is a subtype of another term
||| according to the given schema.
convertTerm :
      { s: MvSchema }
   -> { x, y: _ }
   -> Subtype s x y
   -> MvBaseExpr (base s) x
   -> MvBaseExpr (base s) y
convertTerm ReflSub
  = \t => t
convertTerm (TransSub t1 t2)
  = convertTerm t2 . convertTerm t1
convertTerm (Inject s x y f)
  = f
convertTerm (EntitySub s x y)
  = InjectEntitySub (base s) x y

-- Examples

-- myType : Nat
-- myType = 0

-- schema : MvBaseSchema
-- schema = MkBaseSchema Nothing [myType] [] [MkEntityDec 0 myType, MkEntityDec 1 myType] () []

-- Note: For some reason, idris2 doesn't like it when I put variables in types -- it treats them like a hole.
-- exampleTerm : MvExpr (MkBaseSchema Nothing [myType] [] [MkEntityDec 0 myType, MkEntityDec 1 myType] () []) (MkBaseSchema Nothing [myType] [] [MkEntityDec 0 myType, MkEntityDec 1 myType] () [])
-- exampleTerm = EntityExp schema 1 0

(+) : MvExpr s (FuncT IntT (FuncT IntT IntT))
(+) = FuncExp (\(IntExp x) => FuncExp $ \(IntExp y) => IntExp $ x + y)

main : IO ()
main = do
  let (IntExp x) = the (MvExpr (MkBaseSchema [] [] []) IntT) $
     evaluate $ AppExp (AppExp (+) (IntExp 2)) (IntExp 2)
  printLn x


module Sub08Apply108x63

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(36x+21) --F[5,-2]->B[1,-2]--> 3(16x+9)
export
apply108x63 : (Not . P) (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                                    (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                              (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))))
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                        (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                  (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))),
         (Not . P) m))
apply108x63 {o} col = ((S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))
                                                           ** (lte108x63 o, fb108x63To48x27 o col)) where
  lte108x63 : (o:Nat) -> LTE (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                              (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))))
          (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))))
  lte108x63 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x63 (S o) = let lemma = lte108x63 o in
    rewrite (sym (plusSuccRightSucc o o)) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))) in

    rewrite (sym (plusSuccRightSucc (plus o o)  o)) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (S (S (plus (plus o o) o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (S (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (plus (plus o o) o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (S (plus (plus o o) o)))  (S (S (S (S (S (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (S (plus (plus o o) o)))  (S (S (S (S (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (S (plus (plus o o) o)))  (S (S (S (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (S (plus (plus o o) o)))  (S (S (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (S (plus (plus o o) o)))  (S (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (S (plus (plus o o) o)))  (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o))))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                          (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                    (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o))))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o)))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                      (S (plus (plus o o) o)))
                                                (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))
                                          (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                      (S (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))
                                    (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                                                                o)))))))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module tipos

import Data.SortedMap

%access public export

data Id = ValID String

data AExp = Sum AExp AExp | Sub AExp AExp | Div AExp AExp | Mul AExp AExp | N Int | ID Id

data BExp = Equal AExp AExp | Not BExp | LT AExp AExp | GT AExp AExp | LE AExp AExp | GE AExp AExp | And BExp BExp | OR BExp BExp | Boo Bool

data Exp = AExpR AExp | BExpR BExp | Ref Exp | DeRef Id | ValRef Id

data Dec = Bind Id Exp | DSeq Dec Dec

data Cmd = Assign Id Exp | Loop BExp Cmd | Cond BExp Cmd Cmd | CSeq Cmd Cmd | Blk Dec Cmd | NOP

data CmdOp = CtrlAssign | CtrlLoop | CtrlCond | CtrlCSeq | CtrlBlkDec | CtrlBlkCmd

data ExpOp = CtrlSum | CtrlSub | CtrlDiv | CtrlMul | CtrlNot | CtrlLT | CtrlGT | CtrlLE | CtrlGE | CtrlAnd | CtrlOR | CtrlEqual | CtrlRef | CtrlCns

data DecOp = CtrlBind | CtrlDSeq

data Ctrl = CtExp Exp | CtExpOp ExpOp | CtCmd Cmd | CtDec Dec | CtCmdOp CmdOp | CtDecOp DecOp

data Loc = L Int

data Val = ValInt Int | ValBool Bool | ValId String | ValCmd Cmd | ValLoc Loc | ValListLoc (List Loc) | ValEnv (SortedMap Val Loc) |ValNop

--
-- implementation Equal Loc where
--   (L a) == (L b) = a == b
--   (L a) /= (L b) = a /= b
--
-- implementation Ord Loc where
--   compare (L a) (L b) = compare a b
--
--
-- implementation Equal Val where
--     (ValId a) == (ValId b) = a == b
--
-- implementation Ord Val where
--     compare (ValId a) (ValId b) = compare a b

implementation Show Id where
  show (ValID x) = "ValID " ++ show x

implementation Show AExp where
  show (Sum a b) = "Sum (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (Sub a b) = "Sub (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (Mul a b) = "Mul (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (Div a b) = "Div (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (N a) = "N " ++ show a
  show (ID a) = "ID " ++ show a

implementation Show BExp where
  show (Equal a b) = "Equal (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (GT a b) = "GT (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (LT a b) = "LT (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (LE a b) = "LE (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (GE a b) = "GE (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (And a b) = "And (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (OR a b) = "OR (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
  show (Boo a) = "Boo " ++ show a
  show (Not a) = "Not " ++ show a

implementation Show Exp where
  show (AExpR a) = "AExpR (" ++ show a ++ ")"
  show (BExpR a) = "BExpR " ++ show a
  show (Ref a) = "Ref " ++ show a
  show (DeRef id) = "DeRef " ++ show id
  show (ValRef id) = "ValRef " ++ show id

implementation Show Dec where
  show (Bind a b) = "Bind " ++ show a ++ " " ++ show b
  show (DSeq a b) = "DSeq " ++ show a ++ " " ++ show b

implementation Show Cmd where
  show (Assign id exp) = "Assign " ++ show id ++ " " ++ show exp
  show (Loop b c) = "Loop " ++ show b ++ " " ++ show c
  show (Cond b c1 c2) = "Cond " ++ show b ++ " " ++ show c1 ++ " " ++ show c2
  show (CSeq c1 c2) = "CSeq " ++ show c1 ++ " " ++ show c2
  show (Blk d c) = "Blk " ++ show d ++ " " ++ show c
  show (NOP) = "NOP"

implementation Show CmdOp where
  show CtrlAssign = "CtrlAssign"
  show CtrlLoop = "CtrlLoop"
  show CtrlCond = "CtrlCond"
  show CtrlCSeq = "CtrlCSeq"
  show CtrlBlkDec = "CtrlBlkDec"
  show CtrlBlkCmd = "CtrlBlkCmd"

implementation Show ExpOp where
  show CtrlSum = "CtrlSum"
  show CtrlSub = "CtrlSub"
  show CtrlDiv = "CtrlDiv"
  show CtrlMul = "CtrlMul"
  show CtrlNot = "CtrlNot"
  show CtrlLT = "CtrlLT"
  show CtrlGT = "CtrlGT"
  show CtrlLE = "CtrlLE"
  show CtrlGE = "CtrlGE"
  show CtrlAnd = "CtrlAnd"
  show CtrlOR = "CtrlOR"
  show CtrlEqual = "CtrlEqual"
  show CtrlRef = "CtrlRef"
  show CtrlCns = "CtrlCns"

implementation Show DecOp where
  show CtrlBind = "CtrlBind"
  show CtrlDSeq = "CtrlDSeq"

implementation Show Ctrl where
  show (CtExp a) = "CtExp (" ++ show a ++ ")"
  show (CtExpOp a) = "CtExpOp " ++ show a
  show (CtCmd a) = "CtCmd " ++ show a
  show (CtDec a) = "CtDec " ++ show a
  show (CtCmdOp a) = "CtCmdOp " ++ show a
  show (CtDecOp a) = "CtDecOp " ++ show a

implementation Show Loc where
  show (L a) = "L " ++ show a

implementation Show Val where
  show (ValInt a) = "ValInt " ++ show a
  show (ValBool b) = "ValBool " ++ show b
  show (ValId a) = "ValId " ++ show a
  show (ValCmd a) = "ValCmd " ++ show a
  show (ValLoc a) = "ValLoc " ++ show a
  show (ValListLoc a) = "ValListLoc " ++ show a
  show (ValEnv map) = "ValEnv" ++ show (toList map)
  show ValNop = "ValNop"


-- Copyright (c) 2013 Radek Micek

module Solver

import Algo

partial
hd : List a -> a
hd (x :: _) = x
-- missing case: hd []

partial
tl : List a -> List a
tl (_ :: xs) = xs
-- missing case: tl []

partial
fromJust : Maybe a -> a
fromJust (Just x) = x
-- missing case: fromJust Nothing

groupBy : (a -> a -> Bool) -> List a -> List (List a)
groupBy _ [] = []
groupBy eq (x :: xs) =
  let (ys, zs) = span (eq x) xs in
  (x :: ys) :: groupBy eq zs

Var : Type
Var = String

data Sign = Pos | Neg

instance Eq Sign where
  Pos == Pos = True
  Neg == Neg = True
  _ == _ = False

instance Ord Sign where
  compare Pos Pos = EQ
  compare Neg Neg = EQ
  compare Pos Neg = LT
  compare Neg Pos = GT

data Lit = MkLit Sign Var

instance Eq Lit where
  (MkLit sign var) == (MkLit sign' var') = sign == sign' && var == var'

instance Ord Lit where
  compare (MkLit s v) (MkLit s' v') =
    case compare s s' of
      LT => LT
      GT => GT
      EQ => compare v v'

instance Show Lit where
  show (MkLit Pos lit) = lit
  show (MkLit Neg lit) = strCons '~' lit

data CId = MkCId Nat

instance Eq CId where
  (MkCId x) == (MkCId y) = x == y

-- Must not contain any duplicate literals.
data Clause = MkClause CId (List Lit)

-- Decision level.
Level : Type
Level = Nat

Ante : Type
Ante = CId

Trail : Type
Trail = List (Lit, Maybe Ante, Level)

data Operation
  = OOther
  -- Current conflict clause, original conflict clause, processed variables.
  | OLearn (List Lit) Clause (List Var)
  | OMinimize (List Lit)
  -- Processed clauses, remaining clauses.
  | OPropagate (List Clause) (List Clause)

-- Solver state.
record Sol : Type where
  MkSol : (sClauses : List Clause) ->
          (sLevel : Level) ->
          (sTrail : Trail) ->
          (sOp : Operation) ->
          -- Corresponding clauses contain negations of the literals.
          (sWatched : List (CId, (Lit, Lit))) ->
          (sChosen : Maybe Lit) ->
          (sEnableMinimization : Bool) ->
          (sEnableWatchedLits : Bool) ->
          Sol

data Event
  -- Nonempty list of unassigned variables.
  = EChoose (List Var)
  | EDecide Lit
  | EProp Lit Clause
  | EConfl Clause
  | EWShortClause Lit Clause
  | EWPropLitStart Lit
  -- Watched literal which is being propagated,
  -- other watched literal which is true, clause.
  | EWOtherLitTrue Lit Lit Clause
  -- Watched literal which is being propagated,
  -- not watched literal which is not false, clause.
  | EWReplaceLit Lit Lit Clause
  -- Watched literal which is being propagated,
  -- other watched literal which is false, clause.
  | EWConfl Lit Lit Clause
  -- Watched literal which is being propagated,
  -- other watched literal which is unassigned, clause.
  | EWProp Lit Lit Clause
  | EAnalyzeStart Clause
  -- Variable to be resolved on, current conflict clause,
  -- antecedent clause of the variable, resolvent.
  | EResolve Var (List Lit) Clause (List Lit)
  | ESkip Var (List Lit) Clause
  | EAnalyzeEnd (List Lit)
  -- Candidates for removal, asserting clause.
  | EMinStart (List Lit) (List Lit)
  | ETestRedundant Lit (List Lit)
  | ERedundant Lit (List Lit)
  | ENotRedundant Lit (List Lit)
  -- Redundant literals, original asserting clause,
  -- minimized asserting clause.
  | EMinEnd (List Lit) (List Lit) (List Lit)
  | ELearn Clause
  | EBacktrack Lit (Maybe Clause)

SatAlgo : Type -> Type -> Type
SatAlgo = Algo Sol Event

data LBool = LTrue | LFalse | LUndef

instance Eq LBool where
  LTrue == LTrue = True
  LFalse == LFalse = True
  LUndef == LUndef = True
  _ == _ = False

Assignment : Type
Assignment = Lit -> LBool

emptySol : Sol
emptySol = MkSol [] 0 [] OOther [] Nothing True True

negLit : Lit -> Lit
negLit (MkLit Pos l) = MkLit Neg l
negLit (MkLit Neg l) = MkLit Pos l

getLits : Clause -> List Lit
getLits (MkClause _ lits) = lits

findInTrail : Var -> Trail -> Maybe (Lit, Maybe Ante, Level)
findInTrail var = find (\(MkLit _ v, _, _) => v == var)

findClause : CId -> List Clause -> Clause
findClause cid = fromJust . find (\(MkClause cid' _) => cid == cid')

trailToAssig : Trail -> Assignment
trailToAssig trail l =
  let (MkLit _ var) = l in
  case findInTrail var trail of
    Nothing => LUndef
    Just (l', _, _) => if l == l' then LTrue else LFalse

data Prop = Unit Lit | Conflict

testClause : Assignment -> Clause -> Maybe Prop
testClause assig (MkClause _ lits) =
  if sat then
    Nothing
  else
    -- Note: nub is redundant when clause has no duplicate literals.
    case List.nub $ filter ((== LUndef) . assig) lits of
      [] => Just Conflict
      [l] => Just $ Unit l
      _ => Nothing
  where
    sat = not $ isNil $ filter ((== LTrue) . assig) lits

-- Manages decision level.
assign : Lit -> Maybe Ante -> SatAlgo r ()
assign l ante = do
  s <- get
  let trail = sTrail s
  let lvl : Nat =
    case ante of
      Nothing => sLevel s + 1
      Just _ => sLevel s
  put (record { sTrail = (l, ante, lvl) :: trail, sLevel = lvl } s)

findClauseToProp : Assignment -> List Clause -> Maybe (Clause, Prop)
findClauseToProp _ [] = Nothing
findClauseToProp assig (c::cs) =
  case testClause assig c of
    Just p => Just (c, p)
    Nothing => findClauseToProp assig cs

-- Unit propagation. Returns conflict clause.
propagate : SatAlgo r (Maybe Clause)
propagate = do
  s <- get
  let assig = trailToAssig $ sTrail s
  let clauses = sClauses s
  let clause = findClauseToProp assig clauses
  case clause of
    Just (cl, Unit l) => do
      let MkClause cid _ = cl
      assign l $ Just cid
      interrupt $ EProp l cl
      propagate
    Just (cl, Conflict) => return $ Just cl
    Nothing => return Nothing

wpropagate : SatAlgo r (Maybe Clause)
wpropagate = do
    confl <- propagateShort
    case confl of
      Just _ => return confl
      _ => firstLit >>= propagateWatched
  where
    findShortToProp : Assignment -> List Clause -> Maybe (Clause, Prop)
    findShortToProp _ [] = Nothing
    findShortToProp _ (MkClause cid [] :: _) =
      Just (MkClause cid [], Conflict)
    findShortToProp assig (MkClause cid [l] :: cs) =
      case assig l of
        LTrue => findShortToProp assig cs
        LFalse => Just (MkClause cid [l], Conflict)
        LUndef => Just (MkClause cid [l], Unit l)
    findShortToProp assig (_ :: cs) = findShortToProp assig cs

    propagateShort : SatAlgo r (Maybe Clause)
    propagateShort = do
      s <- get
      if sLevel s == 0 then
        case findShortToProp (trailToAssig $ sTrail s) (sClauses s) of
          Nothing => return Nothing
          -- There should be no empty clause.
          Just (cl, Conflict) => return $ Just cl
          Just (MkClause cid lits, Unit l) => do
            assign l $ Just cid
            interrupt $ EWShortClause l $ MkClause cid lits
            propagateShort
      else
        return Nothing

    -- The first literal in the propagation queue.
    firstLit : SatAlgo r (Maybe Lit)
    firstLit = do
      s <- get
      case dropWhile (\(_, _, lvl) => lvl /= sLevel s) $ reverse (sTrail s) of
        [] => return $ Nothing
        (l, _, _) :: _ => return $ Just l

    -- Next literal in the propagation queue.
    nextLit : Lit -> SatAlgo r (Maybe Lit)
    nextLit lit = do
      s <- get
      case dropWhile (\(l, _, _) => l /= lit) $ reverse (sTrail s) of
        _ :: (l, _, _) :: _ => return $ Just l
        _ => return Nothing

    propagateWatched : Maybe Lit -> SatAlgo r (Maybe Clause)
    -- Propagation queue is empty.
    propagateWatched Nothing = return Nothing
    propagateWatched (Just lit) = do
        s <- get

        -- Find clauses where lit is watched.
        let clauses : List Clause =
          map (\(cid, _) => findClause cid $ sClauses s)
            $ filter (\(cid, (l, l')) => l == lit || l' == lit)
            $ sWatched s

        putOp [] clauses

        interrupt $ EWPropLitStart (negLit lit)

        confl <- propClauses [] clauses
        case confl of
          Nothing => nextLit lit >>= propagateWatched
          confl => return confl
      where
        putOp : List Clause -> List Clause -> SatAlgo r ()
        putOp proc remaining = do
          s <- get
          case remaining of
            [] => put (record { sOp = OOther } s)
            _ :: _ => put (record { sOp = OPropagate proc remaining } s)
        propClauses : List Clause -> List Clause -> SatAlgo r (Maybe Clause)
        propClauses proc [] = return Nothing
        propClauses proc (c :: cs) = do
          putOp (c :: proc) cs
          s <- get

          let (MkClause cid lits) = c
          let (_, (wl, wl')) = fromJust
                                 $ List.find (\(cid', _) => cid == cid')
                                 $ sWatched s
          let lit' = (wl == lit) ? wl' : wl
          let assig = trailToAssig $ sTrail s

          case assig $ negLit lit' of
            LTrue => do
              interrupt $ EWOtherLitTrue (negLit lit) (negLit lit') c
              propClauses (c :: proc) cs
            a =>
              -- Find replacement for lit.
              case
                find (\l => negLit l /= lit &&
                            negLit l /= lit' &&
                            assig l /= LFalse)
                     lits
              of
                Just newLit => do
                  -- Replace watched literal.
                  s2 <- get
                  let (ws, ws') = List.break (\(cid', _) => cid == cid')
                                    $ sWatched s2
                  let watched : List (CId, (Lit, Lit)) =
                    ws ++ ((cid, (negLit newLit, lit')) :: tl ws')
                  put (record { sWatched = watched } s2)

                  interrupt $ EWReplaceLit (negLit lit) newLit c
                  propClauses (c :: proc) cs
                Nothing =>
                  if a == LFalse then do
                    putOp (c :: proc) []
                    interrupt $ EWConfl (negLit lit) (negLit lit') c
                    return $ Just c
                  else do
                    assign (negLit lit') $ Just cid
                    interrupt $ EWProp (negLit lit) (negLit lit') c
                    propClauses (c :: proc) cs

unassignedVars : Assignment -> List Clause -> List Var
unassignedVars assig clauses =
  filter ((== LUndef) . assig . MkLit Pos) vars
  where
    varsInClause : Clause -> List Var
    varsInClause (MkClause _ lits) = nub $ map (\(MkLit _ var) => var) lits
    vars : List Var
    vars = nub $ concatMap varsInClause clauses

choose : SatAlgo r (Maybe Lit)
choose = do
  s <- get
  let vars = unassignedVars (trailToAssig $ sTrail s) (sClauses s)

  case vars of
    [] => return Nothing
    _ :: _ =>
      case sChosen s of
        Nothing => do
          interrupt $ EChoose vars
          choose
        Just (MkLit sign v) => do
          put (record { sChosen = Nothing } s)
          if v `elem` vars then
            return $ Just $ MkLit sign v
          -- Chosen literal isn't among unassigned literals.
          else
            choose

addClause' : List Lit -> Maybe (Lit, Lit) -> SatAlgo r Clause
addClause' lits watch = do
  s <- get
  let clauses = sClauses s
  let cid = MkCId $ length clauses + 1
  let cl = MkClause cid lits
  let watched =
    if sEnableWatchedLits s then
      case watch of
        Just (l, l') => sWatched s ++ [(cid, (negLit l, negLit l'))]
        Nothing =>
          case lits of
            l :: l' :: _ => sWatched s ++ [(cid, (negLit l, negLit l'))]
            _ => sWatched s
    else
      sWatched s
  put (record { sClauses = clauses ++ [cl], sWatched = watched } s)
  return cl

addClause : List Lit -> SatAlgo r Clause
addClause lits = addClause' lits Nothing

-- Literal must be assigned.
litToLevel : Trail -> Lit -> Level
litToLevel trail (MkLit _ v) = level $ fromJust $ findInTrail v trail
  where
    level (_, _, l) = l

litRedundant : List Lit -> Lit -> SatAlgo r Bool
litRedundant assertingCl = \l => get >>= litRedundant' (negLit l)
  where
    -- Literal must be in the trail (i.e. it must be true).
    litRedundant' : Lit -> Sol -> SatAlgo r Bool
    litRedundant' literal s = do
        let (MkLit _ variable) = literal
        let (_, antecedent, _) = fromJust $ findInTrail variable $ sTrail s
        let anteLits = getLits $ findClause (fromJust antecedent) $ sClauses s
        let queue = List.map negLit $ filter (/= literal) anteLits
        let (b, highlight) = bfs queue $ map (\l => (l, Nothing)) queue

        put (record { sOp = OMinimize highlight } s)
        interrupt $ ETestRedundant (negLit literal) assertingCl

        put (record { sOp = OOther } s)
        if b then
          interrupt $ ERedundant (negLit literal) assertingCl
        else
          interrupt $ ENotRedundant (negLit literal) assertingCl

        return b
      where
        Redundant : Type
        Redundant = Bool
        Marked : Type
        Marked = (Lit, Maybe Lit)
        bfs : List Lit -> List Marked -> (Redundant, List Lit)
        bfs [] marked = (True, map fst marked) -- Literal is redundant.
        bfs (q :: qs) marked =
          -- Literal ~q is in asserting clause.
          if negLit q `elem` assertingCl then
            bfs qs marked
          else
            let (MkLit _ var) = q in
            case fromJust $ findInTrail var (sTrail s) of
              -- Literal isn't redundant.
              (_, Nothing, _) => (False, constructPath q)
              (_, Just _, O) => bfs qs marked
              (_, Just cid, _) =>
                let newLits : List Lit =
                  filter (\l => all ((/= l) . fst) marked) -- l is not marked.
                    $ map negLit
                    $ filter (/= q)
                    $ getLits
                    $ findClause cid (sClauses s) in
                -- Add antecedents to the queue and mark them.
                bfs
                  (qs ++ newLits)
                  (marked ++ map (\l => (l, Just q)) newLits)
          where
            constructPath : Lit -> List Lit
            constructPath lit =
              case fromJust $ find (\(l, _) => l == lit) marked of
                (_, Nothing) => [lit]
                (_, Just l) => lit :: constructPath l

-- Common.filterM doesn't work for some reason.
filterM' : (a -> SatAlgo r Bool) -> List a -> SatAlgo r (List a)
filterM' _ [] = return List.Nil
filterM' p (x :: xs) = do
  b <- p x
  ys <- filterM' p xs
  return (b ? List.(::) x ys : ys)

minimize : List Lit -> SatAlgo r (List Lit)
minimize assertingCl = do
    s <- get

    let candidates : List Lit =
      map (negLit . getLit)
        -- Skip decided literals.
        $ filter (\(_, ante, _) => isJust ante)
        -- Skip literal from current decision level.
        $ filter (\(_, _, lvl) => sLevel s /= lvl)
        $ List.map fromJust
        $ List.map (\(MkLit _ var) => findInTrail var $ sTrail s) assertingCl

    interrupt $ EMinStart candidates assertingCl

    redundant <- filterM' (litRedundant assertingCl) candidates
    let newAssertingCl = filter (\l => List.all (/= l) redundant) assertingCl

    interrupt $ EMinEnd redundant assertingCl newAssertingCl

    return newAssertingCl
  where
    getLit : (Lit, Maybe Ante, Level) -> Lit
    getLit (l, _, _) = l

isAsserting : List Lit -> Level -> Trail -> Bool
isAsserting lits level trail = (List.length $ filter (== level) levels) == 1
  where
      levels : List Nat
      levels = map (litToLevel trail) $ nub lits

-- Returns a learned clause.
-- If decision level > 0 then the learned clause is nonempty.
analyzeConflict : Clause -> SatAlgo r (List Lit)
analyzeConflict conflClause = do
    let conflLits = getLits conflClause
    s <- get
    put (record { sOp = OLearn conflLits conflClause [] } s)
    interrupt $ EAnalyzeStart conflClause
    assertingLits <- resolve s (sTrail s) conflLits []
    put (record { sOp = OOther } s)
    interrupt $ EAnalyzeEnd assertingLits
    return assertingLits
  where
    partial
    resolve : Sol -> Trail -> List Lit -> List Var -> SatAlgo r (List Lit)
    resolve s trail lits procVars =
      if isAsserting lits (sLevel s) (sTrail s) then
        return lits
      else
        case trail of
          (MkLit _ var, Just ante, _) :: ts => do
            let procVars' = var :: procVars
            let anteCl = findClause ante $ sClauses s
            if find (\(MkLit _ v) => v == var) lits == Nothing then do
              put (record { sOp = OLearn lits conflClause procVars' } s)
              interrupt $ ESkip var lits anteCl
              resolve s ts lits procVars'
            -- var is among lits, so we resolve it out.
            else do
              let anteLits = getLits anteCl
              let resolvent =
                List.nub
                  $ filter (\(MkLit _ v) => v /= var)
                  $ lits ++ anteLits
              put (record { sOp = OLearn resolvent conflClause procVars' } s)
              interrupt $ EResolve var lits anteCl resolvent
              resolve s ts resolvent procVars'
          -- missing case: []

-- Assumes that every literal in the clause is assigned.
computeBacktrackLevel : List Lit -> Trail -> (Level, Maybe (Lit, Lit))
computeBacktrackLevel lits trail =
  case groupBy sameLevel $ reverse $ sort lits' of
    ((_, l) :: _) :: ((lvl, l') :: _) :: _ => (lvl, Just (l, l'))
    _ => (0, Nothing)
  where
    lits' : List (Level, Lit)
    lits' = map (\l => (litToLevel trail l, l)) lits
    sameLevel : (Level, Lit) -> (Level, Lit) -> Bool
    sameLevel (l, _) (l2, _) = l == l2

backtrack : Level -> SatAlgo r ()
backtrack level = do
  s <- get
  let trail = sTrail s
  case trail of
    (lit, ante, l) :: ts =>
      if l > level then do
        put (record { sTrail = ts } s)
        let cl = [| findClause ante (pure $ sClauses s) |]
        interrupt (EBacktrack lit cl)
        backtrack level
      else
        put $ record { sLevel = level } s
    [] =>
      put $ record { sLevel = level } s

data Result = Sat | Unsat

instance Eq Result where
  Sat == Sat = True
  Unsat == Unsat = True
  _ == _ = False

instance Show Result where
  show Sat = "Sat"
  show Unsat = "Unsat"

solve : SatAlgo r Result
solve = do
  conflCl <- get >>= (\s => (sEnableWatchedLits s) ? wpropagate : propagate)
  case conflCl of
    Nothing => do
      lit <- choose
      case lit of
        -- All variables are assigned.
        Nothing => return Sat
        Just l => do
          assign l Nothing
          interrupt (EDecide l)
          solve
    Just confl => do
      interrupt (EConfl confl)
      s <- get
      if sLevel s == 0 then
        return Unsat
      else do
        assertingCl <- analyzeConflict confl
        assertingCl' <-
          (sEnableMinimization s) ? minimize assertingCl : return assertingCl
        let (blevel, watch) = computeBacktrackLevel assertingCl' (sTrail s)
        learned <- addClause' assertingCl' watch
        interrupt (ELearn learned)
        backtrack blevel
        solve

-- ---------------------------------------------------------------------------
-- Parser

whitespace : Char -> Bool
whitespace c = c == ' ' || c == '\t' || c == '\n' || c == '\r'

asciiIdent : String -> Bool
asciiIdent s with (unpack s)
  asciiIdent _ | [] = False
  asciiIdent _ | (x :: xs) = asciiAlphaUsc x && all asciiAlphaNumUsc xs
  where
    asciiAlphaUsc : Char -> Bool
    asciiAlphaUsc c =
      (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || c == '_'
    asciiAlphaNumUsc : Char -> Bool
    asciiAlphaNumUsc c = asciiAlphaUsc c || (c >= '0' && c <= '9')

parseLit' : List Char -> Either String Lit
parseLit' str =
  case lit of
    MkLit _ v =>
      if not $ asciiIdent v then
        Left $ "Invalid identifier: '" ++ v ++ "'"
      else
        Right lit
  where
    str' : List Char
    str' = filter (not . whitespace) str
    lit : Lit
    lit =
      case str' of
        '~' :: var => MkLit Neg (pack var)
        '!' :: var => MkLit Neg (pack var)
        var => MkLit Pos (pack var)

-- Tolerates literal separator after the last literal.
parseLits' : List Char -> Either String (List Lit)
parseLits' str =
  if all whitespace str then
    Right []
  else
    let (litStr, restStr) = break litSep str in
    case (parseLit' litStr, parseLits' $ drop 1 restStr) of
      (Left err, _) => Left err
      (_, Left err) => Left err
      (Right l, Right ls) => Right $ l :: ls
  where
    litSep : Char -> Bool
    litSep c = c == ',' || c == '|' || c == ';'

parseLit : String -> Either String Lit
parseLit = parseLit' . unpack

parseLits : String -> Either String (List Lit)
parseLits = parseLits' . unpack


module Circuits.NetList.Linear.Terms

import Decidable.Equality

import Data.Nat
import Data.List.Elem
import Data.List.Quantifiers

import Data.Vect
import Data.Vect.Quantifiers

import Data.String

import Toolkit.Data.Whole

import Circuits.Common

import Circuits.NetList.Types
import Circuits.NetList.Linear.Usage

%default total

public export
data Term : (start : List Item)
         -> (item  : Ty)
         -> (next  : List Item)
                   -> Type
  where
    -- ## Vars
    VarPort : (prf : IsFreePort (I (TyPort (flow,type)) u) ctxt_a)
           -> (use : UsePort ctxt_a prf ctxt_b)
                  -> Term ctxt_a
                          (TyPort (flow,type))
                          ctxt_b

    -- ## Structure

    Port : (flow : Direction)
        -> (type : DType)
        -> (urgh : FreePort flow type item)
        -> (body : Term (item :: ctxt)
                        TyUnit
                        Nil)
                -> Term ctxt TyUnit Nil

    Wire : (type : DType)
        -> (urgh : FreeChan type item)
        -> (body : Term (item :: ctxt)
                        TyUnit
                        Nil)
                -> Term ctxt TyUnit Nil

    Gate : (gate : Term this TyGate that)
        -> (body : Term (I TyGate TyGate :: that)
                        TyUnit
                        Nil)
                -> Term this TyUnit Nil

    Stop : (prf : All CanStop ctxt)
               -> Term ctxt TyUnit Nil

    -- ## Gates

    Mux : (out  : Term a (TyPort (OUTPUT, LOGIC)) b)
       -> (ctrl : Term b (TyPort (INPUT,  LOGIC)) c)
       -> (inA  : Term c (TyPort (INPUT,  LOGIC)) d)
       -> (inB  : Term d (TyPort (INPUT,  LOGIC)) e)
               -> Term a  TyGate                  e

    GateU : (kind : Unary.Kind)
         -> (out  : Term a (TyPort (OUTPUT, LOGIC)) b)
         -> (inA  : Term b (TyPort (INPUT,  LOGIC)) c)
                 -> Term a TyGate                   c

    GateB : (kind : Binary.Kind)
         -> (out  : Term a (TyPort (OUTPUT, LOGIC)) b)
         -> (inA  : Term b (TyPort (INPUT,  LOGIC)) c)
         -> (inB  : Term c (TyPort (INPUT,  LOGIC)) d)
                 -> Term a TyGate                   d

    -- ## For linearity

    Split : (outA : Term a (TyPort (OUTPUT,LOGIC)) b)
         -> (outB : Term b (TyPort (OUTPUT,LOGIC)) c)
         -> (inp  : Term c (TyPort (INPUT, LOGIC)) d)
                 -> Term a TyGate                  d

    Collect : {type : DType}
           -> (out  : Term a (TyPort (OUTPUT,BVECT (W (S (S Z)) ItIsSucc) type)) b)
           -> (inA  : Term b (TyPort (OUTPUT,type)) c)
           -> (inB  : Term c (TyPort (INPUT, type)) d)
                   -> Term a TyGate                  d

    -- ## Port Manipulation & Channel Projection

    Cast : (cast : Cast INOUT flow)
        -> (port : Term a (TyPort (INOUT, type)) b)
                -> Term a (TyPort (flow,  type)) b

    Project : (how : Project dir)
           -> (prf : IsFreeChannel how (I (TyChan type) (TyChan ein eout)) this)
           -> (use : ProjectChannel how this prf that)
                  -> Term this (TyPort (dir,type)) that

    Index : (idir : Index flow)
         -> (idx : Fin a)
         -> (prf : CanIndexPort idx (I (TyPort (flow, BVECT (W (S n) ItIsSucc) type)) u) this)
         -> (use : IndexPort idx this prf that)
                -> Term this (TyPort (flow,type)) that

-- [ EOF ]


-- ----------------------------------------------------------- [ Structure.idr ]
-- Module    : Structure.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

||| This section details the check for structural link insertion.
|||
||| Correctness/Soundess Properties of a Structural Link
|||
||| 1. The src and destination must not be the same.
||| 2. A node can only be decomposed once.
||| 3. The decomposition type must be valid for the parent.
||| 4. A parent cannot be contained by its children.
|||
module GRL.Property.Structure

import public Data.AVL.Graph
import public Data.List
import public Data.Stack

import GRL.Model
import GRL.IR
import GRL.Common

%default partial
%access export

-- ----------------------------------------------- [ Structural Link Insertion ]

||| No loops and all different children.
allDiff : GExpr ELEM -> List (GExpr ELEM) -> Bool
allDiff src ds = diffDSTs ds && noLoopBack src ds
  where
    diffDSTs : List (GExpr ELEM) -> Bool
    diffDSTs xs = if length xs == 1
                   then True
                   else not $ and [ eqGExpr x y | x <- xs, y <- xs]

    noLoopBack : GExpr ELEM -> List (GExpr ELEM) -> Bool
    noLoopBack y xs = not $ and $ map (\x => eqGExpr x y) xs

||| Nodes are all valid nodes
validNodes : List (GExpr ELEM) -> GModel -> Bool
validNodes ns m = and $ map (\n => isValid n m) ns
  where
    isValid : GExpr ELEM -> GModel -> Bool
    isValid (Elem ty t s) m = hasGoal t m

||| The node is free to be decomposed, or has been decomposed and are
||| adding the same decomposition.
validDTy : GExpr ELEM -> GStructTy -> GModel -> Bool
validDTy (Elem ty t s) dty m =
  case getGoalByTitle t m of
    Nothing => False
    Just n  => case getStructTy n of
        Nothing  => True
        Just xty => xty == dty

-- -------------------------------------------------------------- [ Evaluation ]
private
record ComputeState where
  constructor MkState
  next : Stack NodeID
  seen : List NodeID

private
defState : List NodeID -> ComputeState
defState is = MkState (pushSThings is mkStack) (List.Nil)

private
cycleCheck : NodeID -> NodeID -> List NodeID -> Bool
cycleCheck id curr seen = elem curr seen || curr == id || elem id seen

partial
private
doComputeSpan : (id    : NodeID)
              -> (model : GModel)
              -> (st    : ComputeState)
              -> Bool
doComputeSpan id g st =
    case popS' (next st) of
      Nothing          => True
      Just (curr, newS) =>  -- TODO
        if cycleCheck id curr (seen st)
          then False
          else let cs = children curr in
              if isNil cs
                then True && doComputeSpan id g
                                 (record { next = newS} st)
                else
                  if elem id cs
                    then False -- If thing is in children
                    else True && doComputeSpan id g
                        (record { seen = curr :: (seen st)
                                , next = newS ++ cs} st)
  where
    children : NodeID -> List NodeID
    children n = map fst $ getDeCompEdges n g

%assert_total
computeSpan : GExpr STRUCT -> GModel -> Bool
computeSpan (SLink ty (Elem ty' t s) ds) m =
    case initID of
      Nothing => False
      Just id => doComputeSpan id m (defState ds')
  where
    initID : Maybe NodeID
    initID = getGoalIDByTitle t m

    ds' : List (NodeID)
    ds' = catMaybes $ map (\x => getGoalIDByTitle (getTitle x) m) ds

partial
checkStructBool : GExpr STRUCT -> GModel -> Bool
checkStructBool l@(SLink ty src ds) m =
    length ds >= 1
    && allDiff src ds
    && validNodes (src :: ds) m
    && validDTy src ty m
    && computeSpan l m

-- --------------------------------------------------------------------- [ EOF ]