module LightClick.Types.Equality

import public Toolkit.Decidable.Equality.Indexed

import public Toolkit.Decidable.Informative

import Toolkit.Data.Rig

import Toolkit.Data.Vect.Extra

import LightClick.Types.Meta
import LightClick.Types.Direction
import LightClick.Types.Sensitivity
import LightClick.Types.WireType

import LightClick.Types

%default total

public export
Equals : {a,b : MTy}
      -> (x : Ty a)
      -> (y : Ty b)
      -> Type
Equals = Equals MTy Ty

-- [ No's for Logic vs X]
namespace Logic
  export
  logicNotStruct : (Equals TyLogic (TyStruct xs)) -> Void
  logicNotStruct (Same _ _) impossible

  export
  logicNotUnion : (Equals TyLogic (TyUnion xs)) -> Void
  logicNotUnion (Same _ _ ) impossible

  export
  logicNotArray : (Equals TyLogic (TyArray x k)) -> Void
  logicNotArray (Same _ _) impossible

-- [ No's for Array vs X]
namespace Array
  export
  arrayNotStruct : (Equals (TyArray x k) (TyStruct xs)) -> Void
  arrayNotStruct (Same _ _) impossible

  export
  arrayNotUnion  : (Equals (TyArray x k) (TyUnion xs)) -> Void
  arrayNotUnion (Same _ _) impossible

  export
  arrayDiffIndicies : {k,j : Nat}
                   -> (contra : (k = j) -> Void)
                   -> (Equals (TyArray x k) (TyArray y j))
                   -> Void
  arrayDiffIndicies contra (Same Refl Refl) {k = j} {j = j} = contra Refl

  export
  arrayDiffTypes : (contra : (x `Equals` y) -> Void)
                -> (Equals (TyArray x k) (TyArray y j))
                -> Void
  arrayDiffTypes contra (Same Refl Refl) = contra (Same Refl Refl)

-- [ No's for 'Bodies' vs X]
namespace Body

  namespace Length
    export
    structNotUnion : (TyStruct xs `Equals` TyUnion ys) -> Void
    structNotUnion (Same _ _) impossible

    export
    structDifferBody : {xs : Vect (S n) (Pair String (Ty DATA))}
                    -> {ys : Vect (S m) (Pair String (Ty DATA))}
                    -> (contra : (xs = ys) -> Void)
                    -> (TyStruct xs `Equals` TyStruct ys)
                    -> Void
    structDifferBody contra (Same Refl Refl) = contra Refl

    export
    unionDifferBody : {xs : Vect (S n) (Pair String (Ty DATA))}
                   -> {ys : Vect (S m) (Pair String (Ty DATA))}
                   -> (contra : (xs = ys) -> Void)
                   -> (TyUnion xs `Equals` TyUnion ys)
                   -> Void
    unionDifferBody contra (Same Refl Refl) = contra Refl

    export
    modDifferBody : {xs : DVect String (Ty . PORT) (S n) ns}
                 -> {ys : DVect String (Ty . PORT) (S m) ms}
                 -> (contra : (xs = ys) -> Void)
                 -> (TyModule xs `Equals` TyModule ys)
                 -> Void
    modDifferBody contra (Same Refl Refl) = contra Refl

-- [ No's for Ports]
namespace Ports
  export
  portDifferUsage : (contra : (ux = uy) -> Void)
                 -> (TyPort lx dy sy wx ty ux `Equals` TyPort lx dy sy wx ty uy)
                 -> Void
  portDifferUsage contra (Same Refl Refl) = contra Refl

  export
  portDifferType :  (contra : (tx `Equals` ty) -> Void)
                -> (TyPort lx dy sy wx tx ux `Equals` TyPort lx dy sy wy ty uy)
                -> Void
  portDifferType contra (Same Refl Refl) = contra (Same Refl Refl)

  export
  portDifferWire : (contra : (wx = wy) -> Void)
                -> (TyPort lx dy sy wx tx ux `Equals` TyPort lx dy sy wy ty uy)
                -> Void
  portDifferWire contra (Same Refl Refl) = contra Refl

  export
  portDifferSens : (contra : (sx = sy) -> Void)
                -> (TyPort lx dy sx wx tx ux `Equals` TyPort lx dy sy wy ty uy)
                -> Void
  portDifferSens contra (Same Refl Refl) = contra Refl

  export
  portsDifferDir : (contra : (dx = dy) -> Void)
                -> (TyPort a dx sx wx tx ux `Equals` TyPort a dy sy wy ty uy)
                -> Void
  portsDifferDir contra (Same Refl Refl) = contra Refl

  export
  portsDifferLabel : (contra : (lx = ly) -> Void)
                  -> (TyPort lx dx sx wx tx ux `Equals` TyPort ly dy sy wy ty uy)
                  -> Void
  portsDifferLabel contra (Same Refl Refl) = contra Refl

-- [ No's for Body ]
namespace Body
  namespace Length
    export
    dataBodyLengthsDiffer : {xs : Vect n (Pair String (Ty DATA))}
                         -> {ys : Vect m (Pair String (Ty DATA))}
                         -> (contra : (n = m) -> Void)
                         -> (xs = ys)
                         -> Void
    dataBodyLengthsDiffer contra Refl = contra Refl

    export
    dataBodyLengthsDiffer' : {xs : Vect (S n) (Pair String (Ty DATA))}
                          -> {ys : Vect (S m) (Pair String (Ty DATA))}
                          -> (contra : (xs = ys) -> Void)
                          -> (xs = ys)
                          -> Void
    dataBodyLengthsDiffer' contra Refl = contra Refl

  namespace Values

    namespace Names
      export
      modBodyDiffer : {n : Nat}
                   -> {names : Vect (S n) String}
                   -> {xs : DVect String (Ty . PORT) (S n) names}
                   -> {ys : DVect String (Ty . PORT) (S n) names}
                   -> (contra : (xs = ys) -> Void)
                   -> (TyModule xs `Equals` TyModule ys)
                   -> Void
      modBodyDiffer contra (Same Refl Refl) = contra Refl

    namespace Rest
      export
      restDataBodyDiffer : {xs : Vect n (Pair String (Ty DATA))}
                        -> {ys : Vect n (Pair String (Ty DATA))}
                        -> (contra : (xs = ys) -> Void)
                        -> (((ky, vy) :: xs) = ((ky, vy) :: ys))
                        -> Void
      restDataBodyDiffer contra Refl = contra Refl

      export
      dataBodyDiffer : {xs : Vect n (Pair String (Ty DATA))}
                    -> {ys : Vect n (Pair String (Ty DATA))}
                    -> (contra : (xs = ys) -> Void)
                    -> (xs = ys)
                    -> Void
      dataBodyDiffer contra Refl = contra Refl

      vRestDiffer : {xs : Vect n (Pair String (Ty DATA))}
                 -> {ys : Vect m (Pair String (Ty DATA))}
                 -> (contra : (xs = ys) -> Void)
                 -> (((ky, vy) :: xs) = ((ky, vy) :: ys))
                 -> Void
      vRestDiffer contra Refl = contra Refl

      export
      dVectElemDiffer : {n : Nat}
                     -> {ns : Vect n String}
                     -> {xrest : DVect String (Ty . PORT) n ns}
                     -> {yrest : DVect String (Ty . PORT) n ns}
                     -> {x : String}
                     -> {ex : Ty (PORT x)}
                     -> {ey : Ty (PORT x)}
                     -> (contra : (ex `Equals` ey) -> Void)
                     -> ((ex :: xrest) = (ey :: yrest))
                     -> Void
      dVectElemDiffer contra Refl = contra (Same Refl Refl)

      export
      dVectBodyDiffer : {xrest : DVect String (Ty . PORT) n ns}
                     -> {yrest : DVect String (Ty . PORT) n ns}
                     -> (contra : (xrest = yrest) -> Void)
                     -> ((ey :: xrest) = (ey :: yrest))
                     -> Void
      dVectBodyDiffer contra Refl = contra Refl

    namespace Head
      export
      elemDataBodyDiffer : {xs : Vect n (Pair String (Ty DATA))}
                        -> {ys : Vect n (Pair String (Ty DATA))}
                        -> {vx, vy : Ty DATA}
                        -> (contra : (vx `Equals` vy) -> Void)
                        -> (((ky, vx) :: xs) = ((ky, vy) :: ys))
                        -> Void
      elemDataBodyDiffer contra Refl = contra (Same Refl Refl)

      export
      elemDataKeyDiffer : {xs : Vect n (Pair String (Ty DATA))}
                       -> {ys : Vect n (Pair String (Ty DATA))}
                       -> {vx, vy : Ty DATA}
                       -> (contra : (kx = ky) -> Void)
                       -> (((kx, vx) :: xs) = ((ky, vy) :: ys))
                       -> Void
      elemDataKeyDiffer contra Refl = contra Refl

export
decEq : (x : Ty i)
     -> (y : Ty j)
     -> (prf : i = j)
     -> Dec (Equals MTy Ty x y)

namespace Fields

  differentLengthLeft : {y : String}
                     -> {z : Ty DATA}
                     -> (y, z) `Vect.(::)` (x `Vect.(::)` xs) = (y, z) `Vect.(::)` Nil -> Void
  differentLengthLeft _ impossible

  differentLengthRight : {y : String}
                      -> {z : Ty DATA}
                      -> (y, z) `Vect.(::)` Nil = (y, z) `Vect.(::)` (x `Vect.(::)` xs) -> Void
  differentLengthRight _ impossible

  headTypeDiff : {xs : Vect m (Pair String (Ty DATA))}
              -> {ys : Vect n (Pair String (Ty DATA))}
              -> {z,w : Ty DATA}
              -> (Equals MTy Ty z w -> Void)
              -> (y, z) `Vect.(::)` xs = (y, w) `Vect.(::)` ys
              -> Void
  headTypeDiff contra Refl = contra (Same Refl Refl)

  headLabelDiff : {xs : Vect m (Pair String (Ty DATA))}
               -> {ys : Vect n (Pair String (Ty DATA))}
               -> (x = y -> Void)
               -> {z,w : Ty DATA}
               -> (x, z) `Vect.(::)` xs = (y, w) `Vect.(::)` ys
               -> Void
  headLabelDiff contra Refl = contra Refl

  fieldsAreNotEqual : {xs : Vect m (Pair String (Ty DATA))}
                   -> {ys : Vect n (Pair String (Ty DATA))}
                   -> (x `Vect.(::)` xs = y' `Vect.(::)` ys -> Void)
                   -> (y, z) `Vect.(::)` (x `Vect.(::)` xs) = (y, z) `Vect.(::)` (y' `Vect.(::)` ys)
                   -> Void
  fieldsAreNotEqual contra Refl = contra Refl

  export
  decEq : (xs : Vect (S n) (Pair String (Ty DATA)))
       -> (ys : Vect (S m) (Pair String (Ty DATA)))
             -> Dec (xs = ys)
  decEq {n} xs {m} ys  with (shape xs ys)
    decEq {n = n} ((x, z) :: xs) {m = m} ((y, w) :: ys) | Both with (decEq x y)
      decEq {n = n} ((y, z) :: xs) {m = m} ((y, w) :: ys) | Both | (Yes Refl) with (Equality.decEq z w Refl)
        decEq {n = n} ((y, z) :: xs) {m = m} ((y, z) :: ys) | Both | (Yes Refl) | (Yes (Same Refl Refl)) with (shape xs ys)
          decEq {n = 0} ((y, z) :: []) {m = 0} ((y, z) :: []) | Both | (Yes Refl) | (Yes (Same Refl Refl)) | Empty = Yes Refl

          decEq {n = (S len)} ((y, z) :: (x :: xs)) {m = 0} ((y, z) :: []) | Both | (Yes Refl) | (Yes (Same Refl Refl)) | LH = No differentLengthLeft
          decEq {n = 0} ((y, z) :: []) {m = (S len)} ((y, z) :: (y' :: ys)) | Both | (Yes Refl) | (Yes (Same Refl Refl)) | RH = No differentLengthRight

          decEq {n = (S len)} ((y, z) :: (x :: xs)) {m = (S len)} ((y, z) :: (y' :: ys)) | Both | (Yes Refl) | (Yes (Same Refl Refl)) | Both with (Fields.decEq (x::xs) (y'::ys))
            decEq {n = (S len)} ((y, z) :: (x :: xs)) {m = (S len)} ((y, z) :: (x :: xs)) | Both | (Yes Refl) | (Yes (Same Refl Refl)) | Both | (Yes Refl) = Yes Refl
            decEq {n = (S len)} ((y, z) :: (x :: xs)) {m = (S len)} ((y, z) :: (y' :: ys)) | Both | (Yes Refl) | (Yes (Same Refl Refl)) | Both | (No contra) = No (fieldsAreNotEqual contra)

        decEq {n = n} ((y, z) :: xs) {m = m} ((y, w) :: ys) | Both | (Yes Refl) | (No contra) = No (headTypeDiff contra)
      decEq {n = n} ((x, z) :: xs) {m = m} ((y, w) :: ys) | Both | (No contra) = No (headLabelDiff contra)

namespace Port

  export
  decEq : (x : Ty (PORT a))
       -> (y : Ty (PORT b))
       -> Dec (Equals x y)
  decEq (TyPort a dx sx wx tx ux) (TyPort b dy sy wy ty uy) with (decEq a b)
    decEq (TyPort a dx sx wx tx ux) (TyPort a dy sy wy ty uy) | (Yes Refl) with (decEq dx dy)
      decEq (TyPort a dx sx wx tx ux) (TyPort a dx sy wy ty uy) | (Yes Refl) | (Yes Refl) with (decEq sx sy)
        decEq (TyPort a dx sx wx tx ux) (TyPort a dx sx wy ty uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) with (decEq wx wy)
          decEq (TyPort a dx sx wx tx ux) (TyPort a dx sx wx ty uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes Refl) with (decEq tx ty Refl)
            decEq (TyPort a dx sx wx tx ux) (TyPort a dx sx wx tx uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes (Same Refl Refl)) with (decEq ux uy)
              decEq (TyPort a dx sx wx tx uy) (TyPort a dx sx wx tx uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes (Same Refl Refl)) | (Yes Refl) = Yes (Same Refl Refl)
              decEq (TyPort a dx sx wx tx ux) (TyPort a dx sx wx tx uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes (Same Refl Refl)) | (No contra) = No (portDifferUsage contra)
            decEq (TyPort a dx sx wx tx ux) (TyPort a dx sx wx ty uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (No contra) = No (portDifferType contra)

          decEq (TyPort a dx sx wx tx ux) (TyPort a dx sx wy ty uy) | (Yes Refl) | (Yes Refl) | (Yes Refl) | (No contra) = No (portDifferWire contra)
        decEq (TyPort a dx sx wx tx ux) (TyPort a dx sy wy ty uy) | (Yes Refl) | (Yes Refl) | (No contra) = No (portDifferSens contra)
      decEq (TyPort a dx sx wx tx ux) (TyPort a dy sy wy ty uy) | (Yes Refl) | (No contra) = No (portsDifferDir contra)
    decEq (TyPort a dx sx wx tx ux) (TyPort b dy sy wy ty uy) | (No contra) = No (portsDifferLabel contra)

namespace Ports

  export
  decEq : {n :Nat}
       -> {ns : _}
       -> (xs : DVect String (Ty . PORT) n ns)
       -> (ys : DVect String (Ty . PORT) n ns)
             -> Dec (xs = ys)
  decEq [] [] = Yes Refl
  decEq (x :: xs) (y :: ys) with (Port.decEq x y)
    decEq (x :: xs) (x :: ys) | (Yes (Same Refl Refl)) with (Ports.decEq xs ys)
      decEq (x :: xs) (x :: xs) | (Yes (Same Refl Refl)) | (Yes Refl) = Yes Refl
      decEq (x :: xs) (y :: ys) | (Yes (Same Refl Refl)) | (No contra) = No (dVectBodyDiffer contra)
    decEq (x :: xs) (y :: ys) | (No contra) = No (dVectElemDiffer contra)

-- [ Body ]

-- [ Logic Types]
decEq TyLogic TyLogic Refl = Yes (Same Refl Refl)
decEq TyLogic (TyArray x k) Refl = No logicNotArray
decEq TyLogic (TyStruct xs) Refl = No logicNotStruct
decEq TyLogic (TyUnion xs) Refl = No logicNotUnion

-- [ Array Types ]
decEq (TyArray x k) TyLogic Refl = No (negEqSym logicNotArray)

decEq (TyArray x i) (TyArray y j) Refl with (decEq i j)
  decEq (TyArray x i) (TyArray y i) Refl | (Yes Refl) with (decEq x y Refl)
    decEq (TyArray x i) (TyArray x i) Refl | (Yes Refl) | (Yes (Same Refl Refl))
      = Yes (Same Refl Refl)
    decEq (TyArray x i) (TyArray y i) Refl | (Yes Refl) | (No contra)
      = No (arrayDiffTypes contra)
  decEq (TyArray x i) (TyArray y j) Refl | (No contra)
    = No (arrayDiffIndicies contra)

decEq (TyArray x k) (TyStruct xs) Refl = No arrayNotStruct
decEq (TyArray x k) (TyUnion xs) Refl = No arrayNotUnion

-- [ Structs ]
decEq (TyStruct xs) TyLogic Refl = No (negEqSym logicNotStruct)
decEq (TyStruct xs) (TyArray type length) Refl = No (negEqSym arrayNotStruct)

decEq (TyStruct xs) (TyStruct ys) Refl with (Fields.decEq xs ys)
  decEq (TyStruct xs) (TyStruct xs) Refl | (Yes Refl)  = Yes (Same Refl Refl)
  decEq (TyStruct xs) (TyStruct ys) Refl | (No contra) = No (structDifferBody contra)

decEq (TyStruct xs) (TyUnion kvs) Refl = No structNotUnion

-- [ Unions ]
decEq (TyUnion xs) TyLogic Refl = No (negEqSym logicNotUnion)
decEq (TyUnion xs) (TyArray type length) Refl = No (negEqSym arrayNotUnion)
decEq (TyUnion xs) (TyStruct kvs) Refl = No (negEqSym structNotUnion)

decEq (TyUnion xs) (TyUnion ys) Refl with (Fields.decEq xs ys)
  decEq (TyUnion xs) (TyUnion xs) Refl | (Yes Refl)   = Yes (Same Refl Refl)
  decEq (TyUnion xs) (TyUnion ys) Refl | (No  contra) = No (unionDifferBody contra)

-- [ Unit ]
decEq TyUnit TyUnit Refl = Yes (Same Refl Refl)

-- [ Gates ]
decEq TyGate TyGate Refl = Yes (Same Refl Refl)

-- [ Connections ]

decEq TyConn TyConn Refl = Yes (Same Refl Refl)

-- [ Ports ]
decEq (TyPort l dx sx wx tx ux) (TyPort l dy sy wy ty uy) Refl = Port.decEq (TyPort l dx sx wx tx ux) (TyPort l dy sy wy ty uy)

decEq (TyModule xs) (TyModule ys) Refl with (Ports.decEq xs ys)
  decEq (TyModule xs) (TyModule xs) Refl | (Yes Refl) = Yes (Same Refl Refl)
  decEq (TyModule xs) (TyModule ys) Refl | (No contra) = No (modBodyDiffer contra)

DecEqIdx MTy Ty where
  decEq x y prf = Equality.decEq x y prf

-- [ EOF ]


-- ----------------------------------------------------------------- [ Key.idr ]
-- Module      : Keys
-- Description : Types for Cryptographic Keys
-- Copyright   : (c) Jan de Muijnck-Hughes
-- License     : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
module Crypto.Std.Key

import Crypto.Common
import Data.Bits

||| Keys are vectors of bits.
|||
||| @ v The Visibility of the key with respect to the owner.
||| @ s The setting in which the key is to be used.
||| @ l The length of the key in bits.
data Key : (v : Visibility) -> (s : Setting) -> (l : Nat) -> Type where
  ||| PKE Encryption keys.
  MkEncKey : Bits n -> Key Public Asymm n

  ||| PKE Decryption keys
  MkDecKey : Bits n -> Key Private Asymm n

  ||| DS Signing keys.
  MkSignKey : Bits n -> Key Private Sign n

  ||| DS Verifying keys.
  MkVerifyKey : Bits n -> Key Public Sign n

  ||| Symmetric keys
  MkSymmKey : Bits n -> Key Private Symm n

||| Key pairs
|||
||| @ s The setting in which the key is to be used.
||| @ l The length of the key in bits.
data KeyPair : (s : Setting) -> (l : Nat) -> Type where
  ||| Key pair for PKE.
  |||
  ||| @ pub The public key.
  ||| @ priv The private key.
  MkAsymmKeyPair : (pub : Key Public Asymm n)
                 -> (priv : Key Private Asymm n)
                 -> KeyPair Asymm n

  ||| Key pair for DS.
  |||
  ||| @ sig The signing key.
  ||| @ ver The verifying key.
  MkSignKeyPair : (sig : Key Private Sign n)
                -> (ver : Key Public Sign n)
                -> KeyPair Sign n

data TDESKeyOption = KeyOption1 | KeyOption2 | KeyOption3

||| Representation of a Triple DES
|||
||| @ s The setting in ehich the key is to be used.
||| @ n The length of each key
||| @ option The Keying option used.
data TDESKey : (s : Setting) -> (n : Nat) -> (option : TDESKeyOption)-> Type where
  |||
  MkTDESKey : (key1 : Bits n)
             -> (key2 : Bits n)
             -> (key3 : Bits n)
             -> (opt : TDESKeyOption)
             -> TDESKey Symm n opt
-- --------------------------------------------------------------------- [ EOF ]


module Flexidisc.Function

import Flexidisc.TaggedValue

%default total
%access public export

infixr 8 |->
infix 7 ~~

||| A wrapper for functions to allow definition of typeclasses
record (|->) (a : Type) (b : Type) where
  constructor F
  unwrap : (a -> b)

Functor ((|->) a) where
  map g (F f) = F (g . f)

Applicative ((|->) a) where
  pure x = F (const x)
  (<*>) (F f) (F x) = F (\y => f y (x y))

(~~) : (l : k) -> (a -> b) -> TaggedValue l (a |-> b)
(~~) l f = l := F f


-- ------------------------------------------------------ [ Tree.idr<RedBlack> ]
-- Module    : Tree.idr
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
-- http://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs
module Data.RedBlack.Tree

import Debug.Error
%language ElabReflection

%default total
%access export

-- ------------------------------------------------------------- [ Definitions ]
public export
data Colour = R | B

||| The core tree key-value data structure used to represent an
||| Red-Black Tree.
|||
||| This structure doesn't encode the invariants of the tree and is
||| *simply* a container. This structure ideally shouldn't be exposed
||| to the user at all. This structure should be used to build other
||| data structures.  See the modules alongside this for appropriate
||| interfaces for using the tree.
|||
||| @keyTy The type associated with the key.
||| @valTy The type associated with the value.
public export
data Tree : (colour : Colour)
         -> (keyTy : Type)
         -> (valTy : Type)
         -> Type
  where
    ||| An empty Tree node.
    Empty : Tree B k v

    ||| A Key Value node in the Tree.
    |||
    ||| @key   The key.
    ||| @val   The value associated with the key.
    ||| @left  The left child of the Node
    ||| @right THe right child of the Node.
    Node : (c3 : Colour)
        -> (key   : k)
        -> (val   : v)
        -> (left  : Tree c1 k v)
        -> (right : Tree c2 k v)
        -> Tree c3 k v

%name Tree t, tree

public export
data RBInvariant : (blackHeight : Nat)
                -> (colour : Colour)
                -> (valid : Bool)
                -> (tree : Tree colour k v)
                -> Type
  where
    ||| A tree of height zero.
    RBEmpty : RBInvariant 0 B True Empty
    ||| A balanced black tree.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    BNode : (left  : RBInvariant n _ True l)
         -> (right : RBInvariant n _ True r)
         -> RBInvariant (S n) B True (Node B k v l r)
    ||| A balanced red tree.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    RNode : (left  : RBInvariant n B True l)
         -> (right : RBInvariant n B True r)
         -> RBInvariant n R True (Node R k v l r)

    ||| A red tree with a red left child.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    LBad : (left  : RBInvariant n R True l)
        -> (right : RBInvariant n B True r)
        -> RBInvariant n R False (Node R k v l r)

    ||| A red tree with a red right child.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    RBad : (left  : RBInvariant n B True l)
        -> (right : RBInvariant n R True r)
        -> RBInvariant n R False (Node R k v l r)

%name RBInvariant inv

||| An Red-Black Tree.
|||
||| Modelled using subset to separate the invariants from the tree
||| implementation itself.
|||
||| @blackHeight  The height of the Tree.
||| @keyTy        The type associated with the keys.
||| @valueTy      The type associated with the values.
public export
RBTree : (blackHeight  : Nat)
      -> (colour : Colour)
      -> (keyTy   : Type)
      -> (valueTy : Type)
      -> Type
RBTree n c k v = Subset (Tree c k v) (RBInvariant n c True)

private
InsTree : (blackHeight  : Nat)
       -> (colour : Colour)
       -> (keyTy   : Type)
       -> (valueTy : Type)
       -> (valid : Bool)
       -> Type
InsTree n c k v valid = Subset (Tree c k v) (RBInvariant n c valid)

-- --------------------------------------------------------------- [ Insertion ]

private
balance : k -> v -> RBTree n c1 k v -> RBTree n c2 k v -> (c3 ** RBTree (S n) c3 k v)
balance {n} y vy (Element (Node _ x vx a b) (RNode pf_l_l pf_l_r))
                 (Element (Node _ z vz c d) (RNode pf_r_l pf_r_r)) =
  let t = (Node R y vy (Node B x vx a b) (Node B z vz c d))
      pf = RNode (BNode pf_l_l pf_l_r) (BNode pf_r_l pf_r_r)
  in (R ** Element t pf)
balance {n} x vx (Element a pf_a) (Element b pf_b) =
  let t = (Node B x vx a b)
      pf = BNode pf_a pf_b
  in (B ** Element t pf)

private
recolorRight : (Ord k) => k -> v -> RBTree n c k v -> InsTree n R k v False -> (c' ** valid ** InsTree (S n) c' k v valid)

recolorRight g vg (Element (Node R u vu t5 t4) (RNode pf_5 pf_4))
                  (Element (Node R p vp t3 tn) (RBad pf_3 pf_n)) =
  (R ** True ** Element (Node R g vg (Node B u vu t5 t4) (Node B p vp t3 tn))
                        (RNode (BNode pf_5 pf_4) (BNode pf_3 pf_n)))

recolorRight g vg (Element (Node R u vu t5 t4) (RNode pf_5 pf_4))
                  (Element (Node R p vp tn t3) (LBad pf_n pf_3)) =
  (R ** True ** Element (Node R g vg (Node B u vu t4 t5) (Node B p vp tn t3))
                        (RNode (BNode pf_4 pf_5) (BNode pf_n pf_3)))

recolorRight g vg (Element (Node B u vu t5 t4) (BNode pf_5 pf_4))
                  (Element (Node R p vp t3 (Node R n vn t2 t1)) (RBad pf_3 (RNode pf_2 pf_1))) =
  (B ** True ** Element (Node B p vp (Node R g vg (Node B u vu t5 t4) t3)
                                     (Node R n vn t2 t1))
                        (BNode (RNode (BNode pf_5 pf_4) pf_3) (RNode pf_2 pf_1)))

recolorRight g vg (Element Empty RBEmpty)
                  (Element (Node R p vp t3 (Node R n vn t2 t1)) (RBad pf_3 (RNode pf_2 pf_1))) =
  (B ** True ** Element (Node B p vp (Node R g vg Empty t3)
                                     (Node R n vn t2 t1))
                        (BNode (RNode RBEmpty pf_3) (RNode pf_2 pf_1)))

recolorRight g vg (Element (Node B u vu t5 t4) (BNode pf_5 pf_4))
                  (Element (Node R p vp (Node R n vn t3 t2) t1) (LBad (RNode pf_3 pf_2) pf_1)) =
  (B ** True ** Element (Node B n vn (Node R g vg (Node B u vu t5 t4) t3)
                                     (Node R p vp t2 t1))
                        (BNode (RNode (BNode pf_5 pf_4) pf_3) (RNode pf_2 pf_1)))

recolorRight g vg (Element Empty RBEmpty)
                  (Element (Node R p vp (Node R n vn t3 t2) t1) (LBad (RNode pf_3 pf_2) pf_1)) =
  (B ** True ** Element (Node B n vn (Node R g vg Empty t3)
                                     (Node R p vp t2 t1))
                        (BNode (RNode RBEmpty pf_3) (RNode pf_2 pf_1)))

private
recolorLeft : (Ord k) => k -> v -> InsTree n R k v False -> RBTree n c k v -> (c' ** valid ** InsTree (S n) c' k v valid)

recolorLeft g vg (Element (Node R p vp tn t3) (LBad pf_n pf_3))
                 (Element (Node R u vu t4 t5) (RNode pf_4 pf_5)) =
  (R ** True ** Element (Node R g vg (Node B p vp tn t3)
                                     (Node B u vu t4 t5))
                        (RNode (BNode pf_n pf_3) (BNode pf_4 pf_5)))

recolorLeft g vg (Element (Node R p vp t1 tn) (RBad pf_1 pf_n))
                 (Element (Node R u vu t4 t5) (RNode pf_4 pf_5)) =
  (R ** True ** Element (Node R g vg (Node B p vp t1 tn)
                                     (Node B u vu t4 t5))
                        (RNode (BNode pf_1 pf_n) (BNode pf_4 pf_5)))

recolorLeft g vg (Element (Node R p vp (Node R n vn t1 t2) t3) (LBad (RNode pf_1 pf_2) pf_3))
                 (Element (Node B u vu t4 t5) (BNode pf_4 pf_5)) =
  (B ** True ** Element (Node B p vp (Node R n vn t1 t2)
                                     (Node R g vg t3 (Node B u vu t4 t5)))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 (BNode pf_4 pf_5))))

recolorLeft g vg (Element (Node R p vp (Node R n vn t1 t2) t3) (LBad (RNode pf_1 pf_2) pf_3))
                 (Element Empty RBEmpty) =
  (B ** True ** Element (Node B p vp (Node R n vn t1 t2)
                                     (Node R g vg t3 Empty))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 RBEmpty)))

recolorLeft g vg (Element (Node R p vp t1 (Node R n vn t2 t3)) (RBad pf_1 (RNode pf_2 pf_3)))
                 (Element (Node B u vu t4 t5) (BNode pf_4 pf_5)) =
  (B ** True ** Element (Node B n vn (Node R p vp t1 t2)
                                     (Node R g vg t3 (Node B u vu t4 t5)))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 (BNode pf_4 pf_5))))

recolorLeft g vg (Element (Node R p vp t1 (Node R n vn t2 t3)) (RBad pf_1 (RNode pf_2 pf_3)))
                 (Element Empty RBEmpty) =
  (B ** True ** Element (Node B n vn (Node R p vp t1 t2)
                                     (Node R g vg t3 Empty))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 RBEmpty)))

private
ins : Ord k => k -> v -> RBTree n c k v -> (c' ** valid ** InsTree n c' k v valid)
ins x vx (Element Empty RBEmpty) = (R ** True ** Element (Node R x vx Empty Empty) (RNode RBEmpty RBEmpty))
ins x vx t@(Element (Node _ y _ _ _) _) = insWith x vx t (compare x y)
  where
    addValid : (c ** InsTree n c k v True) -> (c ** valid ** InsTree n c k v valid)
    addValid (c ** t) = (c ** True ** t)

    insWith : Ord k => k -> v -> RBTree n c k v -> Ordering -> (c' ** valid ** InsTree n c' k v valid)

    insWith x vx (Element Empty RBEmpty) _ =  -- unreachable, but make totality checker happy
      (R ** True ** Element (Node R x vx Empty Empty) (RNode RBEmpty RBEmpty))

    insWith x vx (Element n@(Node B y vy a b) pf) EQ =
      (B ** True ** Element n pf)
    insWith x vx t@(Element (Node B y vy a b) (BNode pf_a pf_b)) LT =
      let t_a = assert_smaller t (Element a pf_a)
      in case ins x vx t_a of
        (_ ** True ** t_a') => addValid (balance y vy t_a' (Element b pf_b))
        (R ** False ** t_a') => recolorLeft y vy t_a' (Element b pf_b)
        (B ** False ** (Element _ _)) impossible
    insWith x vx t@(Element (Node B y vy a b) (BNode pf_a pf_b)) GT =
      let t_b = assert_smaller t (Element b pf_b)
      in case ins x vx t_b of
        (_ ** True ** t_b') => addValid (balance y vy (Element a pf_a) t_b')
        (R ** False ** t_b') => recolorRight y vy (Element a pf_a) t_b'
        (B ** False ** (Element _ _)) impossible

    insWith x vx (Element n@(Node R y vy a b) pf) EQ =
      (R ** True ** Element n pf)
    insWith x vx t@(Element (Node R y vy a b) (RNode pf_a pf_b)) LT =
      let t_a = assert_smaller t (Element a pf_a)
      in case ins x vx t_a of
        (B ** True ** Element a' pf_a') => (R ** True ** Element (Node R y vy a' b) (RNode pf_a' pf_b))
        (R ** True ** Element a' pf_a') => (R ** False ** Element (Node R y vy a' b) (LBad pf_a' pf_b))
        (R ** False ** t_a') => error "impossible"
        (B ** False ** Element _ _) impossible
    insWith x vx t@(Element (Node R y vy a b) (RNode pf_a pf_b)) GT =
      let t_b = assert_smaller t (Element b pf_b)
      in case ins x vx t_b of
        (B ** True ** Element b' pf_b') => (R ** True ** Element (Node R y vy a b') (RNode pf_a pf_b'))
        (R ** True ** Element b' pf_b') => (R ** False ** Element (Node R y vy a b') (RBad pf_a pf_b'))
        (R ** False ** t_b') => error "impossible"
        (B ** False ** Element _ _) impossible

-- --------------------------------------- [ Public API for working with Trees ]

||| An empty tree
empty : RBTree 0 B k v
empty = Element Empty RBEmpty

||| Insert a key value pair into the tree, returning a the new tree
||| and possibly its new height.
insert : Ord k => k -> v -> RBTree n B k v -> (n' : Nat ** RBTree n' B k v)
insert x vx s =
  case ins x vx s of
    (B ** True ** t) => (_ ** t)
    (R ** True ** Element (Node R k v l r) (RNode pf_l pf_r)) =>
      (_ ** Element (Node B k v l r) (BNode pf_l pf_r))
    (B ** False ** Element _ _) impossible
    (R ** False ** Element (Node R k v l r) (RBad pf_l pf_r)) =>
      (_ ** Element (Node B k v l r) (BNode pf_l pf_r))
    (R ** False ** Element (Node R k v l r) (LBad pf_l pf_r)) =>
      (_ ** Element (Node B k v l r) (BNode pf_l pf_r))

||| Find a value in the tree.
lookup : (Ord k) => k -> RBTree n B k v -> Maybe v
lookup key (Element t _) = lookup' key t
  where
    lookup' : (Ord k) => k -> Tree c k v -> Maybe v
    lookup' key Empty = Nothing
    lookup' key (Node _ key' value' l r) with (compare key key')
      lookup' key (Node _ key' value' l r) | LT = lookup' key l
      lookup' key (Node _ key' value' l r) | EQ = Just value'
      lookup' key (Node _ key' value' l r) | GT = lookup' key r

||| Perform a right fold over the tree.
foldr : (step : k -> v -> p -> p)
     -> (init : p)
     -> RBTree n B k v
     -> p
foldr step init (Element t _) = foldr' step init t
  where
    foldr' : (k -> v -> p -> p) -> p -> Tree c k v -> p
    foldr' step' init' Empty = init'
    foldr' step' init' (Node _ key val l r) = foldr' step' (step' key val (foldr' step' init' r)) l

||| Construct a AVL Tree from an association list.
fromList : (Ord k) => List (k, v) -> (n : Nat ** RBTree n B k v)
fromList xs = go xs empty
  where go : (Ord k) => List (k, v) -> RBTree n B k v -> (n' : Nat ** RBTree n' B k v)
        go [] t = (0 ** Element Empty RBEmpty)
        go ((k, v) :: xs) t = case insert k v t of
          (_ ** t') => go xs t'

||| Flatten the tree to an association list.
toList : RBTree n B k v -> List (k, v)
toList = foldr (\k,v,xs => (k, v) :: xs) []

||| Size of the tree.
size : RBTree n B k v -> Nat
size t = Tree.foldr (\_,_,res => S res) Z t

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


module Libraries.Data.DList

%default total

-- Do not re-export the type so that it does not get unfolded in goals
-- and error messages!
export
DList : Type -> Type
DList a = List a -> List a

export
Nil : DList a
Nil = id

export
(::) : a -> DList a -> DList a
(::) a as = (a ::) . as

export
snoc : DList a -> a -> DList a
snoc as a = as . (a ::)

export
appendR : DList a -> List a -> DList a
appendR as bs = as . (bs ++)

export
appendL : List a -> DList a -> DList a
appendL as bs = (as ++) . bs

export
(++) : DList a -> DList a -> DList a
(++) = (.)

export
reify : DList a -> List a
reify as = as []

-- NB: No Functor instance because it's too expensive to reify, map, put back
-- Consider using a different data structure if you need mapping (e.g. a rope)


module Solutions.DPair

import Control.Monad.State

import Data.DPair
import Data.Either
import Data.HList
import Data.List
import Data.List1
import Data.Singleton
import Data.String
import Data.Vect

import Text.CSV

import System.File

%default total

--------------------------------------------------------------------------------
--          Dependent Pairs
--------------------------------------------------------------------------------

-- 1

filterVect : (a -> Bool) -> Vect m a -> (n ** Vect n a)
filterVect f []        = (_ ** [])
filterVect f (x :: xs) = case f x of
  True  => let (_ ** ys) = filterVect f xs in (_ ** x :: ys)
  False => filterVect f xs

-- 2

mapMaybeVect : (a -> Maybe b) -> Vect m a -> (n ** Vect n b)
mapMaybeVect f []        = (_ ** [])
mapMaybeVect f (x :: xs) = case f x of
  Just v  => let (_ ** vs) = mapMaybeVect f xs in (_ ** v :: vs)
  Nothing => mapMaybeVect f xs

-- 3

dropWhileVect : (a -> Bool) -> Vect m a -> Exists (\n => Vect n a)
dropWhileVect f []        = Evidence _ []
dropWhileVect f (x :: xs) = case f x of
  True  => dropWhileVect f xs
  False => Evidence _ (x :: xs)

-- 4

vectLength : Vect n a -> Singleton n
vectLength []        = Val 0
vectLength (x :: xs) = let Val k = vectLength xs in Val (S k)

dropWhileVect' : (a -> Bool) -> Vect m a -> (n ** Vect n a)
dropWhileVect' f xs =
  let Evidence _ ys = dropWhileVect f xs
      Val n         = vectLength ys
   in (n ** ys)

--------------------------------------------------------------------------------
--          Use Case: Nucleic Acids
--------------------------------------------------------------------------------

-- 1

data BaseType = DNABase | RNABase

data Nucleobase' : BaseType -> Type where
  Adenine'  : Nucleobase' b
  Cytosine' : Nucleobase' b
  Guanine'  : Nucleobase' b
  Thymine'  : Nucleobase' DNABase
  Uracile'  : Nucleobase' RNABase

RNA' : Type
RNA' = List (Nucleobase' RNABase)

DNA' : Type
DNA' = List (Nucleobase' DNABase)

Acid1 : Type
Acid1 = (b ** List (Nucleobase' b))

record Acid2 where
  constructor MkAcid2
  baseType : BaseType
  sequence : List (Nucleobase' baseType)

data Acid3 : Type where
  SomeRNA : RNA' -> Acid3
  SomeDNA : DNA' -> Acid3

nb12 : Acid1 -> Acid2
nb12 (fst ** snd) = MkAcid2 fst snd

nb21 : Acid2 -> Acid1
nb21 (MkAcid2 bt seq) = (bt ** seq)

nb13 : Acid1 -> Acid3
nb13 (DNABase ** snd) = SomeDNA snd
nb13 (RNABase ** snd) = SomeRNA snd

nb31 : Acid3 -> Acid1
nb31 (SomeRNA xs) = (RNABase ** xs)
nb31 (SomeDNA xs) = (DNABase ** xs)

-- 2

data Dir = Sense | Antisense

data Nucleobase : BaseType -> Dir -> Type where
  Adenine  : Nucleobase b d
  Cytosine : Nucleobase b d
  Guanine  : Nucleobase b d
  Thymine  : Nucleobase DNABase d
  Uracile  : Nucleobase RNABase d

RNA : Dir -> Type
RNA d = List (Nucleobase RNABase d)

DNA : Dir -> Type
DNA d = List (Nucleobase DNABase d)

-- 3

inverse : Dir -> Dir
inverse Sense     = Antisense
inverse Antisense = Sense

complementBase :  (b : BaseType)
               -> Nucleobase b dir
               -> Nucleobase b (inverse dir)
complementBase DNABase Adenine  = Thymine
complementBase RNABase Adenine  = Uracile
complementBase _       Cytosine = Guanine
complementBase _       Guanine  = Cytosine
complementBase _       Thymine  = Adenine
complementBase _       Uracile  = Adenine

complement :  (b : BaseType)
           -> List (Nucleobase b dir)
           -> List (Nucleobase b $ inverse dir)
complement b = map (complementBase b)

transcribeBase : Nucleobase DNABase Antisense -> Nucleobase RNABase Sense
transcribeBase Adenine  = Uracile
transcribeBase Cytosine = Guanine
transcribeBase Guanine  = Cytosine
transcribeBase Thymine  = Adenine

transcribe : DNA Antisense -> RNA Sense
transcribe = map transcribeBase

transcribeAny : (dir : Dir) -> DNA dir -> RNA Sense
transcribeAny Antisense = transcribe
transcribeAny Sense     = transcribe . complement _

-- 4

record NucleicAcid where
  constructor MkNucleicAcid
  baseType : BaseType
  dir      : Dir
  sequence : List (Nucleobase baseType dir)

-- 5

readAnyBase : {0 dir : _} -> Char -> Maybe (Nucleobase b dir)
readAnyBase 'A' = Just Adenine
readAnyBase 'C' = Just Cytosine
readAnyBase 'G' = Just Guanine
readAnyBase _   = Nothing

readRNABase : {0 dir : _} -> Char -> Maybe (Nucleobase RNABase dir)
readRNABase 'U' = Just Uracile
readRNABase c   = readAnyBase c

readDNABase : {0 dir : _} -> Char -> Maybe (Nucleobase DNABase dir)
readDNABase 'T' = Just Thymine
readDNABase c   = readAnyBase c

readRNA : String -> Maybe (dir : Dir ** RNA dir)
readRNA str = case forget $ split ('-' ==) str of
  ["5´",s,"3´"] => MkDPair Sense     <$> traverse readRNABase (unpack s)
  ["3´",s,"5´"] => MkDPair Antisense <$> traverse readRNABase (unpack s)
  _             => Nothing

readDNA : String -> Maybe (dir : Dir ** DNA dir)
readDNA str = case forget $ split ('-' ==) str of
  ["5´",s,"3´"] => MkDPair Sense     <$> traverse readDNABase (unpack s)
  ["3´",s,"5´"] => MkDPair Antisense <$> traverse readDNABase (unpack s)
  _             => Nothing

-- 6

preSuf : Dir -> (String,String)
preSuf Sense     = ("5´-", "-3´")
preSuf Antisense = ("3´-", "-5´")

encodeBase : Nucleobase c d -> Char
encodeBase Adenine  = 'A'
encodeBase Cytosine = 'C'
encodeBase Guanine  = 'G'
encodeBase Thymine  = 'T'
encodeBase Uracile  = 'U'

encode : (dir : Dir) -> List (Nucleobase b dir) -> String
encode dir seq =
  let (pre,suf) = preSuf dir
   in pre ++ pack (map encodeBase seq) ++ suf

-- 7

public export
data InputError : Type where
  UnknownBaseType : String -> InputError
  InvalidSequence : String -> InputError

readAcid :  (b : BaseType)
         -> String
         -> Either InputError (d ** List $ Nucleobase b d)
readAcid b str =
  let err = InvalidSequence str
   in case b of
        DNABase => maybeToEither err $ readDNA str
        RNABase => maybeToEither err $ readRNA str

toAcid : (b : BaseType) -> (d ** List $ Nucleobase b d) -> NucleicAcid
toAcid b (d ** seq) = MkNucleicAcid b d seq

getNucleicAcid : IO (Either InputError NucleicAcid)
getNucleicAcid = do
  baseString <- getLine
  case baseString of
    "DNA" => map (toAcid _) . readAcid DNABase <$> getLine
    "RNA" => map (toAcid _) . readAcid RNABase <$> getLine
    _     => pure $ Left (UnknownBaseType baseString)

printRNA : RNA Sense -> IO ()
printRNA = putStrLn . encode _

transcribeProg : IO ()
transcribeProg = do
  Right (MkNucleicAcid b d seq) <- getNucleicAcid
    | Left (InvalidSequence str) => putStrLn $ "Invalid sequence: " ++ str
    | Left (UnknownBaseType str) => putStrLn $ "Unknown base type: " ++ str
  case b of
    DNABase => printRNA $ transcribeAny d seq
    RNABase => case d of
      Sense     => printRNA seq
      Antisense => printRNA $ complement _ seq

--------------------------------------------------------------------------------
--          Use Case: CSV Files with a Schema
--------------------------------------------------------------------------------

-- A lot of code was copy-pasted from the chapter's text and is, therefore
-- not very interesting. I tried to annotate the new parts with some hints
-- for better understanding. Also, instead of grouping code by exercise number,
-- I organized it thematically.

--   *** Types ***

-- I used an indexed type here to make sure, data
-- constructor `Optional` takes only non-nullary types
-- as arguments. As noted in exercise 3, having a nesting
-- of nullary types does not make sense without a way to
-- distinguish between a `Nothing` and a `Just Nothing`,
-- both of which would be encoded as the empty string.
-- For `Finite`, we have to add `n` as an argument to the
-- data constructor, so we can use it to decode values
-- of type `Fin n`.
data ColType0 : (nullary : Bool) -> Type where
  I64      : ColType0 b
  Str      : ColType0 b
  Boolean  : ColType0 b
  Float    : ColType0 b
  Natural  : ColType0 b
  BigInt   : ColType0 b
  Finite   : Nat -> ColType0 b
  Optional : ColType0 False -> ColType0 True

-- This is the type used in schemata, where nullary types
-- are explicitly allowed.
ColType : Type
ColType = ColType0 True

Schema : Type
Schema = List ColType

-- The only interesting new parts are the last two
-- lines. They should be pretty self-explanatory.
IdrisType : ColType0 b -> Type
IdrisType I64          = Int64
IdrisType Str          = String
IdrisType Boolean      = Bool
IdrisType Float        = Double
IdrisType Natural      = Nat
IdrisType BigInt       = Integer
IdrisType (Finite n)   = Fin n
IdrisType (Optional t) = Maybe $ IdrisType t

Row : Schema -> Type
Row = HList . map IdrisType

record Table where
  constructor MkTable
  schema : Schema
  size   : Nat
  rows   : Vect size (Row schema)

data Error : Type where
  ExpectedEOI    : (pos : Nat) -> String -> Error
  ExpectedLine   : Error
  InvalidCell    : (row, col : Nat) -> ColType0 b -> String -> Error
  NoNat          : String -> Error
  OutOfBounds    : (size : Nat) -> (index : Nat) -> Error
  ReadError      : (path : String) -> FileError -> Error
  UnexpectedEOI  : (pos : Nat) -> String -> Error
  UnknownCommand : String -> Error
  UnknownType    : (pos : Nat) -> String -> Error
  WriteError     : (path : String) -> FileError -> Error

-- Oh, the type of `Query` is a nice one. :-)
-- `PrintTable`, on the other hand, is trivial.
-- The save and load commands are special: They will
-- already have carried out their tasks after parsing.
-- This allow us to keep `applyCommand` pure.
data Command : (t : Table) -> Type where
  PrintSchema : Command t
  PrintSize   : Command t
  PrintTable  : Command t
  Load        : Table -> Command t
  Save        : Command t
  New         : (newSchema : Schema) -> Command t
  Prepend     : Row (schema t) -> Command t
  Get         : Fin (size t) -> Command t
  Delete      : Fin (size t) -> Command t
  Quit        : Command t
  Query       :  (ix  : Fin (length $ schema t))
              -> (val : IdrisType $ indexList (schema t) ix)
              -> Command t

--   *** Core Functionality ***

-- Compares two values for equality.
eq : (c : ColType0 b) -> IdrisType c -> IdrisType c -> Bool
eq I64          x        y        = x == y
eq Str          x        y        = x == y
eq Boolean      x        y        = x == y
eq Float        x        y        = x == y
eq Natural      x        y        = x == y
eq BigInt       x        y        = x == y
eq (Finite k)   x        y        = x == y
eq (Optional z) (Just x) (Just y) = eq z x y
eq (Optional z) Nothing  Nothing  = True
eq (Optional z) _        _        = False

-- Note: It would have been quite a bit easier to type and
-- implement this, had we used a heterogeneous vector instead
-- of a heterogeneous list for encoding table rows. However,
-- I still think it's pretty cool that this type checks!
eqAt :  (ts  : Schema)
     -> (ix  : Fin $ length ts)
     -> (val : IdrisType $ indexList ts ix)
     -> (row : Row ts)
     -> Bool
eqAt (x :: _)  FZ     val (v :: _)  = eq x val v
eqAt (_ :: xs) (FS y) val (_ :: vs) = eqAt xs y val vs
eqAt []        _      _   _ impossible

-- Most new commands don't change the table,
-- so their cases are trivial. The exception is
-- `Load`, which replaces the table completely.
applyCommand : (t : Table) -> Command t -> Table
applyCommand t                 PrintSchema    = t
applyCommand t                 PrintSize      = t
applyCommand t                 PrintTable     = t
applyCommand t                 Save           = t
applyCommand _                 (Load t')      = t'
applyCommand _                 (New ts)       = MkTable ts _ []
applyCommand (MkTable ts n rs) (Prepend r)    = MkTable ts _ $ r :: rs
applyCommand t                 (Get x)        = t
applyCommand t                 Quit           = t
applyCommand t                 (Query ix val) = t
applyCommand (MkTable ts n rs) (Delete x)  = case n of
  S k => MkTable ts k (deleteAt x rs)
  Z   => absurd x

--   *** Parsers ***

zipWithIndex : Traversable t => t a -> t (Nat, a)
zipWithIndex = evalState 1 . traverse pairWithIndex
  where pairWithIndex : a -> State Nat (Nat,a)
        pairWithIndex v = (,v) <$> get <* modify S

fromCSV : String -> List String
fromCSV = forget . split (',' ==)

-- Reads a primitive (non-nullary) type. This is therefore
-- universally quantified over parameter `b`.
-- The only interesting part is the parsing of `finXYZ`,
-- where we `break` the string at the occurrence of
-- the first digit.
readPrim : Nat -> String -> Either Error (ColType0 b)
readPrim _ "i64"      = Right I64
readPrim _ "str"      = Right Str
readPrim _ "boolean"  = Right Boolean
readPrim _ "float"    = Right Float
readPrim _ "natural"  = Right Natural
readPrim _ "bigint"   = Right BigInt
readPrim n s          =
  let err = Left $ UnknownType n s
   in case break isDigit s of
        ("fin",r) => maybe err (Right . Finite) $ parsePositive r
        _         => err

-- This is the parser for (possibly nullary) column types.
-- A nullary type is encoded as the corresponding non-nullary
-- type with a question mark appended. We therefore first check
-- for the presence of said question mark at the end of the string.
readColType : Nat -> String -> Either Error ColType
readColType n s = case reverse (unpack s) of
  '?' :: t => Optional <$> readPrim n (pack $ reverse t)
  _        => readPrim n s

readSchema : String -> Either Error Schema
readSchema = traverse (uncurry readColType) . zipWithIndex . fromCSV

readSchemaList : List String -> Either Error Schema
readSchemaList [s] = readSchema s
readSchemaList _   = Left ExpectedLine

-- For all except nullary types we can just use the `CSVField`
-- implementation for reading values.
-- For values of nullary types, we treat the empty string specially.
decodeF : (c : ColType0 b) -> String -> Maybe (IdrisType c)
decodeF I64          s  = read s
decodeF Str          s  = read s
decodeF Boolean      s  = read s
decodeF Float        s  = read s
decodeF Natural      s  = read s
decodeF BigInt       s  = read s
decodeF (Finite k)   s  = read s
decodeF (Optional y) "" = Just Nothing
decodeF (Optional y) s  = Just <$> decodeF y s

decodeField : (row,col : Nat) -> (c : ColType0 b) -> String -> Either Error (IdrisType c)
decodeField row k c s = maybeToEither (InvalidCell row k c s) $ decodeF c s

decodeRow : {ts : _} -> (row : Nat) -> String -> Either Error (Row ts)
decodeRow row s = go 1 ts $ fromCSV s
  where go : Nat -> (cs : Schema) -> List String -> Either Error (Row cs)
        go k []       []         = Right []
        go k []       (_ :: _)   = Left $ ExpectedEOI k s
        go k (_ :: _) []         = Left $ UnexpectedEOI k s
        go k (c :: cs) (s :: ss) = [| decodeField row k c s :: go (S k) cs ss |]

decodeRows : {ts : _} -> List String -> Either Error (List $ Row ts)
decodeRows = traverse (uncurry decodeRow) . zipWithIndex

readFin : {n : _} -> String -> Either Error (Fin n)
readFin s = do
  S k <- maybeToEither (NoNat s) $ parsePositive {a = Nat} s
    | Z => Left $ OutOfBounds n Z
  maybeToEither (OutOfBounds n $ S k) $ natToFin k n

readCommand :  (t : Table) -> String -> Either Error (Command t)
readCommand _                "schema"  = Right PrintSchema
readCommand _                "size"    = Right PrintSize
readCommand _                "table"   = Right PrintTable
readCommand _                "quit"    = Right Quit
readCommand (MkTable ts n _) s         = case words s of
  ["new",    str]    => New     <$> readSchema str
  "add" ::   ss      => Prepend <$> decodeRow 1 (unwords ss)
  ["get",    str]    => Get     <$> readFin str
  ["delete", str]    => Delete  <$> readFin str
  "query" :: n :: ss => do
    ix  <- readFin n
    val <- decodeField 1 1 (indexList ts ix) (unwords ss)
    pure $ Query ix val
  _                  => Left $ UnknownCommand s

--   *** Printers ***

toCSV : List String -> String
toCSV = concat . intersperse ","

-- We mark optional type by appending a question
-- mark after the corresponding non-nullary type.
showColType : ColType0 b -> String
showColType I64          = "i64"
showColType Str          = "str"
showColType Boolean      = "boolean"
showColType Float        = "float"
showColType Natural      = "natural"
showColType BigInt       = "bigint"
showColType (Finite n)   = "fin\{show n}"
showColType (Optional t) = showColType t ++ "?"

-- Again, only nullary values are treated specially. This
-- is another case of a dependent pattern match: We use
-- explicit pattern matches on the value to encode based
-- on the type calculated from the `ColType0 b` parameter.
-- There are few languages capable of expressing this as
-- cleanly as Idris does.
encodeField : (t : ColType0 b) -> IdrisType t -> String
encodeField I64          x        = show x
encodeField Str          x        = x
encodeField Boolean      True     = "t"
encodeField Boolean      False    = "f"
encodeField Float        x        = show x
encodeField Natural      x        = show x
encodeField BigInt       x        = show x
encodeField (Finite k)   x        = show x
encodeField (Optional y) (Just v) = encodeField y v
encodeField (Optional y) Nothing  = ""

encodeFields : (ts : Schema) -> Row ts -> Vect (length ts) String
encodeFields []        []        = []
encodeFields (c :: cs) (v :: vs) = encodeField c v :: encodeFields cs vs

encodeTable : Table -> String
encodeTable (MkTable ts _ rows) =
  unlines . toList $ map (toCSV . toList . encodeFields ts) rows

encodeSchema : Schema -> String
encodeSchema = toCSV . map showColType

-- Pretty printing a table plus header. All cells are right-padded
-- with spaces to adjust their size to the cell with the longest
-- entry for each colum.
-- Value `ls` is a `Vect n Nat` holding these lengths.
-- Here is an example of how the output looks like:
--
-- fin100 | boolean | natural | str         | bigint?
-- --------------------------------------------------
-- 88     | f       | 10      | stefan      |
-- 13     | f       | 10      | hock        | -100
-- 58     | t       | 1000    | hello world | -1234
--
-- Ideally, numeric values would be right-aligned, but since this
-- whole exercise is already quite long and complex, I refrained
-- from adding this luxury.
prettyTable :  {n : _}
            -> (header : Vect n String)
            -> (table  : Vect m (Vect n String))
            -> String
prettyTable h t =
  let -- vector holding the maximal length of each column
      ls  = foldl (zipWith $ \k => max k . length) (replicate n Z) (h::t)

      -- horizontal bar used to separate the header from the rows
      bar = concat . intersperse "---" $ map (`replicate` '-') ls
   in unlines . toList $ line ls h :: bar :: map (line ls) t

  where pad : Nat -> String -> String
        pad v = padRight v ' '

        -- given a vector of lengths, pads each string to the
        -- desired length, separating cells with a vertical bar.
        line : Vect n Nat -> Vect n String -> String
        line lengths = concat . intersperse " | " . zipWith pad lengths

printTable :  (cs   : List ColType)
           -> (rows : Vect n (Row cs))
           -> String
printTable cs rows =
  let header  = map showColType $ fromList cs
      table   = map (encodeFields cs) rows
   in prettyTable header table

allTypes : String
allTypes = concat
         . List.intersperse ", "
         . map (showColType {b = True})
         $ [I64,Str,Boolean,Float]

showError : Error -> String
showError ExpectedLine = """
  Error when reading schema.
  Expected a single line of content.
  """

showError (UnknownCommand x) = """
  Unknown command: \{x}.
  Known commands are: clear, schema, size, table, new, add, get, delete, quit.
  """

showError (UnknownType pos x) = """
  Unknown type at position \{show pos}: \{x}.
  Known types are: \{allTypes}.
  """

showError (InvalidCell row col tpe x) = """
  Invalid value at row \{show row}, column \{show col}.
  Expected type: \{showColType tpe}.
  Value found: \{x}.
  """

showError (ExpectedEOI k x) = """
  Expected end of input.
  Position: \{show k}
  Input: \{x}
  """

showError (UnexpectedEOI k x) = """
  Unxpected end of input.
  Position: \{show k}
  Input: \{x}
  """

showError (OutOfBounds size index) = """
  Index out of bounds.
  Size of table: \{show size}
  Index: \{show index}
  Note: Indices start at zero.
  """

showError (WriteError path err) = """
  Error when writing file \{path}.
  Message: \{show err}
  """

showError (ReadError path err) = """
  Error when reading file \{path}.
  Message: \{show err}
  """

showError (NoNat x) = "Not a natural number: \{x}"

result :  (t : Table) -> Command t -> String
result t PrintSchema    = "Current schema: \{encodeSchema t.schema}"
result t PrintSize      = "Current size: \{show t.size}"
result t PrintTable     = "Table:\n\n\{printTable t.schema t.rows}"
result _ Save           = "Table written to disk."
result _ (Load t)       = "Table loaded. Schema: \{encodeSchema t.schema}"
result _ (New ts)       = "Created table. Schema: \{encodeSchema ts}"
result t (Prepend r)    = "Row prepended:\n\n\{printTable t.schema [r]}"
result _ (Delete x)     = "Deleted row: \{show $ FS x}."
result _ Quit           = "Goodbye."
result t (Query ix val) =
  let (_ ** rs) = filter (eqAt t.schema ix val) t.rows
   in "Result:\n\n\{printTable t.schema rs}"
result t (Get x)        =
  "Row \{show $ FS x}:\n\n\{printTable t.schema [index x t.rows]}"

--   *** File IO ***

-- We use partial function `readFile` for simplicity here.
partial
load :  (path   : String)
     -> (decode : List String -> Either Error a)
     -> IO (Either Error a)
load path decode = do
  Right ls <- readFile path
    | Left err        => pure $ Left (ReadError path err)
  pure $ decode (filter (not . null) $ lines ls)

write : (path : String) -> (content : String) -> IO (Either Error ())
write path content = mapFst (WriteError path) <$> writeFile path content

namespace IOEither
  export
  (>>=) : IO (Either err a) -> (a -> IO (Either err b)) -> IO (Either err b)
  ioa >>= f = Prelude.(>>=) ioa (either (pure . Left) f)

  export
  (>>) : IO (Either err ()) -> IO (Either err a) -> IO (Either err a)
  (>>) x y = x >>= const y

  export
  pure : a -> IO (Either err a)
  pure = Prelude.pure . Right

partial
readCommandIO : (t : Table) -> String -> IO (Either Error (Command t))
readCommandIO t s = case words s of
  ["save", pth] => IOEither.do
    write (pth ++ ".schema") (encodeSchema t.schema)
    write (pth ++ ".csv") (encodeTable t)
    pure Save

  ["load", pth] => IOEither.do
    schema <- load (pth ++ ".schema") readSchemaList
    rows   <- load (pth ++ ".csv") (decodeRows {ts = schema})
    pure . Load $ MkTable schema (length rows) (fromList rows)

  _ => Prelude.pure $ readCommand t s

--   *** Main Loop ***

partial
runProg : Table -> IO ()
runProg t = do
  putStr "Enter a command: "
  str <- getLine
  cmd <- readCommandIO t str
  case cmd of
    Left err   => putStrLn (showError err) >> runProg t
    Right Quit => putStrLn (result t Quit)
    Right cmd  => putStrLn (result t cmd) >>
                  runProg (applyCommand t cmd)

partial
main : IO ()
main = runProg $ MkTable [] _ []


module Lens.Util

import Data.List
import Data.Maybe
import Lens
import Lens.Uninhabited
import Map

%default total

public export
beq_prim : (v : PrimitiveValue) ->  v == v = True
beq_prim (Boolean b) = beq_bool b
beq_prim (Number n) = beq_nat n
beq_prim (Text t) = beq_str t

public export
beq_prim2 : (v1, v2 : PrimitiveValue) -> (v1 == v2 = True) -> v1 = v2
beq_prim2 (Boolean x) (Boolean y) prf = rewrite eq_bool x y prf in Refl
beq_prim2 (Boolean _) (Number _) Refl impossible
beq_prim2 (Boolean _) (Text _) Refl impossible
beq_prim2 (Number _) (Boolean _) Refl impossible
beq_prim2 (Number k) (Number j) prf = rewrite eq_nat k j prf in Refl
beq_prim2 (Number _) (Text _) Refl impossible
beq_prim2 (Text _) (Boolean _) Refl impossible
beq_prim2 (Text _) (Number _) Refl impossible
beq_prim2 (Text xs) (Text ys) prf = rewrite eq_str xs ys prf in Refl

public export
neq_prim : (v1, v2 : PrimitiveValue) -> (v1 == v2 = False) -> Not (v1 = v2)
neq_prim (Boolean x) (Boolean y) prf =
    neq_bool x y prf . justInjective . cong boolean
neq_prim (Boolean x) (Number k) prf = uninhabited
neq_prim (Boolean x) (Text xs) prf = uninhabited
neq_prim (Number k) (Boolean x) prf = uninhabited
neq_prim (Number k) (Number j) prf =
    neq_nat k j prf . justInjective . cong number
neq_prim (Number k) (Text xs) prf = uninhabited
neq_prim (Text xs) (Boolean x) prf = uninhabited
neq_prim (Text xs) (Number k) prf = uninhabited
neq_prim (Text xs) (Text ys) prf =
    neq_str xs ys prf . justInjective . cong text

beq_prim_kind : (k1, k2 : PrimitiveKind) -> (k1 == k2 = True) ->  k1 = k2
beq_prim_kind KBoolean KBoolean prf = Refl
beq_prim_kind KBoolean KNumber Refl impossible
beq_prim_kind KBoolean KText Refl impossible
beq_prim_kind KNumber KBoolean Refl impossible
beq_prim_kind KNumber KNumber prf = Refl
beq_prim_kind KNumber KText Refl impossible
beq_prim_kind KText KBoolean Refl impossible
beq_prim_kind KText KNumber Refl impossible
beq_prim_kind KText KText prf = Refl

public export
validate_properties_after_insert : (vm : Map Value) -> (sm : Map Schema) ->
    (k : Key) -> (v : Value) -> (s : Schema) -> validate s v = True ->
    validate_properties vm sm = True -> validate_properties (insert k v vm) (insert k s sm) = True

public export
validate_properties_after_remove : (vm : Map Value) -> (sm : Map Schema) -> (k : Key) ->
    validate_properties vm sm = True -> validate_properties (remove k vm) (remove k sm) = True

public export
invalid_property : (vm : Map Value) -> (sm : Map Schema) -> (k : Key) ->
    (v : Value) -> (s : Schema) -> get k vm = Just v -> get k sm = Just s -> validate s v = False ->
    validate_properties vm sm = False

public export
still_valid : (vm : Map Value) -> (sm : Map Schema) ->
    (k : Key) -> (kvm : Value) -> (ksm : Schema) ->
    get k vm = Just kvm -> get k sm = Just ksm ->
    validate_properties vm sm = True -> validate ksm kvm = True

public export
still_invalid : (vm : Map Value) -> (sm : Map Schema) ->
    (k : Key) ->  get k vm = Just kvm -> get k sm = Just ksm ->
    validate ksm kvm = False -> validate_properties vm sm = False

public export
flip_map_twice : (m : List (PrimitiveValue, PrimitiveValue)) -> flip_map (flip_map m) = m
flip_map_twice [] = Refl
flip_map_twice ((x, y) :: xs) = rewrite flip_map_twice xs in Refl

public export
flip_map_preserves_validity : (a, b : PrimitiveKind) -> (m : List (PrimitiveValue, PrimitiveValue)) ->
    validate_map a b m = True -> validate_map b a (flip_map m) = True
flip_map_preserves_validity a b [] prf = Refl
flip_map_preserves_validity a b ((x, y) :: xs) prf =
    let sprf = and_split (prim_kind_of x == a) (prim_kind_of y == b && Delay (validate_map a b xs)) prf
        sprf2 = and_split (prim_kind_of y == b) (validate_map a b xs) (snd sprf)
        ind = flip_map_preserves_validity a b xs (snd sprf2)
    in rewrite fst sprf2 in rewrite fst sprf in ind

validate_map_kind_a : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) -> (va : PrimitiveValue) ->
    (va, vb) :: _ = m -> validate_map a b m = True -> prim_kind_of va = a
validate_map_kind_a [] _ _ _ Refl _ impossible
validate_map_kind_a ((va, vb) :: m) KBoolean b (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == KBoolean) (prim_kind_of vb == b && validate_map KBoolean b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KBoolean (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KBoolean b (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == KBoolean) (prim_kind_of vb == b && validate_map KBoolean b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KBoolean (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KNumber b (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == KNumber) (prim_kind_of vb == b && validate_map KNumber b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KNumber (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KNumber b (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == KNumber) (prim_kind_of vb == b && validate_map KNumber b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KNumber (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KText b (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == KText) (prim_kind_of vb == b && validate_map KText b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KText (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KText b (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == KText) (prim_kind_of vb == b && validate_map KText b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KText (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((_, _) :: _) KBoolean _ (Boolean _) prf prf1 = Refl
validate_map_kind_a ((_, _) :: _) KNumber _ (Number _) prf prf1 = Refl
validate_map_kind_a ((_, _) :: _) KText _ (Text _) prf prf1 = Refl

validate_map_kind_b : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) -> (vb : PrimitiveValue) ->
    (va, vb) :: _ = m -> validate_map a b m = True -> prim_kind_of vb = b
validate_map_kind_b [] _ _ _ Refl _ impossible
validate_map_kind_b ((va, vb) :: m) a KBoolean (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KBoolean && validate_map a KBoolean m) prf1
        split2 = and_split (prim_kind_of vb == KBoolean) (validate_map a KBoolean m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KBoolean (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KBoolean (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KBoolean && validate_map a KBoolean m) prf1
        split2 = and_split (prim_kind_of vb == KBoolean) (validate_map a KBoolean m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KBoolean (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KNumber (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KNumber && validate_map a KNumber m) prf1
        split2 = and_split (prim_kind_of vb == KNumber) (validate_map a KNumber m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KNumber (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KNumber (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KNumber && validate_map a KNumber m) prf1
        split2 = and_split (prim_kind_of vb == KNumber) (validate_map a KNumber m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KNumber (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KText (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KText && validate_map a KText m) prf1
        split2 = and_split (prim_kind_of vb == KText) (validate_map a KText m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KText (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KText (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KText && validate_map a KText m) prf1
        split2 = and_split (prim_kind_of vb == KText) (validate_map a KText m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KText (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) _ KBoolean (Boolean _) prf prf1 = Refl
validate_map_kind_b ((va, vb) :: m) _ KNumber (Number _) prf prf1 = Refl
validate_map_kind_b ((va, vb) :: m) _ KText (Text _) prf prf1 = Refl

validate_map_kind : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) ->
    (va, vb : PrimitiveValue) -> (va, vb) :: _ = m -> validate_map a b m = True ->
    (prim_kind_of va = a, prim_kind_of vb = b)
validate_map_kind m a b va vb prf prf1 =
    let pa = validate_map_kind_a m a b va prf prf1
        pb = validate_map_kind_b m a b vb prf prf1
    in (pa, pb)

map_still_valid : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) ->
    (x :: xs) = m -> validate_map a b m = True -> validate_map a b xs = True
map_still_valid [] _ _ Refl _ impossible
map_still_valid ((va, vb) :: m) a b prf prf1 with (prim_kind_of va == a, prim_kind_of vb == b) proof prf2
    map_still_valid ((va, vb) :: m) a b prf prf1 | (False, _) =
        let split = and_split (prim_kind_of va == a) (prim_kind_of vb == b && validate_map a b m) prf1
        in absurd $ trans (sym $ cong fst prf2) (fst split)
    map_still_valid ((va, vb) :: m) a b prf prf1 | (True, False) =
        let split = and_split (prim_kind_of va == a) (prim_kind_of vb == b && validate_map a b m) prf1
            split2 = and_split (prim_kind_of vb == b) (validate_map a b m) (snd split)
        in absurd $ trans (sym $ cong snd prf2) (fst split2)
    map_still_valid ((va, vb) :: m) a b prf prf1 | (True, True) =
        let split = and_split (prim_kind_of va == a) (prim_kind_of vb == b && validate_map a b m) prf1
            split2 = and_split (prim_kind_of vb == b) (validate_map a b m) (snd split)
        in rewrite snd $ consInjective prf in snd split2

public export
convert_prim_kind : (m : List (PrimitiveValue, PrimitiveValue)) ->
    (a, b : PrimitiveKind) -> (va, vb : PrimitiveValue) ->
    validate_map a b m = True -> prim_kind_of va = a ->
    convert_prim va m = Just vb -> prim_kind_of vb = b
convert_prim_kind [] _ _ _ _ _ _ Refl impossible
convert_prim_kind ((va', vb') :: m) a b va vb prf prf1 prf2 with (va == va') proof prf3
    convert_prim_kind ((va', vb') :: m) a b va vb prf prf1 prf2 | True =
        rewrite sym $ justInjective prf2 in
            snd $ validate_map_kind ((va', vb') :: m) a b va' vb' Refl prf
    convert_prim_kind ((va', vb') :: m) a b va vb prf prf1 prf2 | False =
        let sv = map_still_valid ((va', vb') :: m) a b Refl prf
            ind = convert_prim_kind m a b va vb sv prf1 prf2
        in ind


-- exercises in "Type-Driven Development with Idris"
-- chapter 14, section 3, Hangman part

import Data.Vect

-- check that all functions are total
%default total

||| Remove an element in a vector
removeElem : (value : a) -> (xs : Vect (S n) a) ->
              {auto prf : Elem value xs} ->
              Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later}
  = y :: removeElem value ys

||| (Abstract) State of the game
data GameState : Type where
  NotRunning : GameState
  Running : (guesses : Nat) -> (letters : Nat) -> GameState

||| Result of a guess
data GuessResult = Correct | Incorrect

||| Letters in a word
letters : String -> List Char
letters str = nub $ map toUpper $ unpack str

||| Game commands
data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
  ||| new game
  NewGame : (word : String) ->
            GameCmd () NotRunning $
                       const (Running 6 (length (letters word)))
  ||| won game
  Won : GameCmd () (Running (S guesses) 0) $
                   const NotRunning
  ||| lost game
  Lost : GameCmd () (Running 0 (S guesses)) $
                    const NotRunning
  ||| guess a letter
  Guess : (c : Char) ->
          GameCmd  GuessResult
                   (Running (S guesses) (S letters))
                   (\res => case res of
                              Correct => Running (S guesses) letters
                              Incorrect => Running guesses (S letters))
  ||| display the game state
  ShowState : GameCmd () state $ const state
  ||| display a message
  Message : String -> GameCmd () state $ const state
  ||| read a guess
  ReadGuess : GameCmd Char state $ const state
  ||| pure
  Pure : (res : ty) -> GameCmd ty (state res) state
  ||| sequence
  (>>=) : GameCmd a state1 state2 ->
          ((res : a) -> GameCmd b (state2 res) state3) ->
          GameCmd b state1 state3

namespace Loop
  ||| Game loop (type)
  data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
    ||| sequence
    (>>=) : GameCmd a state1 state2 ->
            ((res : a) -> Inf (GameLoop b (state2 res) state3)) ->
            GameLoop b state1 state3
    ||| exit game
    Exit : GameLoop () NotRunning $ const NotRunning

||| Game loop (implementation)
gameLoop : GameLoop () (Running (S guesses) (S letters)) $ const NotRunning
gameLoop {guesses} {letters}
  = do ShowState
       g <- ReadGuess
       ok <- Guess g
       (case ok of
             Correct => case letters of
                          Z => do Won
                                  ShowState
                                  Exit
                          S k => do Message "Correct"
                                    gameLoop
             Incorrect => case guesses of
                          Z => do Lost
                                  ShowState
                                  Exit
                          S k => do Message "Incorrect"
                                    gameLoop)

||| Game set up
hangman : GameLoop () NotRunning $ const NotRunning
hangman = do NewGame "testing"
             gameLoop

||| (Concrete) Game state
data Game : GameState -> Type where
  GameStart : Game NotRunning
  GameWon : (word : String) -> Game NotRunning
  GameLost : (word : String) -> Game NotRunning
  InProgress : (word : String) -> (guesses : Nat) ->
               (missing : Vect letters Char) ->
               Game (Running guesses letters)

||| Game representation
Show (Game gs) where
  show GameStart = "Starting"
  show (GameWon word) = "Game won: word was " ++ word
  show (GameLost word) = "Game lost: word was " ++ word
  show (InProgress word guesses missing)
    = "\n" ++ pack (map hideMissing (unpack word))
           ++ "\n" ++ show guesses ++ " guesses left"
    where hideMissing : Char -> Char
          hideMissing c = if c `elem` missing then '-' else c

||| Fuel machinery
data Fuel = Dry | More (Lazy Fuel)

||| Result of a game
data GameResult : (ty : Type) -> (ty -> GameState) -> Type where
  OK : (res : ty) -> Game (outstate res) ->
       GameResult ty outstate
  OutOfFuel : GameResult ty outstate

||| Helper for returns of runs
ok : (res : ty) -> Game (outstate res) -> IO (GameResult ty outstate)
ok res st = pure (OK res st)

||| Running a game command over fuel
runCmd : Fuel ->
         Game instate ->
         GameCmd ty instate outstate ->
         IO (GameResult ty outstate)
runCmd fuel state (NewGame word)
  = ok () (InProgress (toUpper word) _ (fromList (letters word)))
runCmd fuel (InProgress word _ missing) Won = ok () (GameWon word)
runCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word)
runCmd fuel (InProgress word _ missing) (Guess c)
  = case isElem c missing of
      Yes prf => ok Correct (InProgress word _ (removeElem c missing))
      No contra => ok Incorrect (InProgress word _ missing)
runCmd fuel state ShowState = do printLn state
                                 ok () state
runCmd fuel state (Message x) = do putStrLn x
                                   ok () state
runCmd (More fuel) state ReadGuess
  = do putStr "Guess: "
       input <- getLine
       case unpack input of
         [x] => if isAlpha x
                  then ok (toUpper x) state
                  else do putStrLn "Invalid input"
                          runCmd fuel state ReadGuess
         _ => do putStrLn "Invalid input"
                 runCmd fuel state ReadGuess
runCmd Dry _ _ = pure OutOfFuel
runCmd fuel state (Pure res) = ok res state
runCmd fuel st (cmd >>= next)
  = do OK cmdRes newSt <- runCmd fuel st cmd
        | OutOfFuel => pure OutOfFuel
       runCmd fuel newSt (next cmdRes)

||| Running a game loop over fuel
run : Fuel ->
      Game instate ->
      GameLoop ty instate outstate ->
      IO (GameResult ty outstate)
run Dry _ _ = pure OutOfFuel
run (More fuel) st (cmd >>= next)
  = do OK cmdRes newSt <- runCmd fuel st cmd
       | OutOfFuel => pure OutOfFuel
       run fuel newSt (next cmdRes)
run (More fuel) st Exit = ok () st

-- all remaining functions are partial
%default partial

forever : Fuel
forever = More forever

main : IO ()
main = do run forever GameStart hangman
          pure ()


module Printf

import Prelude
import Data.String

data Arg
    = AInt      Arg
    | AOther    Char Arg
    | AEnd

buildArg : List Char -> Arg
buildArg fmt = case fmt of
    '%' :: 'i' :: fmtTail   => AInt (buildArg fmtTail)
    c :: fmtTail            => AOther c (buildArg fmtTail)
    Nil                     => AEnd

argToType : Arg -> Type -> Type
argToType a result = case a of
    AInt fmtTail      => Int -> argToType fmtTail result
    AOther _ fmtTail  => argToType fmtTail result
    AEnd              => result

-- PrintfType "foo" result = result
-- PrintfType "%i\n" result = Int -> result
-- etc
PrintfType : String -> Type -> Type
PrintfType fmt result = argToType (buildArg (unpack fmt)) result

sprintf : (fmt : String) -> PrintfType fmt String
sprintf fmt = go "" (buildArg (unpack fmt)) where
    go : String -> (arg : Arg) -> argToType arg String
    go strTail arg = case arg of
        AInt fmtTail        => \i : Int => go (strTail ++ show i) fmtTail
        AOther c fmtTail    => go (strTail ++ singleton c) fmtTail
        AEnd                => strTail

test : ?result
test = sprintf "%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i"