module BiNat.Properties.Minus

import BiNat
import BiNat.Properties.Plus
import BiNat.Properties.Induction
import BiNat.Properties.LT
import BiNat.Properties.Mult

%access public export
%default total

minusLast00 : (ms, ns : BiNat) -> (tail : List Bit) ->
  minus' (ms -: O) (ns -: O) tail = minus' ms ns (O :: tail)
minusLast00 J         J         tail = Refl
minusLast00 J         (ns -: O) tail = Refl
minusLast00 J         (ns -: I) tail = Refl
minusLast00 (ms -: O) J         tail = Refl
minusLast00 (ms -: I) J         tail = Refl
minusLast00 (ms -: O) (ns -: O) tail = Refl
minusLast00 (ms -: O) (ns -: I) tail = Refl
minusLast00 (ms -: I) (ns -: O) tail = Refl
minusLast00 (ms -: I) (ns -: I) tail = Refl

minusLast10 : (ms, ns : BiNat) -> (tail : List Bit) ->
  minus' (ms -: I) (ns -: O) tail = minus' ms ns (I :: tail)
minusLast10 J         J         tail = Refl
minusLast10 J         (ns -: O) tail = Refl
minusLast10 J         (ns -: I) tail = Refl
minusLast10 (ms -: O) J         tail = Refl
minusLast10 (ms -: I) J         tail = Refl
minusLast10 (ms -: O) (ns -: O) tail = Refl
minusLast10 (ms -: O) (ns -: I) tail = Refl
minusLast10 (ms -: I) (ns -: O) tail = Refl
minusLast10 (ms -: I) (ns -: I) tail = Refl

minusLast11 : (ms, ns : BiNat) -> (tail : List Bit) ->
  minus' (ms -: I) (ns -: I) tail = minus' ms ns (O :: tail)
minusLast11 J         J         tail = Refl
minusLast11 J         (ns -: O) tail = Refl
minusLast11 J         (ns -: I) tail = Refl
minusLast11 (ms -: O) J         tail = Refl
minusLast11 (ms -: I) J         tail = Refl
minusLast11 (ms -: O) (ns -: O) tail = Refl
minusLast11 (ms -: O) (ns -: I) tail = Refl
minusLast11 (ms -: I) (ns -: O) tail = Refl
minusLast11 (ms -: I) (ns -: I) tail = Refl

minusLast01 : (ms, ns : BiNat) -> (tail : List Bit) -> Not (ms = J) ->
  minus' (ms -: O) (ns -: I) tail = minus' (pred ms) ns (I :: tail)
minusLast01 J         ns         tail notJ = absurd (notJ Refl)
minusLast01 (ms -: O) J          tail _    = Refl
minusLast01 (ms -: I) J          tail _    = Refl
minusLast01 (ms -: O) (ns -: O)  tail _    = Refl
minusLast01 (ms -: O) (ns -: I)  tail _    = Refl
minusLast01 (ms -: I) (ns -: O)  tail _    = Refl
minusLast01 (ms -: I) (ns -: I)  tail _    = Refl

minusLast0J : (ms : BiNat) -> (tail : List Bit) -> Not (ms = J) ->
  minus' (ms -: O) J tail = foldl (-:) (pred ms -: I) tail
minusLast0J J         tail notJ = absurd (notJ Refl)
minusLast0J (ms -: O) tail _    = Refl
minusLast0J (ms -: I) tail _    = Refl

minusLast1J : (ms : BiNat) -> (tail : List Bit) -> Not (ms = J) ->
  minus' (ms -: I) J tail = foldl (-:) (ms -: O) tail
minusLast1J J         tail notJ = absurd (notJ Refl)
minusLast1J (ms -: O) tail _    = Refl
minusLast1J (ms -: I) tail _    = Refl

jMinusIsJ : (n : BiNat) -> minus J n = J
jMinusIsJ J         = Refl
jMinusIsJ (ns -: n) = Refl

minusJIsPred : (n : BiNat) -> minus n J = pred n
minusJIsPred J              = Refl
minusJIsPred (J -: O)       = Refl
minusJIsPred (ns -: n -: O) = rewrite predDashAppendsAcc (ns -: n) [I] in Refl
minusJIsPred (J -: I)       = Refl
minusJIsPred (ns -: n -: I) = Refl

minusOfItSelf : (n : BiNat) -> (tail : List Bit) -> minus' n n tail = tailToBiNat tail
minusOfItSelf J              tail = Refl
minusOfItSelf (J -: O)       tail = Refl
minusOfItSelf (ns -: O -: O) tail = rewrite minusOfItSelf (ns -: O) (O :: tail) in Refl
minusOfItSelf (ns -: I -: O) tail = rewrite minusOfItSelf (ns -: I) (O :: tail) in Refl
minusOfItSelf (J -: I)       tail = Refl
minusOfItSelf (ns -: O -: I) tail = rewrite minusOfItSelf (ns -: O) (O :: tail) in Refl
minusOfItSelf (ns -: I -: I) tail = rewrite minusOfItSelf (ns -: I) (O :: tail) in Refl

minusDashAppendsTail : (m, n : BiNat) -> GT m n -> (tail : List Bit) ->
  minus' m n tail = foldl (-:) (minus' m n []) tail
minusDashAppendsTail J              n              lt tail impossible
minusDashAppendsTail (J -: O)       J              lt tail = Refl
minusDashAppendsTail (ms -: m -: O) J              lt tail = Refl
minusDashAppendsTail (J -: I)       J              lt tail = Refl
minusDashAppendsTail (ms -: m -: I) J              lt tail = Refl
minusDashAppendsTail (ms -: O)      (ns -: O) (LTAppend ns ms lt O O) tail =
  rewrite minusLast00 ms ns tail in
  rewrite minusLast00 ms ns [] in
  rewrite minusDashAppendsTail ms ns lt (O :: tail) in
  rewrite minusDashAppendsTail ms ns lt [O] in Refl
minusDashAppendsTail (J -: O)       (ns -: I)      (LTAppend ns J lt I O) tail impossible
minusDashAppendsTail (ms -: m -: O) (J -: I)       (LTAppend J (ms -: m) lt I O) tail =
  case lessThanImpliesLTEPred J (ms -: m) lt of
    LTEEqual _ _ eq =>
      rewrite sym $ eq in Refl
    LTELessThan _ _ lt2 =>
      rewrite minusDashAppendsTail (pred (ms -: m)) J lt2 (I :: tail) in
      rewrite minusDashAppendsTail (pred (ms -: m)) J lt2 [I] in Refl
minusDashAppendsTail (ms -: m -: O) (ns -: n -: I) (LTAppend (ns -: n) (ms -: m) lt I O) tail =
  case lessThanImpliesLTEPred (ns -: n) (ms -: m) lt of
    LTEEqual _ _ eq =>
      rewrite sym $ eq in
      rewrite minusOfItSelf (ns -: n) (I :: tail) in
      rewrite minusOfItSelf (ns -: n) [I] in Refl
    LTELessThan _ _ lt2 =>
      rewrite minusDashAppendsTail (pred (ms -: m)) (ns -: n) lt2 (I :: tail) in
      rewrite minusDashAppendsTail (pred (ms -: m)) (ns -: n) lt2 [I] in Refl
minusDashAppendsTail (ms -: I)      (ns -: O)      (LTLeading ns ms eq) tail =
  rewrite eq in
  rewrite minusLast10 ms ms tail in
  rewrite minusLast10 ms ms [] in
  case ms of
    J          => Refl
    (ms2 -: m) =>
      rewrite minusOfItSelf (ms2 -: m) (I :: tail) in
      rewrite minusOfItSelf (ms2 -: m) [I] in Refl
minusDashAppendsTail (ms -: m -: I) (ns -: O)      (LTAppend ns (ms -: m) lt O I) tail =
  rewrite minusDashAppendsTail (ms -: m) ns lt (I :: tail) in
  rewrite minusDashAppendsTail (ms -: m) ns lt [I] in Refl
minusDashAppendsTail (J -: I)       (ns -: I)      (LTAppend ns J lt I I) tail impossible
minusDashAppendsTail (ms -: m -: I) (ns -: I)      (LTAppend ns (ms -: m) lt I I) tail =
  rewrite minusDashAppendsTail (ms -: m) ns lt (O :: tail) in
  rewrite minusDashAppendsTail (ms -: m) ns lt [O] in Refl

plusNMinusN : (m, n : BiNat) -> minus (plus m n) n = m
plusNMinusN J              J              = Refl
plusNMinusN J              (J -: O)       = Refl
plusNMinusN J              (ns -: O -: O) = minusOfItSelf (ns -: O) [I]
plusNMinusN J              (ns -: I -: O) = minusOfItSelf (ns -: I) [I]
plusNMinusN J              (J -: I)       = Refl
plusNMinusN J              (ns -: O -: I) = minusOfItSelf (ns -: O) [I]
plusNMinusN J              (ns -: I -: I) =
  rewrite succDashAppendsAcc ns [O, O] in
  rewrite predOfDoubled (succ ns) (succIsNotJ ns) in
  rewrite predOfSucc ns in
  rewrite minusOfItSelf (ns -: I) [I] in Refl
plusNMinusN (J -: O)       J              = Refl
plusNMinusN (ms -: O -: O) J              = Refl
plusNMinusN (ms -: I -: O) J              = Refl
plusNMinusN (J -: I)       J              = Refl
plusNMinusN (ms -: O -: I) J              = Refl
plusNMinusN (ms -: I -: I) J              =
  rewrite succDashAppendsAcc ms [O, O] in
  rewrite predOfDoubled (succ ms) (succIsNotJ ms) in
  rewrite predOfSucc ms in Refl
plusNMinusN (ms -: O)      (ns -: O)      =
  rewrite plusDashAppendsAcc ms ns O [O] in
  rewrite minusLast00 (plus ms ns) ns [] in
  rewrite minusDashAppendsTail (plus ms ns) ns (lessThanPlus ns ms) [O] in
  rewrite plusNMinusN ms ns in Refl
plusNMinusN (ms -: O)      (ns -: I)      =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite minusLast11 (plus ms ns) ns [] in
  rewrite minusDashAppendsTail (plus ms ns) ns (lessThanPlus ns ms) [O] in
  rewrite plusNMinusN ms ns in Refl
plusNMinusN (ms -: I)      (ns -: O)      =
  rewrite plusDashAppendsAcc ms ns O [I] in
  rewrite minusLast10 (plus ms ns) ns [] in
  rewrite minusDashAppendsTail (plus ms ns) ns (lessThanPlus ns ms) [I] in
  rewrite plusNMinusN ms ns in Refl
plusNMinusN (ms -: I)      (ns -: I)      =
  rewrite plusDashAppendsAcc ms ns I [O] in
  rewrite sym $ succGoesToCarry ms ns [] in
  rewrite minusLast01 (succ (plus ms ns)) ns [] (succIsNotJ (plus ms ns)) in
  rewrite predOfSucc (plus ms ns) in
  rewrite minusDashAppendsTail (plus ms ns) ns (lessThanPlus ns ms) [I] in
  rewrite plusNMinusN ms ns in Refl

minusNPlusN : (m, n : BiNat) -> GT m n -> plus (minus m n) n = m
minusNPlusN m n =
  induction
    (\k => LT n k -> plus (minus k n) n = k)
    (\k, pk, lt =>
      case lessThanImpliesLTEPred n (succ k) lt of
        LTEEqual _ _ eq =>
          rewrite eq in
          rewrite predOfSucc k in
          rewrite sym $ jPlusIsSucc k in
          rewrite plusNMinusN J k in Refl
        LTELessThan _ _ lt2 =>
          let pk' = pk (replace {P = \z => LT n z} (predOfSucc k) lt2) in
          replace {P = \z => plus (minus (succ z) n) n = succ k} pk' $
          rewrite sym $ jPlusIsSucc (plus (minus k n) n) in
          rewrite plusAssociative J (minus k n) n in
          rewrite plusNMinusN (plus J (minus k n)) n in
          rewrite sym $ plusAssociative J (minus k n) n in
          rewrite pk' in jPlusIsSucc k
    )
    (\lt => absurd (uninhabited lt))
    m

succIntoMinus : (m, n : BiNat) -> GT m n -> succ (minus m n) = minus (succ m) n
succIntoMinus m n lt =
  induction
    (\k => LT n k -> succ (minus k n) = minus (succ k) n)
    (\k, pk, ltSucc =>
      case lessThanImpliesLTEPred n (succ k) ltSucc of
        LTEEqual _ _ eq =>
          rewrite eq in
          rewrite predOfSucc k in
          rewrite sym $ jPlusIsSucc k in
          rewrite plusNMinusN J k in
          rewrite sym $ jPlusIsSucc (plus J k) in
          rewrite plusAssociative J J k in
          rewrite plusNMinusN (J -: O) k in Refl
        LTELessThan _ _ lt =>
          rewrite sym $ minusNPlusN (succ k) n ltSucc in
          rewrite sym $ jPlusIsSucc (plus (minus (succ k) n) n) in
          rewrite plusAssociative J (minus (succ k) n) n in
          rewrite plusNMinusN (plus J (minus (succ k) n)) n in
          rewrite jPlusIsSucc (minus (succ k) n) in
          rewrite plusNMinusN (minus (succ k) n) n in Refl
    )
    (absurd . uninhabited)
    m lt

succNMinusNIsJ : (n : BiNat) -> minus (succ n) n = J
succNMinusNIsJ J         = Refl
succNMinusNIsJ (ns -: O) = rewrite minusLast10 ns ns [] in minusOfItSelf ns [I]
succNMinusNIsJ (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite minusLast01 (succ ns) ns [] (succIsNotJ ns) in
  rewrite predOfSucc ns in
  minusOfItSelf ns [I]

nMinusPredNIsJ : (n : BiNat) -> minus n (pred n) = J
nMinusPredNIsJ J              = Refl
nMinusPredNIsJ (J -: O)       = Refl
nMinusPredNIsJ (ns -: n -: O) = rewrite predDashAppendsAcc (ns -: n) [I] in minusOfItSelf (pred (ns -: n)) [I]
nMinusPredNIsJ (ns -: I)      = rewrite minusLast10 ns ns [] in minusOfItSelf ns [I]

minusIntoPlusLeft : (l, m, n : BiNat) -> GT l n -> minus (plus l m) n = plus (minus l n) m
minusIntoPlusLeft l m n lt =
  induction
    (\k => minus (plus l k) n = plus (minus l n) k)
    (\k, pk =>
      rewrite sym $ plusJIsSucc k in
      rewrite plusAssociative l k J in
      rewrite plusJIsSucc (plus l k) in
      let nLtLPlusK = lessThanTransitive lt (replace (plusSymmetric k l) (lessThanPlus l k)) in
      rewrite sym $ succIntoMinus (plus l k) n nLtLPlusK in
      rewrite pk in
      rewrite sym $ plusJIsSucc (plus (minus l n) k5) in
      rewrite sym $ plusAssociative (minus l n) k J in Refl
    )
    (
      rewrite plusJIsSucc l in
      rewrite plusJIsSucc (minus l n) in
      sym $ succIntoMinus l n lt
    )
    m

minusIntoPlusRight : (l, m, n : BiNat) -> GT m n -> minus (plus l m) n = plus l (minus m n)
minusIntoPlusRight l m n lt =
  rewrite plusSymmetric l m in
  rewrite minusIntoPlusLeft m l n lt in
  plusSymmetric (minus m n) l

minusGreater : (m, n : BiNat) -> LT m n -> (tail : List Bit) -> minus' m n tail = J
minusGreater m              J         lt tail impossible
minusGreater J              (ns -: n) lt tail = Refl
minusGreater (ms -: O)      (ns -: O) (LTAppend ms ns lt O O) tail =
  rewrite minusLast00 ms ns tail in minusGreater ms ns lt (O :: tail)
minusGreater (ms -: I)      (ns -: O) (LTAppend ms ns lt I O) tail =
  rewrite minusLast10 ms ns tail in minusGreater ms ns lt (I :: tail)
minusGreater (ms -: I)      (ns -: I) (LTAppend ms ns lt I I) tail =
  rewrite minusLast11 ms ns tail in minusGreater ms ns lt (O :: tail)
minusGreater (J -: O)       (ns -: I) lt tail = Refl
minusGreater (ms -: m -: O) (ns -: I) (LTAppend (ms -: m) ns lt O I) tail =
  let lt2 = lessThanTransitive (predIsLessThan (ms -: m) (JLT ms m)) lt in
  minusGreater (pred (ms -: m)) ns lt2 (I :: tail)
minusGreater (ms -: m -: O) (ns -: I) (LTLeading (ms -: m) ns eq) tail =
  let lt = replace {P = \z => LT (pred (ms -: m)) z} eq (predIsLessThan (ms -: m) (JLT ms m)) in
  minusGreater (pred (ms -: m)) ns lt (I :: tail)

minusOfSuccs : (m, n : BiNat) -> minus m n = minus (succ m) (succ n)
minusOfSuccs J              J         = Refl
minusOfSuccs J              (ns -: O) = Refl
minusOfSuccs J              (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  rewrite minusGreater J (succ ns) (succGreaterThanJ ns) [O] in Refl
minusOfSuccs (J -: O)       J         = Refl
minusOfSuccs (ms -: m -: O) J         =
  rewrite minusDashAppendsTail (ms -: m) J (JLT ms m) [I] in
  rewrite minusJIsPred (ms -: m) in Refl
minusOfSuccs (J -: I)       J         = Refl
minusOfSuccs (ms -: m -: I) J         =
  rewrite succDashAppendsAcc (ms -: m) [O] in
  rewrite minusLast00 (succ (ms -: m)) J [] in
  rewrite minusDashAppendsTail (succ (ms -: m)) J (succGreaterThanJ (ms -: m)) [O] in
  rewrite minusJIsPred (succ (ms -: m)) in
  rewrite predOfSucc (ms -: m) in Refl
minusOfSuccs (ms -: O)      (ns -: O) = rewrite minusLast11 ms ns [] in minusLast00 ms ns []
minusOfSuccs (J -: O)       (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  sym $ minusGreater J (succ ns) (succGreaterThanJ ns) [I]
minusOfSuccs (ms -: m -: O) (ns -: I) =
  rewrite succDashAppendsAcc ns [O] in
  case lessThanOrGTE ns (pred (ms -: m)) of
    Left nLTpredm =>
      let succnLTm = replace {P = \z => LT (succ ns) z} (succOfPred (ms -: m) uninhabited) $
                     succKeepsLessThan ns (pred (ms -: m)) nLTpredm in
      rewrite minusDashAppendsTail (pred (ms -: m)) ns nLTpredm [I] in
      rewrite minusDashAppendsTail (ms -: m) (succ ns) succnLTm [I] in
      rewrite minusOfSuccs (pred (ms -: m)) ns in
      rewrite succOfPred (ms -: m) uninhabited in Refl
    Right (LTEEqual (pred (ms -: m)) ns eq) =>
      rewrite sym $ succOfPred (ms -: m) uninhabited in
      rewrite eq in
      rewrite predOfSucc ns in
      rewrite minusOfItSelf ns [I] in
      rewrite minusOfItSelf (succ ns) [I] in Refl
    Right (LTELessThan (pred (ms -: m)) ns predmLTn) =>
      let mLTsuccn = replace {P = \z => LT z (succ ns)} (succOfPred (ms -: m) uninhabited) $
                     succKeepsLessThan (pred (ms -: m)) ns predmLTn in
      rewrite minusGreater (pred (ms -: m)) ns predmLTn [I] in
      rewrite minusGreater (ms -: m) (succ ns) mLTsuccn [I] in Refl
minusOfSuccs (ms -: I)      (ns -: O) =
  rewrite minusLast10 ms ns [] in
  rewrite succDashAppendsAcc ms [O] in
  rewrite minusLast01 (succ ms) ns [] (succIsNotJ ms) in
  rewrite predOfSucc ms in Refl
minusOfSuccs (ms -: I)      (ns -: I) =
  rewrite minusLast11 ms ns [] in
  rewrite succDashAppendsAcc ms [O] in
  rewrite succDashAppendsAcc ns [O] in
  rewrite minusLast00 (succ ms) (succ ns) [] in
  case lessThanOrGTE ns ms of
    Left gt =>
      rewrite minusDashAppendsTail ms ns gt [O] in
      rewrite minusDashAppendsTail (succ ms) (succ ns) (succKeepsLessThan ns ms gt) [O] in
      rewrite minusOfSuccs ms ns in Refl
    Right (LTEEqual ms ns eq) =>
      rewrite eq in
      rewrite minusOfItSelf ns [O] in
      rewrite minusOfItSelf (succ ns) [O] in Refl
    Right (LTELessThan ms ns lt) =>
      rewrite minusGreater ms ns lt [O] in
      rewrite minusGreater (succ ms) (succ ns) (succKeepsLessThan ms ns lt) [O] in Refl

predIntoMinus' : (m, n : BiNat) -> GT m n -> pred (minus m n) = minus (pred m) n
predIntoMinus' m n gt = induction
  (\k => GT k n -> pred (minus k n) = minus (pred k) n)
  (\k, pk, nLTsucck =>
    case lessThanImpliesLTEPred n (succ k) nLTsucck of
      LTEEqual n (pred $ succ k) eq =>
        rewrite eq in
        rewrite predOfSucc k in
        rewrite succNMinusNIsJ k in
        rewrite minusOfItSelf k [] in Refl
      LTELessThan n (pred $ succ k) lt =>
        let nLTk = replace (predOfSucc k) lt in
        rewrite sym $ succIntoMinus k n nLTk in
        rewrite predOfSucc (minus k n) in
        rewrite predOfSucc k in Refl
  )
  (\gt => absurd $ uninhabited gt)
  m gt

predIntoMinus : (m, n : BiNat) -> pred (minus m n) = minus (pred m) n
predIntoMinus m n =
  case lessThanOrGTE n m of
    Left gt =>
      predIntoMinus' m n gt
    Right (LTEEqual m n eq) =>
      rewrite eq in
      rewrite minusOfItSelf n [] in
      case predLessThanEqual n of
        LTEEqual (pred n) n eq2 =>
          rewrite eq2 in
          sym $ minusOfItSelf n []
        LTELessThan (pred n) n lt =>
          rewrite minusGreater (pred n) n lt [] in Refl
    Right (LTELessThan m n lt) =>
      rewrite minusGreater m n lt [] in
      let predmLTn = transLTEandLT (predLessThanEqual m) lt in
      rewrite minusGreater (pred m) n predmLTn [] in Refl

predIntoMinusSucc : (m, n : BiNat) -> pred (minus m n) = minus m (succ n)
predIntoMinusSucc J         n = rewrite jMinusIsJ n in rewrite jMinusIsJ (succ n) in Refl
predIntoMinusSucc (ms -: m) n =
  rewrite predIntoMinus (ms -: m) n in
  rewrite minusOfSuccs (pred (ms -: m)) n in
  rewrite succOfPred (ms -: m) uninhabited in Refl

minusTwiceLeft : (l, m, n : BiNat) -> minus (minus l m) n = minus l (plus m n)
minusTwiceLeft l m n = induction
  (\k => minus (minus l k) n = minus l (plus k n))
  (\k, pk =>
    rewrite sym $ predIntoMinusSucc l k in
    rewrite sym $ jPlusIsSucc k in
    rewrite sym $ plusAssociative J k n in
    rewrite jPlusIsSucc (plus k n) in
    rewrite sym $ predIntoMinusSucc l (plus k n) in
    rewrite sym $ predIntoMinus (minus l k) n in
    rewrite pk in Refl
  )
  (
    rewrite minusJIsPred l in
    rewrite sym $ predIntoMinus l n in
    rewrite jPlusIsSucc n in
    rewrite sym $ predIntoMinusSucc l n in Refl
  )
  m

minusLessThanOriginal : (m, n : BiNat) -> GT m J -> LT (minus m n) m
minusLessThanOriginal m n mgtj = induction
  (\k => LT (minus m k) m)
  (\k, pk =>
    let lte1 = predLessThanEqual (minus m k) in
    replace {P = \z => LT z m} (predIntoMinusSucc m k) (transLTEandLT lte1 pk)
  )
  (replace {P = \z => LT z m} (sym $ minusJIsPred m) (predIsLessThan m mgtj))
  n

multDistributesMinusLeft : (l, m, n : BiNat) -> GT l m -> mult (minus l m) n = minus (mult l n) (mult m n)
multDistributesMinusLeft l m n gt = induction
  (\k => GT k m -> mult (minus k m) n = minus (mult k n) (mult m n))
  (\k, pk, succkGTm =>
    case lessThanImpliesLTEPred m (succ k) succkGTm of
      LTEEqual _ _ eq =>
        rewrite eq in
        rewrite predOfSucc k in
        rewrite succNMinusNIsJ k in
        rewrite plusJIsSucc n in
        rewrite predOfSucc n in
        rewrite multOfSuccLeft k n in
        rewrite plusNMinusN n (mult k n) in Refl
      LTELessThan _ _ lt =>
        let mLTk = replace (predOfSucc k) lt in
        rewrite sym $ succIntoMinus k m mLTk in
        rewrite multOfSuccLeft (minus k m) n in
        rewrite pk mLTk in
        rewrite multOfSuccLeft k n in
        rewrite minusIntoPlusRight n (mult k n) (mult m n) (multNKeepsLT m k mLTk n) in Refl
  )
  (absurd . uninhabited)
  l gt

multDistributesMinusRight : (l, m, n : BiNat) -> GT m n -> mult l (minus m n) = minus (mult l m) (mult l n)
multDistributesMinusRight l m n gt =
  rewrite multSymmetric l (minus m n) in
  rewrite multDistributesMinusLeft m n l gt in
  rewrite multSymmetric l m in
  rewrite multSymmetric l n in Refl


module Effekt.CpsUnstaged

public export
Cps : Type -> Type -> Type
Cps r a = (a -> r) -> r

shift0 : ((a -> r) -> r) -> Cps r a
shift0 = id

runIn0 : Cps r a -> (a -> r) -> r
runIn0 = id

reset0 : Cps r r -> r
reset0 m = runIn0 m id

pure : a -> Cps r a
pure a = \k => k a

push : (a -> Cps r b) -> (b -> r) -> (a -> r)
push f k = \a => f a k

bind : Cps r a -> (a -> Cps r b) -> Cps r b
bind m f = \k => m (push f k)

(>>=) : Cps r a -> (a -> Cps r b) -> Cps r b
m >>= f = bind m f

example : Int
example = 1 + reset0 (do
  x <- shift0 (\k => k (k 100))
  pure (10 + x))


module Circuits.NetList.Linear.Usage.DataType.Use.Partial

import Decidable.Equality

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

import Data.Vect
import Data.Vect.AtIndex
import Data.Vect.Quantifiers

import Data.String

import Toolkit.Data.Whole
import Toolkit.Data.DList
import Toolkit.Data.DList.Elem

import Toolkit.Data.Vect.Extra

import Circuits.Common
import Circuits.NetList.Types
import Circuits.NetList.Linear.Usage.DataType

import Circuits.NetList.Linear.Usage.DataType.Use.Full

%default total

mutual
  public export
  data Use : (idx  : Fin m)

          -> (type : DType)
          -> (old  : Usage        (BVECT (W (S n) ItIsSucc) type))
          -> (prfF : IsFreeAt idx (BVECT (W (S n) ItIsSucc) type)  old)

          -> (new  : Usage        (BVECT (W (S n) ItIsSucc) type))
          -> (prfU : IsUsedAt idx (BVECT (W (S n) ItIsSucc) type)  new)
                  -> Type
    where
      UA : Use idx type        fs          prfFS         us          prfUS
        -> Use idx type (Array fs) (FreeAt prfFS) (Array us) (UsedAt prfUS)

  public export
  data Result : (idx  : Fin m)
             -> (type : DType)
             -> (old  : Usage        (BVECT (W (S n) ItIsSucc) type))
             -> (free : IsFreeAt idx (BVECT (W (S n) ItIsSucc) type)  old)
                     -> Type
    where
      R : (new   : Usage        (BVECT (W (S n) ItIsSucc) type))
       -> (prfU  : IsUsedAt idx (BVECT (W (S n) ItIsSucc) type)         new)
       -> (holds : Use      idx                           type old prfF new prfU)
                -> Result   idx                           type old prfF

  namespace Vect
    public export
    data Use : (idx  : Fin  m)
            -> (type : DType)
            -> (old  : Vect n   (Usage type))
            -> (this : AtIndexI (Usage type) (IsFree type) m n idx old)
            -> (new  : Vect n   (Usage type))
            -> (that : AtIndexI (Usage type) (IsUsed type) m n idx new)
                    -> Type
      where
        Here : (use : Use    type  f                prfF    u                prfU)
                   -> Use FZ type (f::fs) (At (Here prfF)) (u::fs) (At (Here prfU))

        Next : Use     next  type         fs  (At        next_f)          us  (At        next_u)
            -> Use (FS next) type (not_f::fs) (At (There next_f)) (not_u::us) (At (There next_u))

    public export
    data Result : (idx  : Fin m)
               -> (type : DType)
               -> (old  : Vect n (Usage type))
               -> (this : AtIndexI (Usage type) (IsFree type) m n idx old)
                       -> Type
      where
        R : (new   : Vect n   (Usage type))
         -> (prfU  : AtIndexI (Usage type) (IsUsed type) m n idx new)
         -> (holds : Use    idx type old this new prfU)
                  -> Result idx type old this

mutual

  use : {type : DType}
     -> (idx  : Fin m)
     -> {old  : Usage        (BVECT (W (S n) ItIsSucc) type)}
     -> (free : IsFreeAt idx (BVECT (W (S n) ItIsSucc) type) old)
             -> Result   idx                           type old free
  use idx (FreeAt prf) with (use idx prf)
    use idx (FreeAt prf) | (R new prfU holds)
      = R (Array new) (UsedAt prfU) (UA holds)

  namespace Vect

    export
    use : {type : DType}
       -> (idx  : Fin m)
       -> {old  : Vect n (Usage type)}
       -> (this : AtIndexI (Usage type) (IsFree type) m n idx old)
               -> Result idx type old this
    use FZ {old=(x :: xs)} (At (Here prf)) with (use prf)
      use FZ {old=(x :: xs)} (At (Here prf)) | (R u used result)
        = R (u :: xs) (At (Here used)) (Here result)

    use (FS next) {old=(not_x :: xs)} (At (There later)) with (use next (At later))
      use (FS next) {old=(not_x :: xs)} (At (There later)) | (R new (At x) holds)
        = R (not_x :: new) (At (There x)) (Next holds)

-- [ EOF ]


module InvParComb2

%default total
%hide Prelude.Algebra.(<*>)
%hide Prelude.Applicative.(<|>)

-- http://www.informatik.uni-marburg.de/~rendel/unparse/

-- core definitions

data PartIso a b = MkPartIso (a -> Maybe b) (b -> Maybe a)

class PartIsoFunctor (f : Type -> Type -> Type) where
  (<$>) : PartIso a b -> (f a c -> f b c)

class PFunctor (f : Type -> Type -> Type) where
  (<*>) : f a c -> Lazy (f b c) -> f (a, b) c

class PAlternative (f : Type -> Type -> Type) where
  (<|>) : f a c -> Lazy (f a c) -> f a c
  empty : f a c

class (PartIsoFunctor d, PFunctor d, PAlternative d) => Syntax (d : Type -> Type -> Type) c where
  pure : Eq a => a -> d a c
  item : d c c

-- helper functions

ipc_inverse : PartIso a b -> PartIso b a
ipc_inverse (MkPartIso f g) = MkPartIso g f

ipc_apply : PartIso a b -> a -> Maybe b
ipc_apply (MkPartIso f g) = f

ipc_unapply : PartIso a b -> b -> Maybe a
ipc_unapply = ipc_apply . ipc_inverse

-- Algebra

infixr 1 >=>
(>=>) : Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g = \x => f x >>= g

pId : PartIso a a
pId = MkPartIso (\x => Just x) (\x => Just x)

(.) : PartIso b c -> PartIso a b -> PartIso a c
g . f = MkPartIso (ipc_apply f >=> ipc_apply g) (ipc_unapply g >=> ipc_unapply f)

pTup : PartIso a b -> PartIso c d -> PartIso (a, c) (b, d)
pTup i j = MkPartIso f g where
  f (a, b) = case (ipc_apply i a) of
    Nothing => Nothing
    Just x => case (ipc_apply j b) of
      Nothing => Nothing
      Just y => Just (x, y)
  g (c, d) = case (ipc_unapply i c) of
    Nothing => Nothing
    Just x => case (ipc_unapply j d) of
      Nothing => Nothing
      Just y => Just (x, y)

associate : PartIso (a, (b, c)) ((a, b), c)
associate = MkPartIso f g where
  f (a, (b, c)) = Just ((a, b), c)
  g ((a, b), c) = Just (a, (b, c))

commute : PartIso (a, b) (b, a)
commute = MkPartIso f f where
  f : (c, d) -> Maybe (d, c)
  f (a, b) = Just (b, a)

unit : PartIso a (a, ())
unit = MkPartIso f g where
  f a = Just (a, ())
  g (a, ()) = Just a

-- *>, <*

infixl 3 *>
(*>) : Syntax d c => d () c -> d a c -> d a c
p *> q = ipc_inverse unit . commute <$> p <*> q

infixl 3 <*
(<*) : Syntax d c => d a c -> d () c -> d a c
p <* q = ipc_inverse unit <$> p <*> q

ignore : a -> PartIso a ()
ignore x = MkPartIso f g where
  f y = Just ()
  g () = Just x

-- Parser

data Parser a c = MkParser (List c -> Maybe (a, List c))

parse : Parser a c -> List c -> Maybe a
parse (MkParser p) s = p s >>= pure . fst

instance PartIsoFunctor Parser where
  iso <$> (MkParser p) = MkParser pf
  where
    pf l = do
      (x, rest) <- p l
      y <- ipc_apply iso x
      return (y, rest)

instance PFunctor Parser where
  (MkParser p) <*> mkpq = MkParser pf
  where
    pf l = do
      (x, rest) <- p l
      case mkpq of
        (MkParser q) => do
          (y, ret) <- q rest
          return ((x, y), ret)

instance PAlternative Parser where
  (MkParser p) <|> mkpq = MkParser pf
  where
    pf l = case p l of
      Just x => Just x
      Nothing => case mkpq of
        (MkParser q) => q l
  empty = MkParser (\s => Nothing)

instance Syntax Parser c where
  pure x = MkParser (\s => Just (x, s))
  item = MkParser f
  where
    f [] = Nothing
    f (x :: xs) = Just (x, xs)

-- Printer

data Printer a c = MkPrinter (a -> Maybe (List c))

compose : Printer a c -> a -> Maybe (List c)
compose (MkPrinter p) x = p x

instance PartIsoFunctor Printer where
  iso <$> (MkPrinter p) = MkPrinter (\b => ipc_unapply iso b >>= p)

instance PFunctor Printer where
  (MkPrinter p) <*> mkpq = MkPrinter pf
  where
    pf (x, y) = do
      x' <- p x
      case mkpq of
        (MkPrinter q) => do
          y' <- q y
          return (x' ++ y')

instance PAlternative Printer where
  (MkPrinter p) <|> mkpq = MkPrinter $ \s =>
    case (p s) of
      Nothing => case mkpq of
        (MkPrinter q) => q s
      x => x
  empty = MkPrinter (\s => Nothing)

instance Syntax Printer γ where
  pure x = MkPrinter (\y =>
    if x == y
    then Just []
    else Nothing)
  item = MkPrinter (\t => Just [t])

-- Basic parsers/composers

sat : Syntax d a => (a -> Bool) -> d a a
sat p = (MkPartIso check check) <$> item
  where check x = if p x then Just x else Nothing

val : (Syntax d a, Eq a) => a -> d a a
val x = sat (== x)

-- rep

nilv : PartIso () (Vect 0 a)
nilv = MkPartIso (const . Just $ Vect.Nil {a=a})
                 (\xs => case xs of
                   [] => Just ()
                   _ => Nothing)

consv : PartIso (a, Vect n a) (Vect (S n) a)
consv = MkPartIso c1 c2
  where c1 (x, xs) = Just (x :: xs)
        c2 (x :: xs) = Just (x, xs)

rep : Syntax d c => (n : Nat) -> d a c -> d (Vect n a) c
rep Z p = nilv <$> pure ()
rep (S k) p = consv <$> p <*> rep k p

-- many

nil : PartIso () (List a)
nil = MkPartIso c1 c2
  where
    c1 () = Just []
    c2 [] = Just ()
    c2 (x :: xs) = Nothing

cons : PartIso (a, List a) (List a)
cons = MkPartIso c1 c2
  where
    c1 (x, l) = Just $ x :: l
    c2 [] = Nothing
    c2 (x :: xs) = Just (x, xs)

partial many : Syntax d c => d a c -> d (List a) c
many p = (cons <$> (p <*> (many p)))
     <|> (nil <$> pure ())

-- Various types

-- List Bool <-> Nat, with size and endianness

data Endianness = BE | LE

order : Endianness -> Vect n Bool -> Vect n Bool
order BE = reverse
order LE = id

natToBits : Nat -> Endianness -> (k : Nat) -> Vect k Bool
natToBits n e v = order e $ natToBits' n v
  where natToBits' : Nat -> (k : Nat) -> Vect k Bool
        natToBits' n Z = []
        natToBits' Z bits = replicate bits False
        natToBits' n (S bits) = (mod n 2 /= Z) :: natToBits' (div n 2) bits

bitsToNat : Vect n Bool -> Endianness -> Nat
bitsToNat v e = bitsToNat' (order e v)
  where bitsToNat' : Vect k Bool -> Nat
        bitsToNat' [] = Z
        bitsToNat' (v :: l) = (if v then 1 else 0) + 2 * bitsToNat' l

nat : Syntax d Bool => Endianness -> Nat -> d Nat Bool
nat endianness size = MkPartIso pf cf <$> rep size item
  where
    pf l = Just $ bitsToNat l endianness
    cf x = Just $ natToBits x endianness size

-- testing

test : Syntax d Nat => d (Nat, Nat) Nat
test = (val 1) <*> item
   <|> (val 2) <*> (val 3)

test2 : Syntax d Bool => d (Nat, Bool) Bool
test2 = (nat BE 4) <*> (val True)
    <|> (nat BE 2) <*> (val False)

partial test3 : Syntax d Bool => d (Bool, List Nat) Bool
test3 = (val True) <*> ((ignore False <$> item) *> (many $ nat BE 4))
    <|> (val False) <*> ((ignore True <$> item) *> (many $ nat LE 3))

-- compose test3 (False, [1,2,3])
-- parse test3 [False, True, False, False, False, True, False, True, True, False]

-- foldl

partial driver : (a -> Maybe a) -> (a -> a)
driver step state = case step state of
  Just state' => driver step state'
  Nothing => state

partial iterate : PartIso a a -> PartIso a a
iterate step = MkPartIso f g where
  f = Just . driver (ipc_apply step)
  g = Just . driver (ipc_unapply step)

step : PartIso (a, b) a -> PartIso (a, List b) (a, List b)
step i = (pTup i pId) . associate . (pTup pId (ipc_inverse cons))

partial foldl : PartIso (a, b) a -> PartIso (a, List b) a
foldl i = ipc_inverse unit . (pTup pId (ipc_inverse nil)) . iterate (step i)


module Circuits.NetList.Linear.Usage.DataType

import Decidable.Equality

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

import Data.Vect
import Data.Vect.AtIndex
import Data.Vect.Quantifiers

import Data.String

import Toolkit.Data.Whole
import Toolkit.Data.DList
import Toolkit.Data.DList.Elem

--import Toolkit.Data.Vect.Leanings
import Toolkit.Data.Vect.Extra
import Toolkit.Data.DVect

import Circuits.Common

import Circuits.NetList.Types

%default total

public export
data Usage : DType -> Type where
  Logic : (u : Usage) -> Usage LOGIC

  Array : (us : Vect            (S n)           (Usage type))
             -> Usage (BVECT (W (S n) ItIsSucc)        type)

mutual
  namespace Free
    public export
    data IsFree : (type : DType) -> (u : Usage type) -> Type
      where
        FreeL : IsFree LOGIC (Logic FREE)
        FreeA : (prf : All (IsFree type) os)
                    -> IsFree (BVECT (W (S n) ItIsSucc) type) (Array os)

    Uninhabited (IsFree LOGIC (Logic USED)) where
      uninhabited FreeL impossible

  namespace Used
    public export
    data IsUsed : (type : DType) -> (u : Usage type) -> Type
      where
        UsedL : IsUsed LOGIC (Logic USED)
        UsedA : (prf : All (IsUsed type) os)
                    -> IsUsed (BVECT (W (S n) ItIsSucc) type) (Array os)

    Uninhabited (IsUsed LOGIC (Logic FREE)) where
      uninhabited UsedL impossible

  namespace Part
    public export
    data IsPart : (type : DType) -> (u : Usage type) -> Type
      where
        PartA : (notF : Any (IsFree type) os )
             -> (notU : Any (IsUsed type) os )
                     -> IsPart (BVECT (W (S n) ItIsSucc) type) (Array os)

    Uninhabited (IsPart LOGIC (Logic u)) where
      uninhabited PartA impossible

mutual

  namespace Free
    notFree : (All (IsFree type) us -> Void)
            -> IsFree (BVECT (W (S n) ItIsSucc) type) (Array us)
            -> Void
    notFree f (FreeA prf) = f prf

    export
    isFree : {type : DType}
          -> (u    : Usage type)
                  -> Dec (IsFree type u)
    isFree (Logic USED)
      = No absurd
    isFree (Logic FREE)
      = Yes FreeL

    isFree (Array us) with (all isFree us)
      isFree (Array us) | (Yes prf)
         = Yes (FreeA prf)
      isFree (Array us) | (No contra)
        = No (notFree contra)

  namespace Used
    notUsed : (All (IsUsed type) us -> Void)
           -> IsUsed (BVECT (W (S n) ItIsSucc) type) (Array us)
           -> Void
    notUsed f (UsedA prf) = f prf

    export
    isUsed : {type : DType}
          -> (u    : Usage type)
                  -> Dec (IsUsed type u)
    isUsed (Logic FREE)
      = No absurd
    isUsed (Logic USED)
      = Yes UsedL

    isUsed (Array us) with (all isUsed us)
      isUsed (Array us) | (Yes prf)
         = Yes (UsedA prf)
      isUsed (Array us) | (No contra)
        = No (notUsed contra)

  namespace Part

    export
    isPart : {type : DType}
          -> (u    : Usage type)
                  -> Dec (IsPart type u)
    isPart (Logic u)
      = No absurd

    isPart (Array us) with (any isFree us)
      isPart (Array us) | (Yes prfF) with (any isUsed us)
        isPart (Array us) | (Yes prfF) | (Yes prfU)
          = Yes (PartA prfF prfU)
        isPart (Array us) | (Yes prfF) | (No contra)
          = No (\(PartA fs us) => contra us)

      isPart (Array us) | (No contra)
        = No (\(PartA fs us) => contra fs)

public export
data IsFreeAt : (idx : Fin n) -> (type : DType) -> (u : Usage type) -> Type
  where
    FreeAt : {idx : Fin m}
          -> {us  : Vect (S n) (Usage type)}
          -> (prf : AtIndexI (Usage type) (IsFree type) m (S n) idx us)
                 -> IsFreeAt idx (BVECT (W (S n) ItIsSucc) type) (Array us)

Uninhabited (IsFreeAt idx LOGIC u) where
  uninhabited (FreeAt prf) impossible

notFreeAtIndex : (AtIndexI (Usage type) (IsFree type) m (S n) idx us -> Void)
              -> IsFreeAt idx (BVECT (W (S n) ItIsSucc) type) (Array us) -> Void
notFreeAtIndex f (FreeAt prf) = f  prf

export
isFreeAt : {type : DType}
        -> {n   : Nat}
        -> (idx : Fin n)
        -> (u   : Usage type)
               -> Dec (IsFreeAt idx type u)

isFreeAt {n = n} idx (Logic u)
  = No absurd

isFreeAt {n = n} idx (Array us) with (atIndexI isFree idx us)
  isFreeAt {n = (S n)} idx (Array us) | (Yes prf)
    = Yes (FreeAt prf)

  isFreeAt {n = n} idx (Array us) | (No contra)
    = No (notFreeAtIndex contra)

public export
data IsUsedAt : (idx : Fin n) -> (type : DType) -> (u : Usage type) -> Type
  where
    UsedAt : {idx : Fin m}
          -> (prf : AtIndexI (Usage type) (IsUsed type) m (S n) idx us)
                 -> IsUsedAt idx (BVECT (W (S n) ItIsSucc) type) (Array us)

Uninhabited (IsUsedAt idx LOGIC u) where
  uninhabited (UsedAt prf) impossible

notUsedAtIndex : (AtIndexI (Usage type) (IsUsed type) m (S n) idx us -> Void)
               -> IsUsedAt idx (BVECT (W (S n) ItIsSucc) type) (Array us) -> Void
notUsedAtIndex f (UsedAt prf) = f prf

export
isUsedAt : {type : DType}
        -> {n   : Nat}
        -> (idx : Fin n)
        -> (u   : Usage type)
               -> Dec (IsUsedAt idx type u)

isUsedAt {n = n} idx (Logic u)
  = No absurd

isUsedAt {n = n} idx (Array us) with (atIndexI isUsed idx us)
  isUsedAt {n = (S n)} idx (Array us) | (Yes prf)
    = Yes (UsedAt prf)

  isUsedAt {n = n} idx (Array us) | (No contra)
    = No (notUsedAtIndex contra)

mutual

  export
  init : (type : DType) -> DPair (Usage type) (IsFree type)
  init LOGIC
    = MkDPair (Logic FREE) FreeL

  init (BVECT (W (S n) ItIsSucc) type) with (init type)
    init (BVECT (W (S n) ItIsSucc) type) | (MkDPair u prf) with (init (S n) u prf)
      init (BVECT (W (S n) ItIsSucc) type) | (MkDPair u prf) | (MkDPair os pU)
        = MkDPair (Array os) (FreeA pU)

  namespace Vect
    export
    init : (n   : Nat)
        -> (u   : Usage type)
        -> (prf : IsFree type u)
               -> DPair (Vect n (Usage type)) (All (IsFree type))
    init Z _ _ = MkDPair [] []
    init (S k) u prf with (init k u prf)
      init (S k) u prf | (MkDPair fst snd)
        = MkDPair (u :: fst) (prf :: snd)

-- [ EOF ]


module TypeFuns

SorI : Bool -> Type
SorI False = String
SorI True = Int

getStringOrInt : (isInt : Bool) -> SorI isInt
getStringOrInt False = "Twenty four"
getStringOrInt True = 24

valToString : (isInt : Bool) -> SorI isInt -> String
valToString False x = trim x
valToString True x = cast x

vts : (isInt : Bool) -> (case isInt of
                              False => String
                              True => Int) -> String
vts False x = trim x
vts True x = cast x


module Main

import Data.Vect as V

infixr 5 .+.

data Schema = SString
            | SInt
            | SChar
            | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType SChar = Char
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

data Command : Schema -> Type where
     SetSchema : (newSchema : Schema) -> Command schema
     Add : SchemaType schema -> Command schema
     Get : Maybe Integer -> Command schema
     Quit : Command schema

record DataStore where
       constructor MkData
       schema : Schema
       size : Nat
       items : Vect size (SchemaType schema)

-- Writing definitons like below to extract fields for types will become tedious.
-- Instead we can use Idris' record syntax (above), which gives accessor functions as default.
{-
data DataStore : Type where
     MkData : (schema : Schema) ->
              (size : Nat) ->
              (items : Vect size (SchemaType schema)) ->
              DataStore

size : DataStore -> Nat
size (MkData schema size items) = size

schema : DataStore -> Schema
schema (MkData schema size items) = schema

items : (store : DataStore) -> Vect (size store) (SchemaType (schema store))
items (MkData schema size items) = items
-}

parseSchema : List String -> Maybe Schema
parseSchema ("String" :: xs) = case xs of
                                   [] => Just SString
                                   _  => do xs_sch <- parseSchema xs
                                            Just (SString .+. xs_sch)
parseSchema ("Int" :: xs) = case xs of
                                [] => Just SInt
                                _ => do xs_sch <- parseSchema xs
                                        Just (SInt .+. xs_sch)
parseSchema ("Char" :: xs) = case xs of
                                 [] => Just SChar
                                 _  => do xs_sch <- parseSchema xs
                                          Just (SChar .+. xs_sch)
parseSchema _ = Nothing

addToStore : (store : DataStore) -> (SchemaType (schema store)) -> DataStore
addToStore (MkData schema size store) newItem = MkData schema _ (addToData store)
           where
            addToData : Vect oldSize (SchemaType schema) -> Vect (S oldSize) (SchemaType schema)
            addToData [] = [newItem]
            addToData (item :: items) = item :: (addToData items)

display : SchemaType schema -> String
display {schema = SString} item = item
display {schema = SInt} item = cast item
display {schema = SChar} item = cast item
display {schema = (x .+. y)} (iteml, itemr) = "(" ++ (display $ iteml) ++ "," ++ (display $ itemr) ++ ")"

getItem : (id : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getItem id store = let storeItems = items store in
                       case integerToFin id (size store) of
                            Nothing    => Just $ ("Out of range\n", store)
                            (Just pos) => Just $ ((display (V.index pos storeItems)) ++ "\n", store)

parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString input   = getQuoted (unpack input)
            where
            getQuoted : List Char -> Maybe (String, String)
            getQuoted ('"' :: xs)
                      = case span (/= '"') xs of
                             (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
                             _                     => Nothing
            getQuoted _ = Nothing
parsePrefix SChar input     = case unpack input of
                                   (c :: ' ' :: rest) => Just (c, ltrim (pack rest))
                                   _ => Nothing
parsePrefix SInt input      = case span isDigit input of
                                   ("", rest)  => Nothing
                                   (num, rest) => Just (cast num, ltrim rest)
parsePrefix (schemal .+. schemar) input = case parsePrefix schemal input of
                                               Nothing => Nothing
                                               Just (l_val, input') =>
                                                    case parsePrefix schemar input' of
                                                         Nothing => Nothing
                                                         Just (r_val, input'') => Just ((l_val, r_val), input'')

parseBySchema : (schema : Schema) -> (value : String) -> Maybe (SchemaType schema)
parseBySchema schema input = case parsePrefix schema input of
                                  Just (res, "") => Just res
                                  Just _         => Nothing
                                  Nothing        => Nothing

setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
                              Z     => Just (MkData schema _ [])
                              (S k) => Nothing

total parseCommand : (schema : Schema) -> (cmd : String) -> (args : String) -> Maybe (Command schema)
parseCommand schema "add" value  = do schemaType <- parseBySchema schema value
                                      Just $ Add schemaType
parseCommand schema "get" id     = case unpack id of
                                        [] => Just $ Get Nothing
                                        l  => case all isDigit l of
                                                  False => Nothing
                                                  True  => Just $ Get (Just $ cast id)
-- parseCommand "size" _     = Just Size
parseCommand schema "quit" _     = Just Quit
-- parseCommand "search" str = Just $ Search str
{- ... rest of definition as before ... -}
parseCommand schema "schema" rest
             = do schemaok <- parseSchema (words rest)
                  Just (SetSchema schemaok)
parseCommand _ _ _          = Nothing

parse : (schema : Schema) ->
        (input : String) ->
        Maybe (Command schema)
parse schema input = case span (/= ' ') input of
                     (cmd, args) => parseCommand schema cmd (ltrim args)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
             = case parse (schema store) input of
                    Nothing         => Just ("Invalid command\n", store)
                    Just (Add item) =>
                      Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
                    Just (SetSchema schema') =>
                      case setSchema store schema' of
                           Nothing     => Just ("Can't update schema\n", store)
                           Just store' => Just ("OK\n", store')
                    Just (Get pos)  => case pos of
                                           Just position => getItem position store
                                           Nothing       => Just $ (unlines $ toList $ map display (items store), store)
                    Just Quit       => Nothing

main : IO ()
main = replWith (MkData (SString .+. SString .+. SInt) _ []) "Command: " processInput

{-

-- Below seems unnecessarily long and verbose to me, need to refactor!
searchStoreItems : (str : String) -> (storeItems : Vect size String) -> (count : Int) -> (acc : String) -> String
searchStoreItems str [] count acc = acc
searchStoreItems str (x :: xs) count acc = if (isInfixOf str x) then searchStoreItems str xs (count + 1) (acc ++ (show count) ++ ": " ++ x ++ "\n")
                                           else searchStoreItems str xs (count + 1) acc

searchStore : (str : String) -> (store : DataStore) -> String
searchStore str store = let storeItems = items store in (searchStoreItems str storeItems 0 "")

processCommand : (command : Command) -> (store : DataStore) -> Maybe (String, DataStore)
processCommand (Add str) store    = Just $ ("Added " ++ str ++ " to store at id " ++ show (size store) ++ "\n", addToStore store str)
processCommand (Get id) store     = getItem id store
processCommand Size store         = Just $ ("No. of Items in Store is " ++ show (size store) ++ "\n", store)
processCommand (Search str) store = Just $ (searchStore str store, store)
processCommand Quit store         = Nothing

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input = case parse input of
                                Nothing        => Just $ ("Invalid Command\n", store)
                                (Just command) => processCommand command store
-}


module Flexidisc.OrdList.Sub

import Flexidisc.Dec.IsYes
import Flexidisc.OrdList.Fresh
import Flexidisc.OrdList.Label
import Flexidisc.OrdList.Nub
import Flexidisc.OrdList.Row
import Flexidisc.OrdList.Type

%default total
%access public export

||| Proof that an `OrdList` is a sublist of another vect
public export
data Sub : (xs, ys : OrdList k v o) -> Type where
  ||| The empty `Ordlist` is a sublist of the empty `OrdList`
  Empty : Sub [] []
  ||| Making the second list larger don't change the property
  Skip  : Sub xs ys -> Sub xs (y::ys)
  ||| To add an element to the first list, we need to add it to the second one
  Keep  : Sub xs ys -> Sub (x::xs) (x::ys)

%name Sub sub, issub, ss

||| An empty `OrdList` is an ordered subset of any `Any`
subEmpty' : (xs : OrdList k v o) -> Sub [] xs
subEmpty' [] = Empty
subEmpty' (_ :: xs) = Skip (subEmpty' xs)

||| An empty `OrdList` is an ordered subset of any `OrdList`
subEmpty : Sub [] xs
subEmpty {xs} = subEmpty' xs

implementation Uninhabited (Sub (x::xs) []) where
  uninhabited Empty impossible
  uninhabited (Skip _) impossible
  uninhabited (Keep _) impossible

||| A `OrdList` is an ordered subset of itself
subRefl' : (xs : OrdList k v o) -> Sub xs xs
subRefl' [] = Empty
subRefl' (x :: xs) = Keep (subRefl' xs)

||| A `OrdList` is an ordered subset of itself
subRefl : Sub xs xs
subRefl {xs} = subRefl' xs

freshInSub : Sub xs ys -> Fresh l ys -> Fresh l xs
freshInSub Empty fresh = fresh
freshInSub (Skip sub) (f :: fresh) = freshInSub sub fresh
freshInSub (Keep sub) (f :: fresh) = f :: freshInSub sub fresh

||| If the original vector doesn't contain any duplicate,
||| an orderred subset doesn't contain duplicate as well
isNubFromSub : Sub xs ys -> Nub ys -> Nub xs
isNubFromSub Empty y = y
isNubFromSub (Skip sub) (yes :: prf) = isNubFromSub sub prf
isNubFromSub (Keep sub) (yes :: prf) =
  freshInSub sub yes :: isNubFromSub sub prf

%hint
rowFromSub : Sub xs ys -> OrdRow key ty xs -> OrdRow key ty ys
rowFromSub Empty lbl = lbl
rowFromSub (Skip sub) loc = There (rowFromSub sub loc)
rowFromSub (Keep sub) Here = Here
rowFromSub (Keep sub) (There later) = There (rowFromSub sub later)

||| Given the proof that a Label is in an subset of a vect
||| provide a proof that this label is in the initial vect
%hint
labelFromSub : Sub xs ys -> OrdLabel x xs -> OrdLabel x ys
labelFromSub Empty y = y
labelFromSub (Skip z) loc = There (labelFromSub z loc)
labelFromSub (Keep _) Here = Here
labelFromSub (Keep sub) (There later) = There (labelFromSub sub later)


module Imp

import Expr
import Logic
import Maps

%access public export

%default total

data Com : Type where
  CSkip : Com
  CAss : Id -> AExp -> Com
  CSeq : Com -> Com -> Com
  CIf : BExp -> Com -> Com -> Com
  CIf1 : BExp -> Com -> Com
  CWhile : BExp -> Com -> Com
  CFor : Com -> BExp -> Com -> Com -> Com
  CRepeat : Com -> BExp -> Com

infix 5 ::=

SKIP : Com
SKIP = CSkip

(::=) : Id -> AExp -> Com
(::=) = CAss

(>>=) : Com -> (() -> Com) -> Com
(>>=) c f = CSeq c (f ())

WHILE : BExp -> Com -> Com
WHILE = CWhile

syntax IFB [b] THEN [c1] ELSE [c2] FI = CIf b c1 c2

syntax IF1 [b] THEN [c] FI = CIf1 b c

syntax FOR [init] ";" [cond] ";" [updt] DO [body] DONE = CFor init cond updt body

syntax REPEAT [c] UNTIL [b] END = CRepeat c b

data CEval : Com -> State -> State -> Type where
  E_Skip : CEval CSkip st st
  E_Ass : aeval st a1 = n -> CEval (CAss x a1) st (t_update x n st)
  E_Seq : CEval c1 st1 st2 -> CEval c2 st2 st3 ->
          CEval (CSeq c1 c2) st1 st3
  E_IfTrue : beval st b = True -> CEval c1 st st1 ->
             CEval (CIf b c1 c2) st st1
  E_IfFalse : beval st b = False -> CEval c2 st st1 ->
              CEval (CIf b c1 c2) st st1
  E_If1True : beval st b = True -> CEval c st st1 ->
              CEval (CIf1 b c) st st1
  E_If1False : beval st b = False -> CEval (CIf1 b c) st st
  E_WhileEnd : beval st b = False -> CEval (CWhile b c) st st
  E_WhileLoop : beval st b = True ->
                CEval c st st1 -> CEval (CWhile b c) st1 st2 ->
                CEval (CWhile b c) st st2
  E_For : CEval init st1 st2 ->
          CEval (CWhile cond (CSeq body updt)) st2 st3 ->
          CEval (CFor init cond updt body) st1 st3
  E_Repeat : CEval c st st1 ->
             CEval (CWhile (not b) c) st1 st2 ->
             CEval (CRepeat c b) st st2

syntax [c1] "/" [st1] "\\\\" [st2] = CEval c1 st1 st2

repeat_example_1 : CEval (REPEAT do
                            X ::= 1
                            Y ::= Y + 1
                          UNTIL X == 1 END)
                         Expr.empty_state
                         (t_update Y 1 (t_update X 1 Expr.empty_state))
repeat_example_1 = E_Repeat (E_Seq (E_Ass Refl)
                                   (E_Ass Refl))
                            (E_WhileEnd Refl)

ceval_deterministic : (c / st \\ st1) -> (c / st \\ st2) -> st1 = st2
ceval_deterministic E_Skip E_Skip = Refl
ceval_deterministic (E_Ass aev1) (E_Ass aev2) =
  rewrite sym aev1
  in rewrite sym aev2
  in Refl
ceval_deterministic {st2} (E_Seq cev11 cev12) (E_Seq {c2} cev21 cev22) =
  let ih = ceval_deterministic cev11 cev21
      cev22' = replace (sym ih) cev22 {P=\x=>CEval c2 x st2}
  in ceval_deterministic cev12 cev22'
ceval_deterministic (E_IfTrue _ cev1) (E_IfTrue _ cev2) =
  ceval_deterministic cev1 cev2
ceval_deterministic (E_IfTrue prf1 _) (E_IfFalse prf2 _) =
  absurd $ replace prf1 prf2 {P=\x=>x=False}
ceval_deterministic (E_IfFalse prf1 _) (E_IfTrue prf2 _) =
  absurd $ replace prf2 prf1 {P=\x=>x=False}
ceval_deterministic (E_IfFalse _ cev1) (E_IfFalse _ cev2) =
  ceval_deterministic cev1 cev2
ceval_deterministic (E_If1True _ cc1) (E_If1True _ cc2) =
  ceval_deterministic cc1 cc2
ceval_deterministic (E_If1True prf1 _) (E_If1False prf2) =
  absurd $ trans (sym prf1) prf2
ceval_deterministic (E_If1False prf1) (E_If1True prf2 _) =
  absurd $ trans (sym prf1) prf2
ceval_deterministic (E_If1False _) (E_If1False _) = Refl
ceval_deterministic (E_WhileEnd _) (E_WhileEnd _) = Refl
ceval_deterministic (E_WhileEnd prf1) (E_WhileLoop prf2 _ _) =
  absurd $ replace prf2 prf1 {P=\x=>x=False}
ceval_deterministic (E_WhileLoop prf1 _ _) (E_WhileEnd prf2) =
  absurd $ replace prf1 prf2 {P=\x=>x=False}
ceval_deterministic {st2} (E_WhileLoop _ cev11 cev12)
                          (E_WhileLoop {b} {c} _ cev21 cev22) =
  let ih = ceval_deterministic cev11 cev21
      cev22' = replace (sym ih) cev22 {P=\x=>CEval (CWhile b c) x st2}
  in ceval_deterministic cev12 cev22'
ceval_deterministic {st2}
                    (E_For cinit1 cwhile1)
                    (E_For {cond} {body} {updt} cinit2 cwhile2) =
  let ih = ceval_deterministic cinit1 cinit2
      cwhile2' = replace {P=\x => CEval (CWhile cond (CSeq body updt)) x st2}
                         (sym ih) cwhile2
  in ceval_deterministic cwhile1 cwhile2'
ceval_deterministic (E_Repeat cc1 cwhile1) (E_Repeat {b} {c} {st2} cc2 cwhile2) =
  let ih = ceval_deterministic cc1 cc2
      cwhile2' = replace {P=\x => CEval (CWhile (not b) c) x st2}
                         (sym ih) cwhile2
  in ceval_deterministic cwhile1 cwhile2'


||| A telescope is the variable context in a dependently typed program.
||| Dependent types with free varialbes  are really only well-defined in a telescope.
|||
||| A segment of a telescope is a tuple of types in that
||| telescope. These are usually implicit in formal developments, but
||| seem to be crucial to get a compositional account. Here we use
||| them to get 'n-ary dependent function' (compare with `Data.Fun`
||| and `Data.Rel`).
|||
||| I've learned this from Conor McBride on an SPLV'19 bus ride.
||| A literary reference would be welcome. This paper is a start:
||| Unifiers as Equivalences: Proof-Relevant Unification of Dependently Typed Data.
||| Jesper Cockx, Dominique Devriese, Frank Piessens, ICFP'16.
||| but they don't seem to have segments and their left action on contexts.
module Data.Telescope

import public Data.Telescope.Telescope
import public Data.Telescope.Segment
import public Data.Telescope.SimpleFun
import public Data.Telescope.Fun
import public Data.Telescope.Congruence


-- Printf.idr
-- A C-style printf function, demonstarting
-- variable function arguments

module Printf

export
data Format = Num Format
            | Chr Format
            | Dbl Format
            | Str Format
            | Lit String Format
            | End

%name Format fmt

export
PrintfType : Format -> Type
PrintfType (Num fmt) = (i : Int) -> PrintfType fmt
PrintfType (Chr fmt) = (c : Char) -> PrintfType fmt
PrintfType (Dbl fmt) = (f : Double) -> PrintfType fmt
PrintfType (Str fmt) = (str : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

||| Generates a string from the given format spec
export
printfFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Num fmt) acc = \i => printfFmt fmt (acc ++ (show i))
printfFmt (Chr fmt) acc = \c => printfFmt fmt (acc ++ (show c))
printfFmt (Dbl fmt) acc = \f => printfFmt fmt (acc ++ (show f))
printfFmt (Str fmt) acc = \str => printfFmt fmt (acc ++ str)
printfFmt (Lit str fmt) acc = printfFmt fmt (acc ++ str)
printfFmt End acc = acc

||| Convert given char list to format data type
export
toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Num (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Chr (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             (Lit lit chars') => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt

||| Outputs the given format string as String
||| @fmt Format specification
export
printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""


module LightClick.Types.Direction

import Decidable.Equality

import Toolkit.Decidable.Informative

%default total

public export
data Direction = IN | OUT | INOUT

export
Show Direction where
  show IN = "IN"
  show OUT = "OUT"
  show INOUT = "INOUT"

inNotOut : (IN = OUT) -> Void
inNotOut Refl impossible

inNotInOut : (IN = INOUT) -> Void
inNotInOut Refl impossible

outNotInOut : (OUT = INOUT) -> Void
outNotInOut Refl impossible

export
DecEq Direction where
  decEq IN IN = Yes Refl
  decEq IN OUT = No inNotOut
  decEq IN INOUT = No inNotInOut

  decEq OUT IN = No (negEqSym inNotOut)
  decEq OUT OUT = Yes Refl
  decEq OUT INOUT = No outNotInOut

  decEq INOUT IN = No (negEqSym inNotInOut)
  decEq INOUT OUT = No (negEqSym outNotInOut)
  decEq INOUT INOUT = Yes Refl

namespace Valid

  public export
  data Valid : (src,dest : Direction) -> Type where
    VOI : Valid OUT   IN
    VBI : Valid INOUT IN
    VOB : Valid OUT   INOUT
    VBB : Valid INOUT INOUT

  dirIsLR : Valid IN dest -> Void
  dirIsLR VOI impossible
  dirIsLR VBI impossible
  dirIsLR VOB impossible
  dirIsLR VBB impossible

  dirAreSame : Valid OUT OUT -> Void
  dirAreSame VOI impossible
  dirAreSame VBI impossible
  dirAreSame VOB impossible
  dirAreSame VBB impossible

  dirIsLR' : Valid INOUT OUT -> Void
  dirIsLR' VOI impossible
  dirIsLR' VBI impossible
  dirIsLR' VOB impossible
  dirIsLR' VBB impossible

  public export
  data Error = InputCannotSend | DirIsSame | OutputCannotReceive

  export
  valid : (src, dest : Direction)
                    -> DecInfo Direction.Valid.Error (Valid src dest)
  valid IN dest = No InputCannotSend dirIsLR
  valid OUT dest with (dest)
    valid OUT dest | IN = Yes VOI
    valid OUT dest | OUT = No DirIsSame dirAreSame
    valid OUT dest | INOUT = Yes VOB

  valid INOUT dest with (dest)
    valid INOUT dest | IN = Yes VBI
    valid INOUT dest | OUT = No OutputCannotReceive (dirIsLR')
    valid INOUT dest | INOUT = Yes VBB

namespace Safe

  public export
  data Safe : (src,dest : Direction) -> Type where
    SOI : Safe OUT   IN
    SBI : Safe INOUT IN
    SBB : Safe INOUT INOUT

  safeDirCannotIn : Safe IN dest -> Void
  safeDirCannotIn SOI impossible
  safeDirCannotIn SBI impossible
  safeDirCannotIn SBB impossible

  safeDirNotOO : Safe OUT OUT -> Void
  safeDirNotOO SOI impossible
  safeDirNotOO SBI impossible
  safeDirNotOO SBB impossible

  safeDirNoFeedbackOO : Safe OUT INOUT -> Void
  safeDirNoFeedbackOO SOI impossible
  safeDirNoFeedbackOO SBI impossible
  safeDirNoFeedbackOO SBB impossible

  safeDirNoFeedbackBO : Safe INOUT OUT -> Void
  safeDirNoFeedbackBO SOI impossible
  safeDirNoFeedbackBO SBI impossible
  safeDirNoFeedbackBO SBB impossible

  public export
  data Error = VCError Direction.Valid.Error
             | PossibleFeedbackFromReceiver
             | PossibleFeedbackFromSender

  export
  safe : (src, dest : Direction) -> DecInfo Direction.Safe.Error (Safe src dest)
  safe IN dest = No (VCError InputCannotSend) safeDirCannotIn
  safe OUT dest with (dest)
    safe OUT dest | IN = Yes SOI
    safe OUT dest | OUT = No (VCError DirIsSame) safeDirNotOO
    safe OUT dest | INOUT = No PossibleFeedbackFromReceiver safeDirNoFeedbackOO

  safe INOUT dest with (dest)
    safe INOUT dest | IN = Yes SBI
    safe INOUT dest | OUT = No PossibleFeedbackFromSender safeDirNoFeedbackBO
    safe INOUT dest | INOUT = Yes SBB


module Data.SortedMap

import Data.Nat

-- TODO: write split

private
data Tree : Nat -> (k : Type) -> Type -> Ord k -> Type where
  Leaf : k -> v -> Tree Z k v o
  Branch2 : Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o
  Branch3 : Tree n k v o -> k -> Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o

branch4 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch4 a b c d e f g =
  Branch2 (Branch2 a b c) d (Branch2 e f g)

branch5 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch5 a b c d e f g h i =
  Branch2 (Branch2 a b c) d (Branch3 e f g h i)

branch6 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch6 a b c d e f g h i j k =
  Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

branch7 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch7 a b c d e f g h i j k l m =
  Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

merge1 : Tree n k v o -> k -> Tree (S n) k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o
merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i
merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge2 : Tree (S n) k v o -> k -> Tree n k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o
merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i
merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge3 : Tree (S n) k v o -> k -> Tree (S n) k v o -> k -> Tree n k v o -> Tree (S (S n)) k v o
merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i
merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

treeLookup : (Ord k) => k -> Tree n k v o -> Maybe v
treeLookup k (Leaf k' v) =
 if k == k'
 then Just v
 else Nothing
treeLookup k (Branch2 t1 k' t2) =
  if k <= k' then
    treeLookup k t1
  else
    treeLookup k t2
treeLookup k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    treeLookup k t1
  else if k <= k2 then
    treeLookup k t2
  else
    treeLookup k t3

treeInsert' : (Ord k) => k -> v -> Tree n k v o -> Either (Tree n k v o) (Tree n k v o, k, Tree n k v o)
treeInsert' k v (Leaf k' v') =
  case compare k k' of
    LT => Right (Leaf k v, k, Leaf k' v')
    EQ => Left (Leaf k v)
    GT => Right (Leaf k' v', k', Leaf k v)
treeInsert' k v (Branch2 t1 k' t2) =
  if k <= k' then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right (a, b, c) => Left (Branch3 a b c k' t2)
  else
    case treeInsert' k v t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right (a, b, c) => Left (Branch3 t1 k' a b c)
treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)
  else
    if k <= k2 then
      case treeInsert' k v t2 of
        Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
        Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)
    else
      case treeInsert' k v t3 of
        Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
        Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

treeInsert : (Ord k) => k -> v -> Tree n k v o -> Either (Tree n k v o) (Tree (S n) k v o)
treeInsert k v t =
  case treeInsert' k v t of
    Left t' => Left t'
    Right (a, b, c) => Right (Branch2 a b c)

delType : Nat -> (k : Type) -> Type -> Ord k -> Type
delType Z k v o = ()
delType (S n) k v o = Tree n k v o

treeDelete : (Ord k) => {n : Nat} -> k -> Tree n k v o -> Either (Tree n k v o) (delType n k v o)
treeDelete k (Leaf k' v) =
  if k == k' then
    Right ()
  else
    Left (Leaf k' v)
treeDelete {n=S Z} k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right () => Right t2
  else
    case treeDelete k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right () => Right t1
treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right () => Left (Branch2 t2 k2 t3)
  else if k <= k2 then
    case treeDelete k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right () => Left (Branch2 t1 k1 t3)
  else
    case treeDelete k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right () => Left (Branch2 t1 k1 t2)
treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right t1' =>
        case t2 of
          Branch2 a b c => Right (Branch3 t1' k' a b c)
          Branch3 a b c d e => Left (branch4 t1' k' a b c d e)
  else
    case treeDelete k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right t2' =>
        case t1 of
          Branch2 a b c => Right (Branch3 a b c k' t2')
          Branch3 a b c d e => Left (branch4 a b c d e k' t2')
treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right t1' => Left (merge1 t1' k1 t2 k2 t3)
  else if k <= k2 then
    case treeDelete k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right t2' => Left (merge2 t1 k1 t2' k2 t3)
  else
    case treeDelete k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right t3' => Left (merge3 t1 k1 t2 k2 t3')

treeToList : {n: Nat} -> Tree n k v o -> List (k, v)
treeToList = treeToList' (:: [])
  where
    treeToList' : ((k, v) -> List (k, v)) -> {n: Nat} -> Tree n k v o -> List (k, v)
    treeToList' cont {n = Z} (Leaf k v) = cont (k, v)
    treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1
    treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

public export
data SortedMap : Type -> Type -> Type where
  Empty : Ord k => SortedMap k v
  M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v

export
empty : Ord k => SortedMap k v
empty = Empty

export
lookup : k -> SortedMap k v -> Maybe v
lookup _ Empty = Nothing
lookup k (M _ t) = treeLookup k t

export
insert : k -> v -> SortedMap k v -> SortedMap k v
insert k v Empty = M Z (Leaf k v)
insert k v (M _ t) =
  case treeInsert k v t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
insertFrom : Foldable f => f (k, v) -> SortedMap k v -> SortedMap k v
insertFrom = flip $ foldl $ flip $ uncurry insert

export
delete : k -> SortedMap k v -> SortedMap k v
delete _ Empty = Empty
delete k (M Z t) =
  case treeDelete k t of
    Left t' => (M _ t')
    Right () => Empty
delete k (M (S _) t) =
  case treeDelete k t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
fromList : Ord k => List (k, v) -> SortedMap k v
fromList l = foldl (flip (uncurry insert)) empty l

export
toList : SortedMap k v -> List (k, v)
toList Empty = []
toList (M _ t) = treeToList t

||| Gets the keys of the map.
export
keys : SortedMap k v -> List k
keys = map fst . toList

||| Gets the values of the map. Could contain duplicates.
export
values : SortedMap k v -> List v
values = map snd . toList

export
null : SortedMap k v -> Bool
null Empty = True
null (M _ _) = False

treeMap : (a -> b) -> Tree n k a o -> Tree n k b o
treeMap f (Leaf k v) = Leaf k (f v)
treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
treeMap f (Branch3 t1 k1 t2 k2 t3)
    = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

export
implementation Functor (SortedMap k) where
  map _ Empty = Empty
  map f (M n t) = M _ (treeMap f t)

||| Merge two maps. When encountering duplicate keys, using a function to combine the values.
||| Uses the ordering of the first map given.
export
mergeWith : (v -> v -> v) -> SortedMap k v -> SortedMap k v -> SortedMap k v
mergeWith f x y = insertFrom inserted x where
  inserted : List (k, v)
  inserted = do
    (k, v) <- toList y
    let v' = (maybe id f $ lookup k x) v
    pure (k, v')

||| Merge two maps using the Semigroup (and by extension, Monoid) operation.
||| Uses mergeWith internally, so the ordering of the left map is kept.
export
merge : Semigroup v => SortedMap k v -> SortedMap k v -> SortedMap k v
merge = mergeWith (<+>)

||| Left-biased merge, also keeps the ordering specified  by the left map.
export
mergeLeft : SortedMap k v -> SortedMap k v -> SortedMap k v
mergeLeft = mergeWith const

export
(Show k, Show v) => Show (SortedMap k v) where
   show m = "fromList " ++ (show $ toList m)

-- TODO: is this the right variant of merge to use for this? I think it is, but
-- I could also see the advantages of using `mergeLeft`. The current approach is
-- strictly more powerful I believe, because `mergeLeft` can be emulated with
-- the `First` monoid. However, this does require more code to do the same
-- thing.
export
Semigroup v => Semigroup (SortedMap k v) where
  (<+>) = merge

||| For `neutral <+> y`, y is rebuilt in `Ord k`, so this is not a "strict" Monoid.
||| However, semantically, it should be equal.
export
(Ord k, Semigroup v) => Monoid (SortedMap k v) where
  neutral = empty


--
-- Primitive casts: Specification
--
-- a. Unsigned integers
--
--    Unsigned integers with a precision of x bit have a valid
--    range of [0,2^x - 1]. When casting from another integral type of value y,
--    the value is checked for being in bounds, and if it is not, the
--    unsigned remainder modulo 2^x of y is returned.
--
--    When casting from a `Double`, the value is first truncated towards 0,
--    before applying the inbounds check and (if necessary) calculating
--    the unsigned remainder modulo 2^x.
--
--    When casting from a `String`, the value is first converted to a floating
--    point number by the backend and then truncated as described above.
--
--    Example: For `Bits8` the valid range is [0,255]. Below are some
--             example casts.
--
--               cast {from = Integer} {to = Bits8} 12   = 12
--               cast {from = Integer} {to = Bits8} 256  = 0
--               cast {from = Integer} {to = Bits8} 259  = 3
--               cast {from = Integer} {to = Bits8} (-2) = 254
--               cast {from = Double} {to = Bits8} (-12.001) = 244
--               cast {from = Double} {to = Bits8} ("-12.001") = 244
--
-- b. Signed integers
--
--    Signed integers with a precision of x bit have a valid
--    range of [-2^(x-1),2^(x-1) - 1]. When casting from another
--    integral type of value y, the unsigned remainder module 2^x
--    is calculated. If the result is >= 2^(x-1), 2^x is subtracted
--    from the result. This is the same behavior as for instance in Haskell.
--
--    When casting from a `Double`, the value is first truncated towards 0,
--    before applying the inbounds check and (if necessary) truncating
--    the value.
--
--    When casting from a `String`, the value is first converted to a floating
--    point number by the backend and then truncated as described above.
--
--    Example: For `Int8` the valid range is [-128,127]. Below are some
--             example casts.
--
--               cast {from = Integer} {to = Int8} 12   = 12
--               cast {from = Integer} {to = Int8} 256  = 0
--               cast {from = Integer} {to = Int8} 259  = 4
--               cast {from = Integer} {to = Int8} (-128) = (-128)
--               cast {from = Integer} {to = Int8} (-129) = 127
--               cast {from = Double}  {to = Int8} (-12.001) = (-12)
--               cast {from = Double}  {to = Int8} ("-12.001") = (-12)
--
-- c. Characters
--
--    Casts from all integral types to `Char` are supported. Note however,
--    that only casts in the non-surrogate range are supported, that is
--    values in the ranges [0,0xd7ff] and [0xe000,0x10ffff], or, in decimal
--    notation, [0,55295] and [57344,1114111].
--
--    All casts from integer types to `Char` are therefore submitted to a
--    bounds check, and, in case the value is out of bounds, are converted to `'\0'`.
--
--
-- Test all casts from and to integral types.
-- The `Cast` implementations in here should go to `Prelude`, once
-- a new minor version of the compiler is released.
--
-- These tests verify also that the full range of integer literals
-- is supported for every integral type.
--
-- Nothing fancy is being done here:
-- All test cases have been hand-written.

import Data.List

--------------------------------------------------------------------------------
--          Tests
--------------------------------------------------------------------------------

showTpe : Type -> String
showTpe Bits16  = "Bits16"
showTpe Bits32  = "Bits32"
showTpe Bits64  = "Bits64"
showTpe Bits8   = "Bits8"
showTpe Char    = "Char"
showTpe Double  = "Double"
showTpe Int     = "Int"
showTpe Int16   = "Int16"
showTpe Int32   = "Int32"
showTpe Int64   = "Int64"
showTpe Int8    = "Int8"
showTpe Integer = "Integer"
showTpe String  = "String"
showTpe _       = "unknown type"

testCasts : (a: Type) -> (b : Type) -> (Cast a b, Show a, Show b, Eq b) =>
            List (a,b) -> List String
testCasts a b = mapMaybe doTest
  where doTest : (a,b) -> Maybe String
        doTest (x,y) =
          let y2 = cast {to = b} x
           in if y == y2 then Nothing
              else Just $  #"Invalid cast from \#{showTpe a} to \#{showTpe b}: "#
                        ++ #"expected \#{show y} but got \#{show y2} when casting from \#{show x}"#

maxBits8 : Bits8
maxBits8 = 0xff

maxBits16 : Bits16
maxBits16 = 0xffff

maxBits32 : Bits32
maxBits32 = 0xffffffff

maxBits64 : Bits64
maxBits64 = 0xffffffffffffffff

results : List String
results =  testCasts Int8 Int16   [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Int32   [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Int64   [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Int     [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Double  [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 String  [(-129,"127"),(-128,"-128"),(0,"0"),(127,"127"),(128,"-128")]
        ++ testCasts Int8 Integer [(-129,127),(-128,-128),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits8   [(-129,127),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits16  [(-129,127),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits32  [(-129,127),(0,0),(127,127),(128,-128)]
        ++ testCasts Int8 Bits64  [(-129,127),(0,0),(127,127),(128,-128)]

        ++ testCasts Int16 Int8    [(-32769,32767),(-32768,0),(0,0),(32767,-1),(32768,0)]
        ++ testCasts Int16 Int32   [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Int64   [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Int     [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Double  [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 String  [(-32769,"32767"),(-32768,"-32768"),(0,"0"),(32767,"32767"),(32768,"-32768")]
        ++ testCasts Int16 Integer [(-32769,32767),(-32768,-32768),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits8   [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits16  [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits32  [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]
        ++ testCasts Int16 Bits64  [(-32769,32767),(0,0),(32767,32767),(32768,-32768)]

        ++ testCasts Int32 Int8    [(-2147483649,2147483647),(-2147483648,0),(0,0),(2147483647,-1),(2147483648,0)]
        ++ testCasts Int32 Int16   [(-2147483649,2147483647),(-2147483648,0),(0,0),(2147483647,-1),(2147483648,0)]
        ++ testCasts Int32 Int64   [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Int     [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Double  [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 String  [(-2147483649,"2147483647"),(-2147483648,"-2147483648"),(0,"0"),(2147483647,"2147483647"),(2147483648,"-2147483648")]
        ++ testCasts Int32 Integer [(-2147483649,2147483647),(-2147483648,-2147483648),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits8   [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits16  [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits32  [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]
        ++ testCasts Int32 Bits64  [(-2147483649,2147483647),(0,0),(2147483647,2147483647),(2147483648,-2147483648)]

        ++ testCasts Int64 Int8    [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int64 Int16   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int64 Int32   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int64 Int     [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int64 Double  [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int64 String  [(-9223372036854775809,"9223372036854775807"),(-9223372036854775808,"-9223372036854775808"),(0,"0"),(9223372036854775807,"9223372036854775807"),(9223372036854775808,"-9223372036854775808")]
        ++ testCasts Int64 Integer [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int64 Bits8   [(-9223372036854775809,255),(0,0),(9223372036854775807,0xff),(9223372036854775808,0)]
        ++ testCasts Int64 Bits16  [(-9223372036854775809,65535),(0,0),(9223372036854775807,0xffff),(9223372036854775808,0)]
        ++ testCasts Int64 Bits32  [(-9223372036854775809,4294967295),(0,0),(9223372036854775807,0xffffffff),(9223372036854775808,0)]
        ++ testCasts Int64 Bits64  [(-9223372036854775809,9223372036854775807),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]

        ++ testCasts Int Int8    [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int Int16   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int Int32   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,0),(0,0),(9223372036854775807,-1),(9223372036854775808,0)]
        ++ testCasts Int Int64   [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int Double  [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int String  [(-9223372036854775809,"9223372036854775807"),(-9223372036854775808,"-9223372036854775808"),(0,"0"),(9223372036854775807,"9223372036854775807"),(9223372036854775808,"-9223372036854775808")]
        ++ testCasts Int Integer [(-9223372036854775809,9223372036854775807),(-9223372036854775808,-9223372036854775808),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]
        ++ testCasts Int Bits8   [(-9223372036854775809,255),(0,0),(9223372036854775807,0xff),(9223372036854775808,0)]
        ++ testCasts Int Bits16  [(-9223372036854775809,65535),(0,0),(9223372036854775807,0xffff),(9223372036854775808,0)]
        ++ testCasts Int Bits32  [(-9223372036854775809,4294967295),(0,0),(9223372036854775807,0xffffffff),(9223372036854775808,0)]
        ++ testCasts Int Bits64  [(-9223372036854775809,9223372036854775807),(0,0),(9223372036854775807,9223372036854775807),(9223372036854775808,-9223372036854775808)]

        ++ testCasts Integer Int8    [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int16   [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int32   [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int64   [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Int     [(-170141183460469231731687303715884105729,-1),(-170141183460469231731687303715884105728,0),(0,0),(170141183460469231731687303715884105727,-1),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer String  [(-170141183460469231731687303715884105729,"-170141183460469231731687303715884105729"),(-170141183460469231731687303715884105728,"-170141183460469231731687303715884105728"),(0,"0"),(170141183460469231731687303715884105727,"170141183460469231731687303715884105727"),(170141183460469231731687303715884105728,"170141183460469231731687303715884105728")]
        ++ testCasts Integer Bits8   [(-170141183460469231731687303715884105729,maxBits8),(0,0),(170141183460469231731687303715884105727,0xff),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Bits16  [(-170141183460469231731687303715884105729,maxBits16),(0,0),(170141183460469231731687303715884105727,0xffff),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Bits32  [(-170141183460469231731687303715884105729,maxBits32),(0,0),(170141183460469231731687303715884105727,0xffffffff),(170141183460469231731687303715884105728,0)]
        ++ testCasts Integer Bits64  [(-170141183460469231731687303715884105729,maxBits64),(0,0),(170141183460469231731687303715884105727,0xffffffffffffffff),(170141183460469231731687303715884105728,0)]

        ++ testCasts Bits8 Int8    [(0,0),(255,-1),(256,0)]
        ++ testCasts Bits8 Int16   [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Int32   [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Int64   [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Int     [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Double  [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 String  [(0,"0"),(255,"255"),(256,"0")]
        ++ testCasts Bits8 Integer [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Bits16  [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Bits32  [(0,0),(255,255),(256,0)]
        ++ testCasts Bits8 Bits64  [(0,0),(255,255),(256,0)]

        ++ testCasts Bits16 Int8    [(0,0),(0xffff,-1),(0x10000,0)]
        ++ testCasts Bits16 Int16   [(0,0),(0xffff,-1),(0x10000,0)]
        ++ testCasts Bits16 Int32   [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Int64   [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Int     [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Double  [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 String  [(0,"0"),(0xffff,"65535"),(0x10000,"0")]
        ++ testCasts Bits16 Integer [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Bits8   [(0,0),(0xffff,0xff),(0x10000,0)]
        ++ testCasts Bits16 Bits32  [(0,0),(0xffff,0xffff),(0x10000,0)]
        ++ testCasts Bits16 Bits64  [(0,0),(0xffff,0xffff),(0x10000,0)]

        ++ testCasts Bits32 Int8    [(0,0),(0xffffffff,-1),(0x100000000,0)]
        ++ testCasts Bits32 Int16   [(0,0),(0xffffffff,-1),(0x100000000,0)]
        ++ testCasts Bits32 Int32   [(0,0),(0xffffffff,-1),(0x100000000,0)]
        ++ testCasts Bits32 Int64   [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 Int     [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 Double  [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 String  [(0,"0"),(0xffffffff,"4294967295"),(0x100000000,"0")]
        ++ testCasts Bits32 Integer [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]
        ++ testCasts Bits32 Bits8   [(0,0),(0xffffffff,0xff),(0x100000000,0)]
        ++ testCasts Bits32 Bits16  [(0,0),(0xffffffff,0xffff),(0x100000000,0)]
        ++ testCasts Bits32 Bits64  [(0,0),(0xffffffff,0xffffffff),(0x100000000,0)]

        ++ testCasts Bits64 Int8    [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int16   [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int32   [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int64   [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Int     [(0,0),(0xffffffffffffffff,-1),(0x10000000000000000,0)]
        ++ testCasts Bits64 Double  [(0,0),(0xffffffffffffffff,0xffffffffffffffff),(0x10000000000000000,0)]
        ++ testCasts Bits64 String  [(0,"0"),(0xffffffffffffffff,"18446744073709551615"),(0x10000000000000000,"0")]
        ++ testCasts Bits64 Integer [(0,0),(0xffffffffffffffff,0xffffffffffffffff),(0x10000000000000000,0)]
        ++ testCasts Bits64 Bits8   [(0,0),(0xffffffffffffffff,0xff),(0x10000000000000000,0)]
        ++ testCasts Bits64 Bits16  [(0,0),(0xffffffffffffffff,0xffff),(0x10000000000000000,0)]
        ++ testCasts Bits64 Bits32  [(0,0),(0xffffffffffffffff,0xffffffff),(0x10000000000000000,0)]

        ++ testCasts String Int8    [("-129",127),("-128",-128),("0",0),("127",127), ("128",-128)]
        ++ testCasts String Int16   [("-32769",32767),("-32768",-32768),("0",0),("32767",32767), ("32768",-32768)]
        ++ testCasts String Int32   [("-2147483649",2147483647),("-2147483648",-2147483648),("0",0),("2147483647",2147483647), ("2147483648",-2147483648)]
        ++ testCasts String Int64   [("-9223372036854775809",9223372036854775807),("-9223372036854775808",-9223372036854775808),("0",0),("9223372036854775807",9223372036854775807), ("9223372036854775808",-9223372036854775808)]
        ++ testCasts String Int     [("-9223372036854775809",9223372036854775807),("-9223372036854775808",-9223372036854775808),("0",0),("9223372036854775807",9223372036854775807), ("9223372036854775808",-9223372036854775808)]
        ++ testCasts String Integer [("-170141183460469231731687303715884105728",-170141183460469231731687303715884105728),("-170141183460469231731687303715884105728",-170141183460469231731687303715884105728),("0",0),("170141183460469231731687303715884105728",170141183460469231731687303715884105728)]
        ++ testCasts String Bits8   [("0",0),("255",255), ("256",0)]
        ++ testCasts String Bits16  [("0",0),("65535",65535), ("65536",0)]
        ++ testCasts String Bits32  [("0",0),("4294967295",4294967295), ("4294967296",0)]
        ++ testCasts String Bits64  [("0",0),("18446744073709551615",18446744073709551615), ("18446744073709551616",0)]

        ++ testCasts Double Int8    [(-129.0, 127),(-128.0,-128),(-12.001,-12),(12.001,12),(127.0,127),(128.0,-128)]
        ++ testCasts Double Int16   [(-32769.0, 32767),(-32768.0,-32768),(-12.001,-12),(12.001,12),(32767.0,32767),(32768.0,-32768)]
        ++ testCasts Double Int32   [(-2147483649.0,2147483647),(-2147483648.0,-2147483648),(-12.001,-12),(12.001,12),(2147483647.0,2147483647),(2147483648.0,-2147483648)]
        ++ testCasts Double Int64   [(-9223372036854775808.0,-9223372036854775808),(-12.001,-12),(12.001,12),(9223372036854775808.0,-9223372036854775808)]
        ++ testCasts Double Int     [(-9223372036854775808.0,-9223372036854775808),(-12.001,-12),(12.001,12),(9223372036854775808.0,-9223372036854775808)]
        ++ testCasts Double Bits8   [(0.0,0),(255.0,255), (256.0,0)]
        ++ testCasts Double Bits16  [(0.0,0),(65535.0,65535), (65536.0,0)]
        ++ testCasts Double Bits32  [(0.0,0),(4294967295.0,4294967295), (4294967296.0,0)]
        ++ testCasts Double Bits64  [(0.0,0),(18446744073709551616.0,0)]

        ++ testCasts Int8 Char    [(-1, '\x0'), (80, 'P')]
        ++ testCasts Int16 Char   [(-1, '\x0'), (80, 'P')]
        ++ testCasts Int32 Char   [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Int64 Char   [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Int   Char   [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Bits8 Char   [(80, 'P')]
        ++ testCasts Bits16 Char  [(80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000')]
        ++ testCasts Bits32 Char  [(80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Bits64 Char  [(80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]
        ++ testCasts Integer Char [(-1, '\x0'), (80, 'P'), (55295, '\xd7ff'), (55296, '\x0'), (57344, '\xe000'), (1114111, '\x10ffff'), (1114112, '\x0')]

--------------------------------------------------------------------------------
--          Main
--------------------------------------------------------------------------------

main : IO ()
main = traverse_ putStrLn results


module ProofColDivSeqMain

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqLvDown
import Sub01Apply18x3
import Sub02Apply54x12
import Sub03Apply54x30
import Sub04Apply54x48
import Sub05Apply9x6
import Sub06Apply36x9
import Sub07Apply108x27
import Sub08Apply108x63
import Sub09Apply108x99
import Sub10Apply108x18
import Sub11Apply108x54
import Sub12Apply108x90
import Sub13Apply108x36
import Sub14Apply108x72
import Sub15Apply108x108

%default total
-- %language ElabReflection

-- 無限降下法の十分条件
unifi : (n:Nat) -> P (S n) 2 -> (m ** (LTE (S m) (S n), P m 2))
unifi n prf with (mod3 n)
  unifi (j + j + j)         prf | ThreeZero with (parity j)
    unifi ((k+k) + (k+k) + (k+k))       prf | ThreeZero | Even = apply18x3 prf
    unifi (S (k+k) + S (k+k) + S (k+k)) prf | ThreeZero | Odd with (mod3 k)
      unifi (S ((l+l+l)+(l+l+l)) + S ((l+l+l)+(l+l+l)) + S ((l+l+l)+(l+l+l))) prf | ThreeZero | Odd | ThreeZero = apply54x12 prf
      unifi (S ((S (l+l+l))+(S (l+l+l))) + S ((S (l+l+l))+(S (l+l+l))) + S ((S (l+l+l))+(S (l+l+l)))) prf | ThreeZero | Odd | ThreeOne = apply54x30 prf
      unifi (S ((S (S (l+l+l)))+(S (S (l+l+l)))) + S ((S (S (l+l+l)))+(S (S (l+l+l)))) + S ((S (S (l+l+l)))+(S (S (l+l+l))))) prf | ThreeZero | Odd | ThreeTwo = apply54x48 prf
  unifi (S (j + j + j))     prf | ThreeOne = apply9x6 prf
  unifi (S (S (j + j + j))) prf | ThreeTwo with (parity j)
    unifi (S (S ((k+k) + (k+k) + (k+k)))) prf | ThreeTwo | Even with (parity k)
      unifi (S (S (((l+l)+(l+l)) + ((l+l)+(l+l)) + ((l+l)+(l+l))))) prf | ThreeTwo | Even | Even = apply36x9 prf
      unifi (S (S ((S (l+l)+S (l+l)) + (S (l+l)+S (l+l)) + (S (l+l)+S (l+l))))) prf | ThreeTwo | Even | Odd with (mod3 l)
        unifi (S (S ((S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o))) + (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o))) + (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o)))))) prf | ThreeTwo | Even | Odd | ThreeZero = apply108x27 prf
        unifi (S (S ((S (S (o+o+o)+S (o+o+o))+S (S (o+o+o)+ S (o+o+o))) + (S (S (o+o+o)+ S (o+o+o))+S (S (o+o+o)+ S (o+o+o))) + (S (S (o+o+o)+ S (o+o+o))+S (S (o+o+o)+ S (o+o+o)))))) prf | ThreeTwo | Even | Odd | ThreeOne = apply108x63 prf
        unifi (S (S ((S (S (S (o+o+o))+S (S (o+o+o)))+S (S (S (o+o+o))+ S (S (o+o+o))) + (S (S (S (o+o+o))+ S (S (o+o+o)))+S (S (S (o+o+o))+ S (S (o+o+o)))) + (S (S (S (o+o+o))+ S (S (o+o+o)))+S (S (S (o+o+o))+ S (S (o+o+o)))))))) prf | ThreeTwo | Even | Odd | ThreeTwo = apply108x99 prf
    unifi (S (S (S (k+k) + S (k+k) + S (k+k)))) prf | ThreeTwo | Odd with (parity k)
      unifi (S (S (S ((l+l)+(l+l)) + S ((l+l)+(l+l)) + S ((l+l)+(l+l))))) prf | ThreeTwo | Odd | Even with (mod3 l)
        unifi (S (S (S (((o+o+o)+(o+o+o))+((o+o+o)+(o+o+o))) + S (((o+o+o)+(o+o+o))+((o+o+o)+(o+o+o))) + S (((o+o+o)+(o+o+o))+((o+o+o)+(o+o+o)))))) prf | ThreeTwo | Odd | Even | ThreeZero = apply108x18 prf
        unifi (S (S (S ((S (o+o+o)+S (o+o+o))+(S (o+o+o)+S (o+o+o))) + S ((S (o+o+o)+S (o+o+o))+(S (o+o+o)+S (o+o+o))) + S ((S (o+o+o)+S (o+o+o))+(S (o+o+o)+S (o+o+o)))))) prf | ThreeTwo | Odd | Even | ThreeOne = apply108x54 prf
        unifi (S (S (S ((S (S (o+o+o))+S (S (o+o+o)))+(S (S (o+o+o))+S (S (o+o+o)))) + S ((S (S (o+o+o))+S (S (o+o+o)))+(S (S (o+o+o))+S (S (o+o+o)))) + S ((S (S (o+o+o))+S (S (o+o+o)))+(S (S (o+o+o))+S (S (o+o+o))))))) prf | ThreeTwo | Odd | Even | ThreeTwo = apply108x90 prf
      unifi (S (S (S (S (l+l)+ S (l+l)) + S (S (l+l)+S (l+l)) + S (S (l+l)+S (l+l))))) prf | ThreeTwo | Odd | Odd with (mod3 l)
        unifi (S (S (S (S ((o+o+o)+(o+o+o))+ S ((o+o+o)+(o+o+o))) + S (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o))) + S (S ((o+o+o)+(o+o+o))+S ((o+o+o)+(o+o+o)))))) prf | ThreeTwo | Odd | Odd | ThreeZero = apply108x36 prf
        unifi (S (S (S (S (S (o+o+o)+S (o+o+o))+ S (S (o+o+o)+S (o+o+o))) + S (S (S (o+o+o)+S (o+o+o))+S (S (o+o+o)+S (o+o+o))) + S (S (S (o+o+o)+S (o+o+o))+S (S (o+o+o)+S (o+o+o)))))) prf | ThreeTwo | Odd | Odd | ThreeOne = apply108x72 prf
        unifi (S (S (S (S (S (S (o+o+o))+S (S (o+o+o)))+ S (S (S (o+o+o))+S (S (o+o+o)))) + S (S (S (S (o+o+o))+S (S (o+o+o)))+S (S (S (o+o+o))+S (S (o+o+o)))) + S (S (S (S (o+o+o))+S (S (o+o+o)))+S (S (S (o+o+o))+S (S (o+o+o))))))) prf | ThreeTwo | Odd | Odd | ThreeTwo = apply108x108 prf

allDivSeqInfFalse' : All Limited (allDivSeq (n+n+n) 2)
allDivSeqInfFalse' = infiniteDescent unifi base0

-- レベルを下げる関数2
lvDown2 : (n, lv:Nat)
  -> All Limited (allDivSeq (n+n+n) lv)
    -> All Limited (allDivSeq (n+n+n) (pred lv))
lvDown2 n Z = id
lvDown2 n (S lv) = rewrite defini (n+n+n) lv in \y =>
  all2 (allDivSeq  (n+n+n) lv)
       (allDivSeqA (n+n+n) lv ++
        allDivSeqB (n+n+n) lv ++
        allDivSeqC (n+n+n) lv ++
        allDivSeqD (n+n+n) lv ++
        allDivSeqE (n+n+n) lv ++
        allDivSeqF (n+n+n) lv ++
        allDivSeqG (n+n+n) lv)
       y

-- 最終的な定理
allDivSeqInfFalse : (n:Nat)
  -> All Limited (allDivSeq (n+n+n) 0)
allDivSeqInfFalse n = lvDown2 n 1 $ lvDown2 n 2 allDivSeqInfFalse'