module Toolkit.Data.DList.DeBruijn

import public Decidable.Equality

import public Data.List.Elem

import public Toolkit.Data.List.DeBruijn

import public Toolkit.Data.DList
import public Toolkit.Data.DList.Elem

%default total

namespace DList

  public export
  Context : (idx      : Type)
         -> (type     : idx -> Type)
         -> (indicies : List idx)
                     -> Type
  Context = DList

  public export
  Contains : (idxType  : Type)
          -> (typeType : idxType -> Type)

          -> {indicies : List idxType}

          -> (ctxt : Context idxType typeType indicies)
          -> {idx  : idxType}
          -> (type : typeType idx)
                  -> Type
  Contains idxType typeType xs x = Elem idxType typeType x xs

  ||| Append `x` to the head of `xs`.
  public export
  (+=) : {v : a}
      -> (xs : DList a e vs)
      -> (x  : e v)
            -> DList a e (v::vs)
  (+=) xs x = x :: xs

{- A nice to have below, work in progress.

namespace Renaming

  public export
  weaken : {idx : typeIdx}
        -> {type' : typeType idx}
        -> (func : Contains typeIdx typeType old type
                -> Contains typeIdx typeType new type)
        -> (Contains typeIdx typeType (old += type') type
         -> Contains typeIdx typeType (new += type') type)

  weaken func (H (Same Refl Refl)) = H (Same Refl Refl)
  weaken func (T rest)             = T (func rest)

  public export
  interface Rename (idxType  : Type)
                   (typeType : idxType -> Type)
                   (term     : {indicies : List idxType}
                            -> {idx      : idxType}
                            -> (context  : DList idxType typeType indicies)
                            -> (type     : typeType idx)
                                        -> Type)
      | term
    where

      rename : {indiciesOld : List idxType}
            -> {indiciesNew : List idxType}
            -> {old : DList idxType typeType indiciesOld}
            -> {new : DList idxType typeType indiciesNew}
            -> (f : {level : idxType}
                 -> {type  : typeType level}
                          -> Contains idxType typeType old type
                          -> Contains idxType typeType new type)
           -> ({level : idxType}
            -> {type  : typeType level}
                     -> term old type
                     -> term new type)

      var : {indicies : List idxType}
         -> {ctxt     : DList idxType typeType indicies}
         -> {idx      : idxType}
         -> {type     : typeType idx}
                     -> Elem idxType typeType type ctxt
                     -> term ctxt type

--  weakens : {idxType  : Type}
--         -> {typeType : idxType -> Type}
--         -> {term     : {indicies : List idxType}
--                     -> {idx      : idxType}
--                     -> (context  : DList idxType typeType indicies)
--                     -> (type     : typeType idx)
--                                 -> Type}
--         -> Rename idxType typeType term
--         => {indiciesOld : List idxType}
--         -> {indiciesNew : List idxType}
--         -> {old : DList idxType typeType indiciesOld}
--         -> {new : DList idxType typeType indiciesNew}
--         -> {level' : idxType}
--         -> {type' : typeType level'}
--         -> (f : {level : idxType}
--              -> {type  : typeType level}
--                       -> Contains idxType typeType old type
--                       -> term                      new type)
--         -> ({level : idxType}
--          -> {type  : typeType level}
--                   -> Contains idxType typeType (type' :: old) type
--                   -> term                      (type' :: new) type)
--  weakens f (H (Same Refl Refl)) = var (H (Same Refl Refl))
--  weakens f (T rest)             = rename T (f rest)

namespace Substitution

  namespace General
    public export
    interface Rename idx type term
           => Substitute (idxType  : Type)
                         (typeType : idxType -> Type)
                         (term     : {indicies : List idxType}
                                  -> {idx      : idxType}
                                  -> (context  : DList idxType typeType indicies)
                                  -> (type     : typeType idx)
                                              -> Type)
         | term
       where

         subst : {old, new : List type}
              -> (f : {ty  : type}
                          -> Contains old ty
                          -> term     new ty)
              -> ({ty : type}
                     -> term old ty
                     -> term new ty)
(f : {level : Universe}
            -> {type  : MTy level}
                     -> Types.Contains old type
                     -> SystemV new type)
       -> ({level : Universe}
        -> {type  : MTy level}
                 -> SystemV old type
                 -> SystemV new type)

--  namespace Single
--
--    apply : {type : Type}
--         -> {term : List type -> type -> Type}
--         -> Rename type term
--         => {ctxt   : List type}
--         -> {typeA  : type}
--         -> {typeB  : type}
--         -> (this   : term      ctxt    typeB)
--         -> (idx    : Contains (ctxt += typeB) typeA)
--                   -> term      ctxt           typeA
--    apply this Here = this
--    apply this (There rest) = var rest
--
--    export
--    subst : {type : Type}
--         -> {term : List type -> type -> Type}
--         -> Rename type term
--         => Substitute type term
--         => {ctxt          : List type}
--         -> {typeA         : type}
--         -> {typeB         : type}
--         -> (this          : term  ctxt           typeB)
--         -> (inThis        : term (ctxt += typeB) typeA)
--                          -> term  ctxt           typeA
--    subst {ctxt} {typeA} {typeB} this inThis
--      = subst (apply this) inThis

-}
-- [ EOF ]


||| Spec: https://webassembly.github.io/spec/core/syntax/instructions.html#control-instructions
module WebAssembly.Structure.Instructions.Control

import WebAssembly.Structure.Types
import WebAssembly.Structure.Modules.Indices

-- Definition
-- Hint: Actual control-instructions are defined in
-- WebAssembly.Structure.Instructions.Definitions

public export
data BlockType : Type where
  BlockTypeTypeIdx   : TypeIdx -> BlockType
  BlockTypeEmpty     : BlockType
  BlockTypeSingelton : ValType -> BlockType

total public export
lemma_blocktypetypeindex_not_blocktypeempty : ((BlockTypeTypeIdx ti) = BlockTypeEmpty) -> Void
lemma_blocktypetypeindex_not_blocktypeempty Refl impossible

total public export
lemma_blocktypetypeindex_not_blocktypesingelton : ((BlockTypeTypeIdx ti) = (BlockTypeSingelton vt)) -> Void
lemma_blocktypetypeindex_not_blocktypesingelton Refl impossible

total public export
lemma_blocktypeempty_not_blocktypesingelton : (BlockTypeEmpty = (BlockTypeSingelton vt)) -> Void
lemma_blocktypeempty_not_blocktypesingelton Refl impossible

total public export
lemma_blocktype__typeindex_injective : ((i = j) -> Void) -> (BlockTypeTypeIdx i = BlockTypeTypeIdx j) -> Void
lemma_blocktype__typeindex_injective i_not_j Refl = i_not_j Refl

total public export
lemma_blocktype__singelton_injective : ((vt1 = vt2) -> Void) -> (BlockTypeSingelton vt1 = BlockTypeSingelton vt2) -> Void
lemma_blocktype__singelton_injective vt1_not_vt2 Refl = vt1_not_vt2 Refl

-- Decidable Equality

public export
implementation DecEq BlockType where
  decEq (BlockTypeTypeIdx k)   (BlockTypeTypeIdx j) with (decEq k j)
    decEq (BlockTypeTypeIdx k)   (BlockTypeTypeIdx j) | No contra = No $ lemma_blocktype__typeindex_injective contra
    decEq (BlockTypeTypeIdx k)   (BlockTypeTypeIdx k) | Yes Refl = Yes Refl
  decEq (BlockTypeTypeIdx k)   BlockTypeEmpty         = No lemma_blocktypetypeindex_not_blocktypeempty
  decEq (BlockTypeTypeIdx k)   (BlockTypeSingelton x) = No lemma_blocktypetypeindex_not_blocktypesingelton
  decEq BlockTypeEmpty         (BlockTypeTypeIdx k)   = No $ negEqSym lemma_blocktypetypeindex_not_blocktypeempty
  decEq BlockTypeEmpty         BlockTypeEmpty         = Yes Refl
  decEq BlockTypeEmpty         (BlockTypeSingelton x) = No lemma_blocktypeempty_not_blocktypesingelton
  decEq (BlockTypeSingelton x) (BlockTypeTypeIdx k)   = No $ negEqSym lemma_blocktypetypeindex_not_blocktypesingelton
  decEq (BlockTypeSingelton x) BlockTypeEmpty         = No $ negEqSym lemma_blocktypeempty_not_blocktypesingelton
  decEq (BlockTypeSingelton x) (BlockTypeSingelton y) with (decEq x y)
    decEq (BlockTypeSingelton x) (BlockTypeSingelton y) | No contra = No $ lemma_blocktype__singelton_injective contra
    decEq (BlockTypeSingelton x) (BlockTypeSingelton x) | Yes Refl = Yes Refl


module Fancy_Ops
{-
   This includes some work done on having more of a well-typed feel to the
   Operational semantics for FLK. It wound up being farely complicated, and
   ruined some of the untyped feel of the semantics, so now it is over here.
 -}
import Data.SortedMap

Ident : Type
Ident = String

data Op2 : Type -> Type -> Type where
  Plus    : Op2 Nat Nat
  Minus   : Op2 Nat Nat
  Times   : Op2 Nat Nat
  LThan   : Op2 Nat Bool
  GThan   : Op2 Nat Bool
  LEThan  : Op2 Nat Bool
  GEThan  : Op2 Nat Bool
  EQual   : Op2 inT outT
  NEqual  : Op2 inT outT

data Op1 : Type -> Type -> Type where
  Not : Op1 Bool Bool

data Status = Inter | Done | Lam

mutual
  Env : Type
  Env = SortedMap Ident (Exp Done)

  data Exp : Status -> Type where
    App   : Exp a   -> Exp b          -> Exp Inter
    Abs   : Ident   -> Exp a          -> Exp Lam
    Rec   : Ident   -> Exp a          -> Exp Done
    If    : Exp a   -> Exp b -> Exp c -> Exp Inter
    Prim1 : Op1 w x -> Exp a          -> Exp Inter
    Prim2 : Op2 w x -> Exp a -> Exp b -> Exp Inter
    N     : Nat                       -> Exp Done
    B     : Bool                      -> Exp Done
    Clos  : Env     -> Exp Lam        -> Exp Done
    Id    : Ident                     -> Exp Inter

total
tView : (n : Exp Done) -> Type
tView (Rec _ _) = {a : Type} -> {b : Type} -> (a -> b)
tView (N _) = Nat
tView (B _) = Bool
tView (Clos _ _) = {a : Type} -> {b : Type} -> (a -> b)

total
calc1 : (x : Exp Done) -> (op : Op1 a b) -> (tView x = a) -> (y ** tView y = b)
calc1 (B x) Not prf = let b = B (not x) in (b ** Refl)
calc1 (Rec x y) Not prf = ?h7_1
calc1 (N k) Not prf = absurd (t prf)
  where t : (Nat = Bool) -> Void
calc1 (Clos x y) Not prf = ?h1_4


module Lib
import Prelude.Doubles as db

export
stopwords : List String
stopwords = ["the", "a", "and", "is", "be", "will", "is"]

export
nums : String
nums = "0123456789!@#$%^&*()_+=-:;"

export
removeStopWords : String -> List String
removeStopWords line = do
              let tmp = words line
              foldr (\x, acc => if elem x stopwords then acc else x::acc ) [] tmp

export
makeWordPairs : List String -> List (String, String)
makeWordPairs [] = []
makeWordPairs (x::y::z::h::xs) = (x,y)::(x,z)::(y,z)::(y,h)::(z,x)::(z,y)::(z,h)::(h,x)::(h,y)::(h,z)::makeWordPairs xs
makeWordPairs (x::y::z::xs) = (x,y)::(x,z)::(y,z)::(z,x)::(z,y)::makeWordPairs xs
makeWordPairs (x::y::xs) = (x,y)::makeWordPairs xs

export
createDictionary : List String ->  List (String, Nat)
createDictionary xss = func 0 tmp
              where
                tmp = sort . nub $ xss
                func : Nat -> List String -> List (String, Nat)
                func _ [] = []
                func Z (x::xs) = (x, S Z) :: func (S (S Z)) xs
                func (S k) (x::xs) = (x, S k) :: func (S (S k) ) xs

export
insertAt : List Double -> Double -> Nat -> List Double
insertAt [] elem pos = []
insertAt (x::xs) elem  Z = elem::x::xs
insertAt (x::xs) elem (S Z) = x::elem::xs
insertAt (x::xs) elem (S k) = x::insertAt xs elem k

export
oneHotEncoder : List Nat -> List Double -> List (List Double)
oneHotEncoder ws zs = foldr(\x, acc => (insertAt zs 1.0 x)::acc) [] ws

export
matrix_gen : Num j =>  List j -> List j -> List (List j )
matrix_gen ws zs = foldr (\x, acc => zs::acc) [] ws

b : Double
b = 0.3

export
softmax_activation : List Double -> List Double
softmax_activation xs = let softmax_denom = sum $ map exp $ xs
in foldr (\x,acc => (exp x)/softmax_denom::acc) [] xs

export
nn_Layer : List Double -> List Double -> List Double
nn_Layer [] _ = []
nn_Layer _ [] = []
nn_Layer [] [] = []
nn_Layer (x::xs) (y::ys) = (x * y + b)::nn_Layer xs ys

export
grad_CrossEntropy : List Double -> List Double -> List Double
grad_CrossEntropy [] _ = []
grad_CrossEntropy _ [] = []
grad_CrossEntropy [] [] = []
grad_CrossEntropy (x::xs) (y::ys) = -(y/x) + (1-y)/(1-x)::grad_CrossEntropy xs ys

export
adam_Optimizer : List Double -> List Double -> Double -> Double -> Double -> Double -> Double -> Double -> List Double
adam_Optimizer [] _ _ _ _ _ _ _ =  []
adam_Optimizer _ [] _ _ _ _ _ _ =  []
adam_Optimizer (t::thetas) (gt::gts) alpha m_prev v_prev beta1 beta2 epsilon = do
              let m_current = (beta1 * m_prev + (1-beta1) * gt)/ (1-beta1)
              let v_current = (beta2 * v_prev + (1-beta2) *  (db.pow gt 2))/(1-(db.pow beta2 2))
              let mhat_current = m_current /(1-beta1)
              let vhat_current = v_current/(1-beta2)
              (t - alpha * mhat_current / ((sqrt  vhat_current) + epsilon)):: adam_Optimizer thetas gts alpha m_current v_current beta1 beta2 epsilon

export
wordpairs : List String -> List (String,String)
wordpairs wrds = makeWordPairs wrds

export
xss : List (String, String) -> List String
xss wordpairs = map (\(a,b) => a ) wordpairs

export
yss : List (String,String) -> List String
yss wordpairs = map (\(a,b) => b ) wordpairs

export
wordify : List String -> List String
wordify [] = []
wordify (fst::xss) =
            let bn = words fst
            in bn ++ wordify xss

export
rawToDict : List String -> List (String,Nat)
rawToDict [] = []
rawToDict dataset = let some_var = wordify dataset
                    in createDictionary some_var

export
rawToCleaned : List String -> List String
rawToCleaned [] = []
rawToCleaned (x::xs) = let some_var = removeStopWords x
                       in some_var ++ rawToCleaned xs
export
fullNNLayer : List (List Double) -> List (List Double) -> List (List Double)
fullNNLayer [] [] = []
fullNNLayer (x::inputs) (y::weights) = (softmax_activation $ nn_Layer x y)::fullNNLayer inputs weights

export
loss_func : (List Double -> List Double -> List Double ) -> List (List Double) -> List (List Double) -> List (List Double)
loss_func f [] _ = []
loss_func f _ [] = []
loss_func f [] [] = []
loss_func f (p::preds) (t::targets) = f p t :: loss_func f preds targets

export
optimizer : ( List Double -> List Double -> Double -> Double -> Double -> Double -> Double -> Double -> List Double) -> List (List Double) -> List (List Double) -> Double -> Double -> Double -> Double -> Double -> Double -> List (List Double)
optimizer f [] _ _ _ _ _ _ _ = []
optimizer f _ [] _ _ _ _ _ _ = []
optimizer f [] [] _ _ _ _ _ _= []
optimizer f (ws::wss) (cs::costs) alpha  m v beta1 beta2 epsilon =  (f ws cs alpha m v beta1 beta2 epsilon) :: optimizer f wss costs alpha m  v beta1 beta2 epsilon

export
model : List (List Double) -> List (List Double) -> List (List Double) -> Double -> Double -> Double -> Double -> Int -> List (List Double )
model [] _ _ _ _ _ _ _ = []
model _ [] _ _ _ _ _ _ = []
model _ _ [] _ _ _ _ _ = []
model [] [] [] _ _ _ _ _= []
model weights inputs targets alpha beta1 beta2 epsilon iterations = case iterations == 0 of
                                              True => weights
                                              False => do
                                                  let predicted = fullNNLayer inputs weights
                                                  let full_cost = loss_func grad_CrossEntropy predicted targets
                                                  let new_weights = optimizer adam_Optimizer weights full_cost alpha 0.0 0.0 beta1 beta2 epsilon
                                                  model new_weights inputs targets alpha beta1 beta2 epsilon (iterations - 1)


module Main

import Data.String
import Data.Vect
import System

%default total

ints : Vect 4 Int
ints = [1, 2, 3, 4]

main : IO ()
main = do
  [_, arg] <- getArgs
      | _ => do putStrLn "One argument expected."
                exitFailure
  let n = stringToNatOrZ arg
  -- case block in a case block, which is needed to test this properly
  case natToFin n (length ints + 1) of
       Nothing => do putStrLn "Invalid number."
                     exitFailure
       Just (FS i) => putStrLn $ "Value: " ++ show (index i ints)


module Control.Monad.State

import public Control.Monad.Identity
import public Control.Monad.Trans

||| A computation which runs in a context and produces an output
public export
interface Monad m => MonadState stateType (m : Type -> Type) | m where
    ||| Get the context
    get : m stateType
    ||| Write a new context/output
    put : stateType -> m ()

||| The transformer on which the State monad is based
public export
record StateT (stateType : Type) (m : Type -> Type) (a : Type) where
  constructor ST
  runStateT : stateType -> m (a, stateType)

public export
implementation Functor f => Functor (StateT stateType f) where
    map f (ST g) = ST (\st => map (mapFst f) (g st)) where
       mapFst : (a -> x) -> (a, s) -> (x, s)
       mapFst fn (a, b) = (fn a, b)

public export
implementation Monad f => Applicative (StateT stateType f) where
    pure x = ST (\st => pure (x, st))

    (ST f) <*> (ST a)
        = ST (\st =>
                do (g, r) <- f st
                   (b, t) <- a r
                   pure (g b, t))

public export
implementation Monad m => Monad (StateT stateType m) where
    (ST f) >>= k
        = ST (\st =>
                do (v, st') <- f st
                   let ST kv = k v
                   kv st')

public export
implementation Monad m => MonadState stateType (StateT stateType m) where
    get   = ST (\x => pure (x, x))
    put x = ST (\y => pure ((), x))

public export
implementation MonadTrans (StateT stateType) where
    lift x
        = ST (\st =>
                do r <- x
                   pure (r, st))

public export
implementation (Monad f, Alternative f) => Alternative (StateT st f) where
    empty = lift empty
    (ST f) <|> (ST g) = ST (\st => f st <|> g st)

public export
implementation HasIO m => HasIO (StateT stateType m) where
  liftIO io = ST $ \s => liftIO $ io_bind io $ \a => pure (a, s)

||| Apply a function to modify the context of this computation
public export
modify : MonadState stateType m => (stateType -> stateType) -> m ()
modify f
    = do s <- get
         put (f s)

||| Evaluate a function in the context held by this computation
public export
gets : MonadState stateType m => (stateType -> a) -> m a
gets f
    = do s <- get
         pure (f s)

||| The State monad. See the MonadState interface
public export
State : (stateType : Type) -> (ty : Type) -> Type
State = \s, a => StateT s Identity a

||| Unwrap a State monad computation.
public export
runState : StateT stateType Identity a -> stateType -> (a, stateType)
runState act = runIdentity . runStateT act

||| Unwrap a State monad computation, but discard the final state.
public export
evalState : State stateType a -> stateType -> a
evalState m = fst . runState m

||| Unwrap a State monad computation, but discard the resulting value.
public export
execState : State stateType a -> stateType -> stateType
execState m = snd . runState m


identityInt : Int -> Int
identityInt x = x

identityString : String -> String
identityString x = x

identityBool : Bool -> Bool
identityBool x = x

identity : ty -> ty
identity x = x

doubleNat : Nat -> Nat
doubleNat x = x + x

doubleInteger : Integer -> Integer
doubleInteger x = x + x

double : Num ty => ty -> ty
double x = x + x


||| Commands Rules
||| Section 6
module Bautzen.Game.Command

import public Bautzen.GameUnit
import Bautzen.Game.Core
import Bautzen.Pos

import Data.Maybe.Extra

import Data.Fin
import Data.Nat
import Data.List

%default total

public export
atCommandDistance : Maybe Pos -> (Pos, Nat) -> Bool
atCommandDistance Nothing y = False
atCommandDistance (Just posUnit) (posHQ, commandDistance) =
  distance posUnit posHQ <= commandDistance

public export
withinCommandDistance : (unit : GameUnit) -> (hqs : List GameUnit) -> (pos : List (GameUnit, Pos)) -> Bool
withinCommandDistance unit hqs pos =
  any (atCommandDistance (lookup unit pos)) (catMaybes $ map positionAndDistance hqs)
  where
    positionAndDistance : GameUnit -> Maybe (Pos, Nat)
    positionAndDistance unit =
      case unitType unit of
        HQ => (\ p => (p, supportDistance unit)) <$> lookup unit pos
        _ => Nothing

||| Find the HQ for a given formation
public export
findHQ : GameUnit -> List (GameUnit, Pos) -> List GameUnit
findHQ unit units = map fst $ filter (flip isHQFor unit . fst) units

||| Check given `unit` is under command of its HQ or a corps/army HQ
public export
underCommand : (units : List (GameUnit, Pos)) -> (unit : GameUnit) -> Bool
underCommand units unit =
  withinCommandDistance unit hqs units
  where
    hqs : List GameUnit
    hqs = findHQ unit units

namespace CommandTest

  positions : List (GameUnit, Pos)
  positions = [ (Bautzen.GameUnit.p15_5dp, Hex 2 2)
              , (Bautzen.GameUnit.r857_294, Hex 2 3)
              , (Bautzen.GameUnit.p13_5dp, Hex 3 4)
              , (Bautzen.GameUnit.p5dp, Hex 3 6)
              , (Bautzen.GameUnit.p2awp, Hex 4 6)
              ]

  -- unit_is_under_command_if_with_command_distance_of_own_hq :
  --   underCommand CommandTest.positions GameUnit.p13_5dp = True
  -- unit_is_under_command_if_with_command_distance_of_own_hq = Refl

  -- unit_is_under_command_if_with_command_distance_of_army_or_corps_hq :
  --   underCommand CommandTest.positions GameUnit.p15_5dp = True
  -- unit_is_under_command_if_with_command_distance_of_army_or_corps_hq = Refl

  -- unit_is_not_under_command_of_hq_with_different_nationality :
  --   underCommand CommandTest.positions GameUnit.r857_294 = False
  -- unit_is_not_under_command_of_hq_with_different_nationality = Refl


module Main

import Data.SortedMap
import FLK_bos
import FLK_ast
import Effects
import Effect.StdIO

evalPrint : (s ** CF s) -> { [STDIO] } Eff ()
evalPrint (MkSigma x pf) with (evalCF x pf)
  evalPrint (MkSigma x pf) | Nothing = putStrLn $ "No evaluation for:" ++ (show pf)
  evalPrint (MkSigma x pf) | (Just (MkSigma y z)) = putStrLn $ (show pf) ++ " evaluates to " ++ (show y) ++ "by\n\t: " ++ (show z)

main : IO ()
main = run $ evalPrint ycomb


module WebAssembly.Validation.Modules.Memories

import WebAssembly.Structure
import WebAssembly.Validation.Conventions
import WebAssembly.Validation.Types

||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#memories)
|||
||| ```
||| ⊢ memtype ok
||| --------------------------------
||| C ⊢ {type memtype} : memtype
||| ```
public export
data ValidMem : Context -> Mem -> MemType -> Type where
  MkValidMem : (c : Context)
            -> (memtype : MemType)
            -> ValidMemoryType memtype
            -> ValidMem c (MkMem memtype) memtype


import Data.String

subtract : Neg a => a -> a -> a
subtract x y = y - x

parse : List Char -> Integer -> Integer
parse (x::xs) =
  case parseInteger (pack xs) of
    Nothing => id
    Just num =>
      case x of
        '+' => (+num)
        '-' => subtract num

loop : Integer -> List (List Char) -> Integer
loop acc lst = foldl (\x, f => f x) acc (map parse lst)

main : IO ()
main = do
  args <- getArgs
  case args of
    (_::arg::_) => do
      file <- readFile arg
      case file of
        Right res => print $ loop 0 $ map unpack (lines res)
        Left _ => putStrLn "File not found"
    _ => putStrLn "Usage: ./appositum input.txt"


module Cordial.Model.Common.Hacks

%default total
%access public export

fromDoubleToNat : Double -> Nat
fromDoubleToNat x =
  let x_int = cast {to=Int} x
  in cast {to=Nat} x_int

calcBits : Double -> Double
calcBits d = (ceiling ((log (d / 8)) / (log 2))) - 1


f : Nat -> Int -> Int -> Int
f (S k) m n = f k m n
f Z m n = if m == n then 0 else 1

main : IO ()
main = do
  putStrLn "hello world"
  printLn $ f 4 3 2


works : (n : (Nat, Nat)) ->
        let mk = n in
            {y : Bool} -> (z : Bool) -> String
works (m, k) {y} z = ?h1

FailType : (Nat, Nat) -> Type
FailType (m, k) = {y : Bool} -> (z : Bool) -> String

fails : (n : (Nat, Nat)) -> FailType n
fails (m, k) {y} z = ?h2

fails2 : (n : (Nat, Nat)) ->
         let (m, k) = n in
             {y : Bool} -> (z : Bool) -> String
fails2 (m, k) {y} z = ?h3


module Play.RankN

example2 : ({a : Type} -> a -> a) -> (Int, String)
example2 f = (f 2, f "hello")

example2' : ({a : Type} -> a -> a) -> Int
example2' = fst . example2
-- also compiles and works fine
-- example2' f = fst . example2 $ f

example3 : (({a : Type} -> a -> a) -> Int) -> String
example3 f = show . f $ id


import Data.Vect

infixr 5 .+.

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

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

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

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

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

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

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

parsePrefix: (schema: Schema) -> String -> Maybe (SchemaType schema, String)
parsePrefix SString item = getQuoted(unpack item)
  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 SInt item =
  case span isDigit item of
    ("", rest)  => Nothing
    (num, rest) => Just (cast num, ltrim rest)
parsePrefix (schemal .+. schemar) item =
  case parsePrefix schemal item of
    Nothing => Nothing
    Just(leftVal, input') =>
      case parsePrefix schemar input' of
        Nothing => Nothing
        Just (rightVal, input'') => Just ((leftVal, rightVal), input'')

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

parseCommand: (schema: Schema) -> String -> String -> Maybe(Command schema)
parseCommand schema "add" rest = case parseBySchema schema rest of
  Nothing         => Nothing
  Just    restok  => Just (Add restok)
parseCommand schema "get" val =
  case all isDigit (unpack val) of
    True  => Just(Get(cast val))
    False => Nothing
parseCommand schema "size" "" = Just Size
parseCommand schema "quit" "" = Just Quit
parseCommand _ _ _ = Nothing

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

total processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input =
  let
    storeSchema = schema store
    invalid = parse storeSchema input
    parsed = parse (schema store) input
  in
    case parsed of
      Nothing => Just("Invalid command\n", store)
      Just (Add item) => Just("ID: " ++ show (size store) ++ "\n", addToStore store item)
      Just (Get pos) => getEntry pos store
      Just Size => Just("Size: " ++ show (size store) ++ "\n", store)
      Just Quit => Nothing

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


module Main

double : Int -> Int
double x = 2 * x

triple : Int -> Int
triple x = 10 * x

multiply : Int -> Int -> Int
multiply x y = x * y

IntFun : Type
IntFun = (Int -> Int)

data TheAlt : Type where
  MyCon : IntFun -> Lazy IntFun -> TheAlt

runCon : TheAlt -> Int -> Int
runCon (MyCon a b) i = let x = a i in if x > 5 then x else (b i)

main : IO ()
main = do
  let obj = MyCon double (multiply 100)
  --let obj = MyCon double triple
  printLn $ runCon obj 1
  printLn $ runCon obj 2
  printLn $ runCon obj 3


-- --------------------------------------------------------------- [ DList.idr ]
-- Module    : DList.idr
-- Copyright : (c) 2015,2016,2017 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

||| A `list` construct to create lists of dependent types.
|||
||| One of the problems with using dependent types is that types
||| depend on values. This affects the ability to construct lists of
||| values that have a dependent type. The existing `List` type cannot
||| be used as it requires all elements to have the same type.
module Data.DList

import Data.List

%access export

using (aTy : Type, elemTy : (aTy -> Type), x : aTy)

  ||| A list construct for dependent types.
  |||
  ||| @aTy    The type of the value contained within the list element type.
  ||| @elemTy The type of the elements within the list
  ||| @as     The List used to contain the different values within the type.
  public export
  data DList : (aTy : Type)
            -> (elemTy : aTy -> Type)
            -> (as : List aTy)
            -> Type where
    ||| Create an empty List
    Nil  : DList aTy elemTy Nil
    ||| Cons
    |||
    ||| @elem The element to add
    ||| @rest The list for `elem` to be added to.
    (::) : (elem : elemTy x)
        -> (rest : DList aTy elemTy xs)
        -> DList aTy elemTy (x::xs)

%name DList rest

-- -------------------------------------------------------------- [ Form Tests ]
isNil : DList aTy eTy as -> Bool
isNil Nil     = True
isNil (x::xs) = False

isCons : DList aTy eTy as -> Bool
isCons l = isNil l == False

-- ------------------------------------------- [ Predicates that are Decidable ]

public export
data NonEmpty : (xs : DList aTy eTy as) -> Type where
  IsNonEmpty : DList.NonEmpty (x::rest)

Uninhabited (DList.NonEmpty []) where
  uninhabited IsNonEmpty impossible

nonEmpty : (xs : DList aTy eTy as) -> Dec (NonEmpty xs)
nonEmpty Nil            = No absurd
nonEmpty (elem :: rest) = Yes IsNonEmpty

public export
data InBounds : (idx : Nat)
             -> (xs  : DList aTy eTy as)
             -> Type
  where
    InFirst : DList.InBounds Z (x::rest)
    InLater : (later : DList.InBounds idx rest)
           -> DList.InBounds (S idx) (x :: rest)

Uninhabited (DList.InBounds idx []) where
  uninhabited InFirst impossible
  uninhabited (InLater _) impossible

inBounds : (idx : Nat)
        -> (xs  : DList aTy eTy as)
        -> Dec (InBounds idx xs)
inBounds idx Nil = No uninhabited
inBounds Z (elem :: rest) = Yes InFirst
inBounds (S k) (elem :: rest) with (inBounds k rest)
  inBounds (S k) (elem :: rest) | (Yes prf) = Yes $ InLater prf
  inBounds (S k) (elem :: rest) | (No contra) =
      No (\p => case p of
                   InLater y => contra y)

-- ------------------------------------------------------------------ [ Length ]

public export
length : DList aTy eTy as -> Nat
length Nil     = Z
length (x::xs) = (S Z) + length xs

Sized (DList aTy eTy as) where
  size = length

-- ---------------------------------------------------------------- [ Indexing ]

public export
index : (idx : Nat)
     -> (xs  : DList aTy eTy as)
     -> {auto ok : InBounds idx xs}
     -> {auto ok' : List.InBounds idx as}
     -> eTy (index idx as)
index Z (y :: rest) {ok = InFirst} = y
index (S k) (y :: rest) {ok = (InLater later)} {ok' = (InLater x)} = index k rest

public export
head : (xs : DList aTy eTy (a::as))
    -> {auto ok : NonEmpty xs}
    -> {auto ok' : NonEmpty (a::as)}
    -> eTy a
head (y :: rest) {ok = IsNonEmpty} {ok' = IsNonEmpty} = y

public export
tail : (xs : DList aTy eTy (a :: as))
    -> {auto ok : NonEmpty xs}
    -> (DList aTy eTy as)
tail (x :: rest) {ok = IsNonEmpty} = rest

public export
last : (xs : DList aTy eTy as)
    -> {auto ok : NonEmpty xs}
    -> {auto ok' : NonEmpty as}
    -> eTy (last as)
last [] {ok = IsNonEmpty} {ok' = _} impossible
last (elem :: []) {ok = ok} {ok' = ok'} = elem
last (elem :: (y :: rest)) {ok = ok} {ok' = ok'} = last (y::rest)

public export
init : (xs : DList aTy eTy as)
    -> {auto ok  : NonEmpty xs}
    -> {auto ok' : NonEmpty as}
    -> DList aTy eTy (init as)
init [] {ok = IsNonEmpty} {ok' = _} impossible
init (elem :: []) {ok = ok} {ok' = ok'} = []
init (elem :: (y :: rest)) {ok = ok} {ok' = ok'} = elem :: init (y::rest)

-- --------------------------------------------------------- [ Bob The Builder ]

public export
(++) : DList aTy eTy xs
    -> DList aTy eTy ys
    -> DList aTy eTy (xs ++ ys)
(++) Nil     ys = ys
(++) (x::xs) ys = x :: (xs ++ ys)

public export
replicate : (n : Nat)
         -> elemTy a
         -> DList aTy elemTy (replicate n a)
replicate Z x = Nil
replicate (S k) x = x :: replicate k x

-- ---------------------------------------------------------------- [ SubLists ]

public export
take : (n : Nat)
    -> DList aTy elemTy as
    -> DList aTy elemTy (take n as)
take Z rest = Nil
take (S k) [] = []
take (S k) (elem :: rest) = elem :: take k rest

takeWhile : ({a : aTy} -> elemTy a -> Bool)
         -> DList aTy elemTy as
         -> (bs : List aTy ** DList aTy elemTy bs)
takeWhile p Nil     = (_ ** Nil)
takeWhile p (x::xs) =
    if p x
      then (_ ** DList.(::) x (snd (takeWhile p xs)))
      else (_ ** Nil)

public export
drop : (n : Nat)
    -> DList aTy elemTy as
    -> DList aTy elemTy (drop n as)
drop Z     rest = rest
drop (S k) [] = []
drop (S k) (elem :: rest) = drop k rest

dropWhile : ({a : aTy} -> elemTy a -> Bool)
         -> DList aTy elemTy as
         -> (bs : List aTy ** DList aTy elemTy bs)
dropWhile p Nil     = (_ ** Nil)
dropWhile p (x::xs) =
    if p x
      then dropWhile p xs
      else (_ ** DList.(::) x xs)

-- ---------------------------------------------------------------- [ Equality ]

eqDList : ({a,b : aTy} -> elemTy a -> elemTy b -> Bool)
       -> DList aTy elemTy as
       -> DList aTy elemTy bs
       -> Bool
eqDList _ Nil     Nil     = True
eqDList p (x::xs) (y::ys) =
  if p x y
    then eqDList p xs ys
    else False
eqDList _ _       _       = False

-- ------------------------------------------------------------------- [ Order ]

cmpDList : ({a,b : aTy} -> elemTy a -> elemTy b -> Bool)
        -> ({a,b : aTy} -> elemTy a -> elemTy b -> Ordering)
        -> DList aTy elemTy as
        -> DList aTy elemTy bs
        -> Ordering
cmpDList _  _   Nil     Nil     = EQ
cmpDList _  _   Nil     _       = LT
cmpDList _  _   _       Nil     = GT
cmpDList eq cmp (x::xs) (y::ys) =
  if not $ eq x y
    then cmp x y
    else cmpDList eq cmp xs ys

-- ----------------------------------------------------------------- [ Folding ]
-- TODO

foldr : ({a : aTy} -> elemTy a -> p -> p)
     -> p
     -> DList aTy elemTy as
     -> p
foldr f init Nil     = init
foldr f init (x::xs) = f x (DList.foldr f init xs)

foldl : ({a : aTy} -> p -> elemTy a -> p)
      -> p
      -> DList aTy elemTy as
      -> p
foldl f init Nil = init
foldl f init (x::xs) = DList.foldl f (f init x) xs

-- ----------------------------------------------------------------- [ Functor ]

map : ({a : aTy} -> elemTy a -> b)
       -> DList aTy elemTy as
       -> List b
map f Nil     = List.Nil
map f (x::xs) = with List f x :: DList.map f xs

-- TODO map from one DList to another.

mapMaybe : ({a : aTy} -> elemTy a -> Maybe b)
         -> DList aTy elemTy as
         -> List b
mapMaybe f Nil     = Nil
mapMaybe f (x::xs) =
  case f x of
    Nothing => mapMaybe f xs
    Just y  => y :: mapMaybe f xs

concatMap : Monoid m
         => (func : {a : aTy} -> elemTy a -> m)
         -> (xs : DList aTy elemTy as)
         -> m
concatMap f = foldr (\e, res => f e <+> res) neutral

-- --------------------------------------------------------- [ Transformations ]
-- TODO

||| From list of Dependent Pairs.
fromLDP : List (x : aTy ** eTy x)
       -> (as ** DList aTy eTy as)
fromLDP Nil     = (_ ** DList.Nil)
fromLDP (x::xs) = (_ ** DList.(++) [snd x] (snd $ fromLDP xs))

-- ---------------------------------------------- [ To List of Dependent Pairs ]

||| To List of Dependent Pairs
toLDP : DList aTy eTy as
     -> List (x : aTy ** eTy x)
toLDP Nil     = Nil
toLDP (x::xs) = (_**x) :: toLDP xs

||| List to DList
fromList : {ty : Type}
        -> {e : ty -> Type}
        -> {x : ty}
        -> (es : List (e x))
        -> DList ty e (replicate (length es) x)
fromList [] = Nil
fromList (x :: xs) = x :: fromList xs

-- -------------------------------------------------------- [ Membership Tests ]

any : ({a : aTy} -> elemTy a -> Bool)
   -> DList aTy elemTy as
   -> Bool
any p = DList.foldr (\e,res => res || p e) False

all : ({a : aTy} -> elemTy a -> Bool)
   -> DList aTy elemTy as
   -> Bool
all p = DList.foldr (\e,res => res && p e) True

elemBy : ({a,b : aTy} -> elemTy a -> elemTy b -> Bool)
      -> elemTy a
      -> DList aTy elemTy as
      -> Bool
elemBy p e = any (\x => p e x)

-- TODO elem

hasAnyBy : ({a,b : aTy} -> elemTy a -> elemTy b -> Bool)
         -> DList aTy elemTy as
         -> DList aTy elemTy bs
         -> Bool
hasAnyBy p es  Nil     = False
hasAnyBy p Nil es      = False
hasAnyBy p es  (x::xs) =
  if elemBy p x es
    then True
    else hasAnyBy p es xs

-- TODO hasAny

-- --------------------------------------------------------------- [ Searching ]

find : ({a : aTy} -> elemTy a -> Bool)
    -> DList aTy elemTy as
    -> Maybe $ DPair aTy elemTy
find p Nil     = Nothing
find p (x::xs) =
  if p x
    then Just (_ ** x)
    else find p xs

private
findIndex' : Nat
          -> ({a : aTy} -> elemTy a -> Bool)
          -> DList aTy elemTy as
          -> Maybe Nat
findIndex' cnt p Nil     = Nothing
findIndex' cnt p (x::xs) =
    if p x
      then Just cnt
      else findIndex' (S cnt) p xs

findIndex : ({a : aTy} -> elemTy a -> Bool)
         -> DList aTy elemTy as
         -> Maybe Nat
findIndex = findIndex' Z

private
findIndices' : Nat
            -> ({a : aTy} -> elemTy a -> Bool)
            -> DList aTy elemTy as
            -> List Nat
findIndices' cnt p Nil     = Nil
findIndices' cnt p (x::xs) =
    if p x
      then cnt :: findIndices' (S cnt) p xs
      else findIndices' (S cnt) p xs

findIndices : ({a : aTy} -> elemTy a -> Bool)
           -> DList aTy elemTy as
           -> List Nat
findIndices = findIndices' Z

elemIndexBy : ({a,b : aTy} -> elemTy a -> elemTy b -> Bool)
            -> elemTy a
            -> DList aTy elemTy as
            -> Maybe Nat
elemIndexBy p e = findIndex (\x => p e x)

-- TODO elemIndex

elemIndicesBy : ({a,b : aTy} -> elemTy a -> elemTy b -> Bool)
              -> elemTy a
              -> DList aTy elemTy as
              -> List Nat
elemIndicesBy p e = findIndices (\x => p e x)

-- TODO elemIndicies

-- ------------------------------------------------------------- [ Conversions ]
-- TODO

-- ----------------------------------------------------------------- [ Filters ]
-- TODO

-- ------------------------------------------------------------ [ Partitioning ]
-- TODO

span : ({a : aTy} -> elemTy a -> Bool)
    -> DList aTy elemTy xys
    -> ((xs ** DList aTy elemTy xs), (ys ** DList aTy elemTy ys))
span f Nil     = ((_ ** Nil), (_ ** Nil))
span f (x::xs) =
  if f x
    then let ((_ ** ys),(_ ** zs)) = span f xs
           in ((_ ** x::ys), (_ ** zs))
    else ((_ ** Nil), (_ ** (x::xs)))

break : ({a : aTy} -> elemTy a -> Bool)
      -> DList aTy elemTy xys
      -> ((xs ** DList aTy elemTy xs), (ys ** DList aTy elemTy ys))
break f xs = span (not . f) xs

split : ({a : aTy} -> elemTy a -> Bool)
     -> DList aTy elemTy xys
     -> (xxs ** DList (List aTy) (\xs => DList aTy elemTy xs) xxs)
split f xs =
  case break f xs of
    ((_ ** chunk), (_ ** Nil))     => (_ ** [chunk])
    ((_ ** chunk), (_ ** (y::ys))) => let (_ ** rest) = DList.split f ys
        in (_ ** DList.(::) chunk rest)

-- ----------------------------------------------------------------- [ Zipping ]
-- TODO

-- -------------------------------------------------------------- [ Predicates ]
-- TODO

-- ----------------------------------------------------------------- [ Sorting ]
-- TODO

mergeBy : Ord aTy => ({a,b : aTy} -> elemTy a -> elemTy b -> Ordering)
        -> DList aTy elemTy as
        -> DList aTy elemTy bs
        -> (cs ** DList aTy elemTy cs) -- Someday replace with (sort (as ++ bs))
mergeBy cmp Nil right = (_ ** right)
mergeBy cmp left Nil  = (_ ** left)
mergeBy cmp (x::xs) (y::ys) =
  if cmp x y == LT
    then let (_ ** rest) = mergeBy cmp xs      (y::ys) in (_ ** DList.(::) x rest)
    else let (_ ** rest) = mergeBy cmp (x::xs) ys      in (_ ** DList.(::) y rest)

-- -------------------------------------------------------------------- [ Show ]
-- A way of doing show, a little nasty but worth it.
private
doDListShow : ({a : aTy} -> elemTy a -> String)
           -> DList aTy elemTy as
           -> List String
doDListShow _  Nil     = Nil
doDListShow f  (x::xs) = (f x) :: doDListShow f xs

||| Function to show a `DList`.
|||
||| Due to limitations in idris wrt to class instances on dependent
||| types a generic show instance cannot be defined for
||| sigmalist. This will cause minor annoyances in its use.
|||
||| @showFunc A function to show the elements
||| @l       The list to be Shown.
showDList : (showFunc : {a : aTy} -> elemTy a -> String)
         -> (l : DList aTy elemTy as)
         -> String
showDList f xs = "[" ++ unwords (intersperse "," (doDListShow f xs)) ++ "]"

-- -------------------------------------------------------------- [ Predicates ]
||| Proof that some element is found in a `DList`.
|||
||| @iTy     The type of the element's index.
||| @elemTy  The type of the list element.
||| @x       An element in the list.
||| @xs      The list itself.
||| @prf     Proof that the element's index is in the list in the same position as the element itself.
public export
data DElem : (iTy    : Type)
          -> (elemTy : iTy -> Type)
          -> (x      : elemTy i)
          -> (xs     : DList iTy elemTy is)
          -> (prf    : Elem i is)
          -> Type
    where
      ||| Proof that the element is at the front of the list.
      Hier : DElem ity elemTy x (x :: xs) Here

      ||| Proof that the element is found later in the list.
      Er : (komst : DElem iTy elemTy x xs xs') -> DElem iTy elemTy x (x' ::xs) (There xs')

Uninhabited (DElem iTy elemTy a Nil prf) where
    uninhabited Hier impossible
    uninhabited (Er _) impossible

%name DElem komst

||| Analgous to `delete` for normal Lists, however, we require explicit proof that the element, and its index, are in the list.
|||
||| @a   The element to remove.
||| @as  The list to remove the element from.
||| @idx Proof that the index of `a` is in the type of `as`.
||| @prf Proof that the element's index is in the list in the same positino as the element itself.
delete' : (a    : elemTy i)
       -> (as   : DList iTy elemTy is)
       -> (idx  : Elem i is)
       -> (prf  : DElem iTy elemTy a as idx)
       -> DList iTy elemTy (dropElem is idx)
delete' a (a  :: rest) Here          Hier       = rest
delete' a (a' :: rest) (There later) (Er komst) = a' :: delete' a rest later komst

||| Analgous to `delete` for normal Lists, however, we must first calculate proof that the element, and its index, are in the list.
|||
||| @a   The element to remove.
||| @as  The list to remove the element from.
delete : (a        : elemTy i)
      -> (as       : DList iTy elemTy is)
      -> {auto idx : Elem i is}
      -> {auto prf : DElem iTy elemTy a as idx}
      -> DList iTy elemTy (dropElem is idx)
delete x xs {idx} {prf} = delete' x xs idx prf

||| Remove an element from the list given proof of its, and its
||| index's, location in the list.
|||
||| @as  The list to remove the element from.
||| @prf Proof that the element's index is in the list in the same
|||      position as the element itself.
public export
dropElem : (as  : DList iTy elemTy is)
        -> (prf : DElem iTy elemTy a as idx)
        -> DList iTy elemTy (dropElem is idx)
dropElem (a  :: rest) Hier       = rest
dropElem (a' :: rest) (Er komst) = a' :: dropElem rest komst

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


{-

1. Anything where the list is the same length as the input. We don't know
the types of elements contained in the list, however, so we can't look at them.
Some possibilities (there are many others!):

   - sorting the list
   - reversing the list
   - returning the input unchanged

2. Anything where the output list is twice as long as the input.
Some possibilities:

   - Duplicating each element
   - Returning the list appended to itself

3. Anything where the output list is one item shorter than the input, which
must itself be non-empty. Some possibilities:

    - Returning all but the first element
    - Returning all but the last element

4. The bounded number is likely to refer to a position in the list, so this
could be a function to return the element at that position.

-}


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Control.Lens.Setter
import Control.Lens.Types
import Control.Monad.Identity
import Data.Profunctor

%default total
%access public export

sets : ((a -> b) -> s -> t) -> Setter s t a b
sets l (Mor f) = Mor $ Id . l (runIdentity . f)

over : Setter s t a b -> (a -> b) -> s -> t
over l f = runIdentity . applyMor (l (Mor (Id . f)))

set : Setter s t a b -> b -> s -> t
set l b = over l (const b)

infixr 4 .~
(.~) : Setter s t a b -> b -> s -> t
(.~) = set

infixr 4 &~

(&~) : Setter s t a b -> (a -> b) -> s -> t
(&~) = over

infixl 1 &
(&) : a -> (a -> b) -> b
(&) a f = f a

mapped : Functor f => LensLike Identity (f a) (f b) a b
mapped = sets map

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


||| Lightweight representation of qualified names.
|||
||| TODO: Look at making names subject to user supplied predicates.
module Commons.Data.QName

import Commons.Text.Display

%default total
%access public export

data Ty = SIMPLE | QUALIFIED

data QName : (ty : Type) -> (shape : Ty) -> Type where
  BN : ty -> QName ty SIMPLE
  QN : ty -> QName ty shape -> QName ty QUALIFIED

fromList : (xs : List ty) -> (prf : NonEmpty xs) -> QName ty (if length xs > 1 then QUALIFIED else SIMPLE)
fromList (x :: []) IsNonEmpty = BN x
fromList (x :: (y :: xs)) IsNonEmpty with (nonEmpty xs)
  fromList (x :: (y :: xs)) IsNonEmpty | (Yes prf) =  QN x $ QN y $ fromList xs prf
  fromList (x :: (y :: xs)) IsNonEmpty | (No contra) = QN x $ BN y

fromList' : (xs : List ty)
         -> {auto prf : NonEmpty xs}
         -> QName ty (if length xs > 1 then QUALIFIED else SIMPLE)
fromList' xs {prf} = fromList xs prf

Show ty => Show (QName ty shape) where
  show (BN x)    = unwords ["BN", show x]
  show (QN x xs) = unwords ["QN", show x, show xs]

Display ty => Display (QName ty shape) where
  display (BN x) = display x
  display (QN x ys) = display x ++ "." ++ display ys

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


module Main

randoms : Int -> Stream Int
randoms seed =
  let seed' = 1664525 * seed + 1013904223
  in (seed' `shiftR` 2) :: randoms seed'

main : IO ()
main = do
  printLn $ take 100 $ randoms 52816


filter : (p : a -> Bool) -> List a -> List a
filter p []        = []
filter p (x :: xs) with (p x)
  _ | True  = x :: filter p xs
  _ | False = filter p xs

filterFilter : (p : a -> Bool) -> (xs : List a) ->
               filter p (filter p xs) === filter p xs
filterFilter p []        = Refl
filterFilter p (x :: xs) with (p x) proof eq
  _ | False = filterFilter p xs
  _ | True  with (p x)
    _ | True = cong (x ::) (filterFilter p xs)


||| Resources is framework for creating Resource Dependent EDSLs as described in the 2020 ECOOP paper:
||| *A Framework for Resource Dependent EDSLs in a Dependently Typed Language*.
|||
||| > Idris’ Effects library demonstrates how to embed resource dependent algebraic effect handlers into a
||| > dependently-typed host language, providing run-time and compile-time based reasoning on type-level resources.
||| > Building upon this work, Resources is a framework for realising Embedded Domain Specific Languages (EDSLs) with
||| > type-systems that contain domain specific substructural properties. Differing from Effects, Resources allows a
||| > language’s substructural properties to be encoded in a resource that is associated with language variables. Such
||| > an association allows for multiple effect instances to be reasoned about autonomically and without explicit
||| > type-level declaration. Type-level predicates are used as proof that the language’s substructural properties
||| > hold. Several exemplar EDSLs are presented that illustrates our framework’s operation and how dependent types
||| > provide correctness-by-construction guarantees that substructural properties of written programs hold.
|||
||| This module defines the Framework's core.
|||
module Resources

%default total
%access public export

namespace TypeLevel

  ||| Language variables are typed.
  |||
  ||| @Ty the type universe in which the variable exists.
  ||| @ty the variable's actual type.
  public export
  data Var : (Ty : Type) -> (ty : Ty) -> Type where
    MkVar : Var type value

  ||| Each variable has an associated abstract state.
  |||
  ||| @type the type universe in which the variable exists.
  ||| @calcStateType a function to compute the state's value from the provided type.
  ||| @value the variables type from which the abstract state's type is calculated.
  public export
  data StateItem : (type : Type)
                -> (calcStateType : type -> Type)
                -> (value : type)
                -> Type
    where
       MkStateItem : (value : type)
                  -> (label : Var type value)
                  -> (state : calcStateType value)
                  -> StateItem type calcStateType value

  ||| The context in which EDSL variables are bound and associated
  ||| with an abstract state.
  |||
  ||| The context is a simple cons-like data structure whose internal
  ||| values are are typed sith a common value.  We cannot utilise
  ||| Idris' `List` type as we need to collect at the type-level the
  ||| variable's type.  In future this should be replaced with `DList`
  ||| from idris-containers but that is future engineering.
  |||
  ||| @type the type universe in which the variable exists.
  ||| @calcStateType a function to compute the state's value from the provided type.
  public export
  data Context : (type : Type)
              -> (calcStateType : type -> Type)
              -> Type
    where
      Nil  : Context type calcStateType
      (::) : (item : StateItem type calcStateType value)
          -> (rest : Context type calcStateType)
          -> Context type calcStateType

  ||| A function to construct the type signature common to all
  ||| /Resource Dependent EDSLs/ as specified in the framework.
  |||
  ||| The signature describes a Hoare like monad that describes the
  ||| shift from an existing `pre` context to a new context based on
  ||| the expression's type.
  |||
  ||| @type the type universe in which the variable exists.
  ||| @calcStateType a function to compute the state's value from the provided type.
  public export
  Lang : (type : Type) -> (calcStateType : (val : type) -> Type) -> Type
  Lang type calcStateType =  (exprTy : Type)
                          -> (pre    : Context type calcStateType)
                          -> (postK  : exprTy -> Context type calcStateType)
                          -> Type

  ||| A simple algebraic data type to represent a /Resource Dependent EDSL/ instance.
  |||
  ||| @type the type universe in which the variable exists.
  ||| @calcStateType a function to compute the state's value from the provided type.
  public export
  data LANG : (type : Type) -> (calcStateType : type -> Type) -> Type where
      MkLang : (type : Type)
            -> (calcStateType : type -> Type)
            -> (lang : Lang type calcStateType)
            -> LANG type calcStateType

  ||| A type-level function calculate the next set of states based on a runtime value.
  |||
  ||| @value The runtime value used for calculation.
  ||| @postK The function that calculates the new state using `value`.
  public export
  updateState : (value : t)
             -> (postK : t -> Context type calcStateType)
             -> Context type calcStateType
  updateState value postK = postK value

  ||| A data structure that captures, generically, the sequencing of resource dependent EDSL language expressions.
  |||
  ||| @m the computation context in which this EDSL is defined.
  ||| @x the type associated with a language expression.
  ||| @calcStateType a function to compute the state's value from the provided type.
  ||| @spec The specific EDSL that is to be embedded.
  ||| @pre  The initial state that the expression knows about.
  ||| @post The final state the expression will be in that is dependent on the runtime value associated with the expression.
  public export
  data LangM : (m : Type -> Type)
            -> (x : Type)
            -> (spec : LANG type calcStateType)
            -> (pre  : Context type calcStateType)
            -> (post : x -> Context type calcStateType)
            -> Type
    where
      ||| Returns a value.
      Value : (value : a)
           -> {postK : a -> Context type calcStateType}
           -> LangM m a spec (postK value) postK

      ||| Provides sequencing of expressions and insertion of computed values into subsequent expressions.
      |||
      ||| @this The computation to run first.
      ||| @beInThis The next computation to run that uses the result of `this`.
      Let : (this : LangM m a spec old oldK)
         -> (beInThis : (val : a) -> LangM m b spec (oldK val) newK)
         -> LangM m b spec old newK

      ||| How to embedd an EDSL language expression into the framework.
      |||
      ||| @t The type of the expression.
      ||| @type the type universe in which the variable exists.
      ||| @calcStateType a function to compute the state's value from the provided type.
      ||| @pre  The initial state that the expression knows about.
      ||| @postK The final state the expression will be in that is dependent on the runtime value associated with the expression.
      ||| @eSig The function to compute the expressions type signature.
      ||| @expr The expression to embedd.
      Expr : {t,type : Type}
          -> {calcStateType : type -> Type}
          -> {pre   : Context type calcStateType}
          -> {postK : t -> Context type calcStateType}
          -> {eSig  : Lang type calcStateType}
          -> (expr : eSig t pre postK)
          -> LangM m t (MkLang type calcStateType eSig) pre (\v => updateState v postK)

  -- A high-level API to make embedding and use of the framework easier for users and designers.
  namespace API
    public export
    pure : (value : a) -> {postK : a -> Context type calcStateType} -> LangM m a spec (postK value) postK
    pure = Value

    public export
    (>>=) : LangM m a spec old oldK
       -> ((val : a) -> LangM m b spec (oldK val) postK)
       -> LangM m b spec old postK
    (>>=) = Let

    public export
    expr : {t,type : Type}
        -> {calcStateType : type -> Type}
        -> {pre   : Context type calcStateType}
        -> {postK : t -> Context type calcStateType}
        -> {eSig  : Lang type calcStateType}
        -> (expr : eSig t pre postK)
        -> LangM m t (MkLang type calcStateType eSig) pre (\v => updateState v postK)
    expr e = Expr e

namespace All
  ||| Ensure that a predicate applies to all items in the given context.
  |||
  ||| @p The predicate to apply to each item.
  ||| @c The context to apply the predicate to.
  public export
  data AllContext : (p : (value : type)
                      -> (item  : StateItem type calcStateType value)
                      -> Type)
                 -> (c : Context type calcStateType)
                 -> Type
    where
      Nil  : AllContext p Nil
      (::) : {p : (v : type) -> StateItem type calcStateType v -> Type}
          -> {value : type}
          -> {item  : StateItem type calcStateType value}
          -> {items : Context type calcStateType}
          -> (prf   : p value item)
          -> (rest  : AllContext p items)
          -> AllContext p (item :: items)

namespace Element

  ||| Existential quantification that there exists an item in the
  ||| context that the given predicate is satisifed.
  |||
  ||| @value The type of variable that the predicate is applied to.
  ||| @p The predicate to apply to each item.
  ||| @c The context to apply the predicate to.
  public export
  data InContext : (value : type)
                -> (p : StateItem type calcStateType value -> Type)
                -> (c : Context type calcStateType)
                -> Type
    where
      H : {p : StateItem type calcStateType value -> Type}
       -> (bewijs : p x)
       -> InContext value p (x :: rest)

      E : {p : StateItem type calcStateType value -> Type}
       -> (komt : InContext value p rest)
       -> InContext value p (not_x :: rest)

  Uninhabited (InContext value p Nil) where
    uninhabited (H _) impossible
    uninhabited (E _) impossible

  ||| Updates the element (at the provided index) in the provided context.
  |||
  ||| @context The context in which to apply the update.
  ||| @index The position of the item to be updated.
  ||| @f The update function to apply. The proof is included incase it contains
  |||    any interesting information for the update.
  public export
  update : (context : Context type calcStateType)
        -> (index   : InContext value predicate context)
        -> (f : (item   : StateItem type calcStateType value)
             -> (bewijs : predicate item)
             -> StateItem type calcStateType value)
        -> Context type calcStateType
  update (item :: rest)     (H bewijs) f = f item bewijs :: rest
  update (not_item :: rest) (E komt)   f = not_item :: update rest komt f

  ||| Remove the element (at the provided index) in the provided context.
  |||
  ||| @predicate The predicate that was applied to the item to be dropped.
  ||| @context The context in which the item is to be dropped.
  ||| @index The position of the item to drop.
  public export
  drop : {predicate : StateItem type calcStateType value -> Type}
      -> (context   : Context type calcStateType)
      -> (index     : InContext value predicate context)
      -> Context type calcStateType
  drop (item :: rest) (H bewijs) = rest
  drop (not_x :: rest) (E komt) = not_x :: drop rest komt

  ||| A helper function to replace the state in an element in our context.
  public export
  doUpdate : {predicate : StateItem type calcStateType value -> Type}
          -> (item     : StateItem type calcStateType value)
          -> (newState : calcStateType value)
          -> (bewijs   : predicate item)
          -> StateItem type calcStateType value
  doUpdate (MkStateItem value label state) newState bewijs = (MkStateItem value label newState)

  ||| An application of `update` to set the state for an item at the specified index.
  |||
  ||| @predicate The predicate that was applied to the item.
  ||| @context The context in which to apply the update.
  ||| @index The position of the item to be updated.
  ||| @item' The new state.
  public export
  setState : {predicate : StateItem type calcStateType value -> Type}
          -> (context   : Context type calcStateType)
          -> (index     : InContext value predicate context)
          -> (item'     : calcStateType value)
          -> Context type calcStateType
  setState context index item' = update context index (\i => doUpdate i item')

  ||| Proof that the given variable has the associated state.
  data HasVar : (lbl  : Var type value)
             -> (item : StateItem type calcStateType value)
             -> Type where
    DoesHaveVar : HasVar lbl (MkStateItem value lbl state)

-- -------------------------------------------------------------- [ Evaluation ]

namespace Env

  ||| Captures how EDSL variables are translated into concrete types.
  public export
  interface RealVar (type : Type) where
    CalcRealType : type -> Type

  ||| A container for holding concrete variable representations.
  public export
  data Tag : (type : Type) -> (value : type)
          -> Type
    where
      MkTag : RealVar type
           => (real : CalcRealType value)
           -> Tag type value

  ||| An evaluation environments to keep track of our language's real
  ||| variables and their abstract state, respective to the language's
  ||| typing context.
  public export
  data Env : (m : Type -> Type)
          -> (type    : Type)
          -> {calcStateType : type -> Type}
          -> (ctxt    : Context type calcStateType)
          -> Type
    where
      Nil  : Env m type Nil
      (::) : RealVar type
          => {item : StateItem type calcStateTy value}
          -> (tag  : Tag type value)
          -> (rest : Env m type items)
          -> Env m type (item::items)

  ||| Extracting a variable from the environment at the given index.
  |||
  ||| @env The environment being accessed.
  ||| @idx The position of the variable value to be extracted.
  public export
  lookup : RealVar type
        => (env : Env m type context)
        -> {p   : (item : StateItem type calcSTy value) -> Type}
        -> (idx : InContext value p context)
        -> Tag type value
  lookup (tag :: rest) (H bewijs) = tag
  lookup (tag :: rest) (E komt) = lookup rest komt

  ||| Update the type level state in the environment.
  |||
  ||| @env The environment being accessed.
  ||| @idx The position of the variable value to be updated
  ||| @up  The update function to be applied.
  public export
  update : RealVar type
        => (env  : Env m type ctxt)
        -> (idx  : InContext value p ctxt)
        -> (up   : (i : StateItem type calcSTy value)
                -> p i
                -> StateItem type calcSTy value)
        -> Env m type (update ctxt idx up)
  update (tag :: rest) (H bewijs) up = tag :: rest
  update (tag :: rest) (E komt) up = tag :: update rest komt up

  ||| Drop the state at the given index.
  |||
  ||| @env The environment being accessed.
  ||| @idx The position of the variable value to be dropped.
  public export
  drop : (env : Env m type ctxt)
      -> (idx : InContext value p ctxt)
      -> Env m type (drop ctxt idx)
  drop (tag :: rest) (H bewijs) = rest
  drop (tag :: rest) (E komt) = tag :: drop rest komt

namespace Building

  ||| The handler interface that describes how to evaluate languages in a presented computation context.
  |||
  ||| @type the type universe in which the variable exists.
  ||| @calcStateType a function to compute the state's value from the provided type.
  ||| @eSig The function to compute the expressions type signature.
  ||| @tyBRes The type associated with the accumulator if we are to build something.
  ||| @m The computation context in which to evaluate the language.
  public export
  interface RealVar type
         => Handler (type : Type)
                    (calcStateType : type -> Type)
                    (eSig   : Lang type calcStateType)
                    (tyBRes : Type)
                    (m      : Type -> Type) | type
    where
      ||| How to handle language expressions in the given computation context `m`.
      |||
      ||| @env the current evaluation context.
      ||| @expr the expression to be handled.
      ||| @acc an accumulator to be used if building something.
      ||| @cont a continuation to make things total.
      handle : (env  : Env m type pre)
            -> (expr : eSig tyExpr pre postK)
            -> (acc  : tyBRes)
            -> (cont : (value : tyExpr)
                    -> (env'  : Env m type (postK value))
                    -> (acc'  : tyBRes)
                    -> m tyRes)
            -> m tyRes

  ||| An internal helper function to evaluate an embedded language expression.
  |||
  ||| You will not need to call this at all.
  public export
  execBuild : RealVar type
           => Handler type calcStateType eSig tyBRes m
           => (env  : Env m type pre)
           -> (expr : eSig tyExpr pre postK)
           -> (acc  : tyBRes)
           -> (cont : (value : tyExpr)
                   -> (env'  : Env m type (updateState value postK))
                   -> (acc'  : tyBRes)
                   -> m tyRes)
           -> m tyRes
  execBuild env expr acc cont = handle env expr acc cont

  ||| An internal helper function to evaluate a `LangM` instance, and sequencing of expressions.
  |||
  ||| You will not need to call this at all.
  public export
  rawEval : RealVar type
         => Handler type calcStateType eSig tyBRes m
         => (env  : Env m type pre)
         -> (expr : LangM m tyExpr (MkLang type calcStateType eSig) pre postK)
         -> (acc  : tyBRes)
         -> (cont : (value : tyExpr)
                 -> (env'  : Env m type (postK value))
                 -> (acc'  : tyBRes)
                 -> m tyRes)
         -> m tyRes
  rawEval env (Value value {postK}) acc cont = cont value env acc
  rawEval env (Let this beIn) acc cont =
    rawEval env this acc (\this', env', acc' =>
                             rawEval env' (beIn this') acc' cont)
  rawEval env (Expr expr) acc cont = execBuild env expr acc cont

  ||| A helper data structure to container evaluation results.
  public export
  record Result (tyExpr : Type) (tyBRes : Type) where
    constructor MkResult
    computed : tyExpr
    built    : tyBRes

  ||| Evaluate the given closed program in the given applicative computation context `m`.
  |||
  ||| @init the initial value for our accumulator.
  ||| @expr the program to evaluate.
  public export
  run : Applicative m
     => RealVar type
     => Handler type calcStateType eSig tyBRes m
     => (init : tyBRes)
     -> (expr : LangM m tyExpr (MkLang type calcStateType eSig) Nil (const Nil))
     -> m (Result tyExpr tyBRes)
  run init expr = rawEval Nil expr init (\val, env', acc' => pure $ MkResult val acc')

  ||| Evaluate the given closed program in the identity computation context.
  |||
  ||| @init the initial value for our accumulator.
  ||| @expr the program to evaluate.
  public export
  runPure : RealVar type
        => Handler type calcStateType eSig tyBRes Basics.id
        => (init : tyBRes)
        -> (expr : LangM Basics.id tyExpr (MkLang type calcStateType eSig) Nil (const Nil))
        -> (Result tyExpr tyBRes)
  runPure init expr = rawEval Nil expr init (\val, env', acc' => MkResult val acc')

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


module Data.Crypto.Encryption.Stream

import Data.Bits
import Data.Vect

import Data.Crypto.Encryption
import Data.Crypto.Util

%default total
%access public export

interface Cipher k bitsPerChunk => StreamCipher k (bitsPerChunk : Nat) | k where
  generateKeystream : k -> Stream (Bits bitsPerChunk)

-- Stream ciphers are automorphic, so the encryption and decryption algorithms
-- are identical. I don’t know when that would ever be useful, but if it is, you
-- can just use `confound*` to handle whichever way you want.

confoundStream :
  StreamCipher k bitsPerChunk => k -> Stream (Bits bitsPerChunk) -> Stream (Bits bitsPerChunk)
confoundStream key = Stream.zipWith xor (generateKeystream key)
encryptStream :
  StreamCipher k bitsPerChunk => k -> Stream (Bits bitsPerChunk) -> Stream (Bits bitsPerChunk)
encryptStream = confoundStream
decryptStream :
  StreamCipher k bitsPerChunk => k -> Stream (Bits bitsPerChunk) -> Stream (Bits bitsPerChunk)
decryptStream = confoundStream

takeV : (n : Nat) -> (xs : Stream a) -> Vect n a
takeV Z     _         = []
takeV (S n) (x :: xs) = x :: (takeV n xs)

confoundMessage :
  StreamCipher k bitsPerChunk => k -> List (Bits bitsPerChunk) -> List (Bits bitsPerChunk)
confoundMessage key message =
  toList (zipWith xor
                  (takeV (length message) (generateKeystream key))
                  (fromList message))

implementation StreamCipher sc b => Encrypter sc b where
  encryptMessage = confoundMessage

implementation StreamCipher sc b => Decrypter sc b where
  decryptMessage = confoundMessage

implementation (StreamCipher sc b, Encrypter sc b, Decrypter sc b) =>
  SymmetricCipher sc b where

confound : (StreamCipher k _, Serializable i, Serializable o) => k -> i -> o
confound key = decode . confoundMessage key . encode


module ATM

import Data.Vect

PIN: Type
PIN = Vect 4 Integer

data ATMState = Ready | CardInserted | Session

data HasCard : ATMState -> Type where
  HasCI : HasCard CardInserted
  HasSession : HasCard Session

data PINCheck = CorrectPIN | IncorrectPIN

data ATMCmd : (ty: Type) -> ATMState -> (ty -> ATMState) -> Type where
  InsertCard: ATMCmd () Ready (const CardInserted)
  EjectCard: {auto prf: HasCard state} -> ATMCmd () state (const Ready)
  GetPIN: ATMCmd PIN CardInserted (const CardInserted)
  CheckPIN: PIN -> ATMCmd PINCheck CardInserted (\check => case check of
                                                              CorrectPIN => Session
                                                              IncorrectPIN => CardInserted)

  GetAmount: ATMCmd Nat state (const state)
  Dispense: (amount: Nat) -> ATMCmd () Session (const Session)

  Message: String -> ATMCmd () state (const state)

  Pure: (res: ty) -> ATMCmd ty (state_fn res) state_fn

  (>>=): ATMCmd a state1 state2_fn -> ((res: a) -> ATMCmd b (state2_fn res) state3_fn) -> ATMCmd b state1 state3_fn

insertEject : ATMCmd () Ready (const Ready)
insertEject = do InsertCard
                 EjectCard

-- atm: ATMCmd () Ready (const Ready)
-- atm = do InsertCard
--          pin <- GetPIN
--          pinOK <- CheckPIN pin
--          case pinOK of
--               CorrectPIN => do cash <- GetAmount
--                                Dispense cash
--                                EjectCard
--               IncorrectPIN => EjectCard

-- runATM: ATMCmd res inState outState_fn -> IO res
-- runATM InsertCard = do putStrLn "Please insert your card"
--                        x <- getLine
--                        pure()
-- runATM EjectCard = putStrLn "Thank you"
-- runATM GetPIN = do putStr "Enter Pin"
--                    pure (the (Vect _ Integer) [1, 2, 3, 4])
-- runATM (CheckPIN pin) = if pin == [1, 2, 3, 4]
--                           then pure CorrectPIN
--                           else pure IncorrectPIN
-- runATM GetAmount = do putStr "How much would you like"
--                       x <- getLine
--                       pure (cast x)
-- runATM (Dispense amount) = putStrLn "Here is the amount"
-- runATM (Message msg) = putStrLn msg
-- runATM (Pure res) = pure res
-- runATM (x >>= f) = do res <- runATM x
--                       runATM (f res)


module Crypto.Hash.SHA2

import Crypto.Hash.Interfaces
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.List
import Data.Nat
import Data.Nat.Factor
import Data.Vect
import Utils.Misc
import Utils.Bytes
import Crypto.Hash.MerkleDamgard

export
data Sha256 : Type where
  MkSha256 : MerkleDamgard 8 64 Bits32 -> Sha256

export
data Sha224 : Type where
  MkSha224 : Sha256 -> Sha224

export
data Sha512 : Type where
  MkSha512 : MerkleDamgard 8 128 Bits64 -> Sha512

export
data Sha384 : Type where
  MkSha384 : Sha512 -> Sha384

sha256_init_hash_values : Vect 8 Bits32
sha256_init_hash_values =
  [ 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a, 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19 ]

sha256_round_constants : Vect 64 Bits32
sha256_round_constants =
  [ 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5
  , 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174
  , 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da
  , 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967
  , 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85
  , 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070
  , 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3
  , 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2 ]

sha256_extend_message : Vect 16 Bits32 -> Stream Bits32
sha256_extend_message xs = prepend (toList xs) $ go xs
  where
  go : Vect 16 Bits32 -> Stream Bits32
  go xs =
    let
      [wi_16, wi_15, wi_7, wi_2] = the (Vect 4 _) $ map (flip index xs) [0, 1, 9, 14]
      s0 = rotr 7  wi_15 `xor` rotr 18 wi_15 `xor` shiftR wi_15 3
      s1 = rotr 17 wi_2 ` xor` rotr 19 wi_2  `xor` shiftR wi_2  10
      w = wi_16 + s0 + wi_7 + s1
    in
      w :: go (tail xs `snoc` w)

sha256_compress : (block : Vect 64 Bits8) -> (h : Vect 8 Bits32) -> Vect 8 Bits32
sha256_compress block hash_values = zipWith (+) hash_values $ go sha256_round_constants (take _ $ sha256_extend_message $ map (from_be {a = Bits32} {n = 4}) $ group 16 4 block) hash_values
  where
  go : (ks : Vect kn Bits32) -> (ws : Vect kn Bits32) -> (h : Vect 8 Bits32) -> Vect 8 Bits32
  go [] _ h = h
  go (k :: ks) (w :: ws) [a,b,c,d,e,f,g,h] =
    let
      s1 = rotr 6 e `xor` rotr 11 e `xor` rotr 25 e
      ch = (e .&. f) `xor` (complement e .&. g)
      temp1 = h + s1 + ch + k + w
      s0 = rotr 2 a `xor` rotr 13 a `xor` rotr 22 a
      maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c)
      temp2 = s0 + maj
    in
      go ks ws [temp1 + temp2, a, b, c, d + temp1, e, f, g]

sha256_update : List Bits8 -> Sha256 -> Sha256
sha256_update input (MkSha256 s) =
  let
    Fraction _ 64 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 64
    (blocks, residue) = splitAt (mult nblocks 64) (replace_vect (sym prf) (s.buffer ++ fromList input))
  in
    MkSha256 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte }
      ( foldl (\s_, block_ => {hash_values $= sha256_compress block_, npassed_blocks $= S} s_) s (group nblocks 64 blocks) )

sha256_finalize : Sha256 -> Vect 32 Bits8
sha256_finalize (MkSha256 s) =
  concat $ map (to_be {n = 4}) $
    case pad_theorem {block_nbyte = 64} {residue_max_nbyte = 55} {length_nbyte = 8} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_be _ $ 8 * (cast s.npassed_blocks * 64 + cast s.buffer_nbyte)) of
      Left block => sha256_compress block s.hash_values
      Right blocks => let (x1, x2) = splitAt 64 blocks in sha256_compress x2 $ sha256_compress x1 s.hash_values

sha224_init_hash_values : Vect 8 Bits32
sha224_init_hash_values =
  [ 0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939, 0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4 ]

sha512_init_hash_values : Vect 8 Bits64
sha512_init_hash_values =
  [ 0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b, 0xa54ff53a5f1d36f1
  , 0x510e527fade682d1, 0x9b05688c2b3e6c1f, 0x1f83d9abfb41bd6b, 0x5be0cd19137e2179 ]

sha512_round_constants : Vect 80 Bits64
sha512_round_constants =
  [ 0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc, 0x3956c25bf348b538
  , 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118, 0xd807aa98a3030242, 0x12835b0145706fbe
  , 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2, 0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235
  , 0xc19bf174cf692694, 0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65
  , 0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5, 0x983e5152ee66dfab
  , 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725
  , 0x06ca6351e003826f, 0x142929670a0e6e70, 0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed
  , 0x53380d139d95b3df, 0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b
  , 0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218
  , 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8, 0x19a4c116b8d2d0c8, 0x1e376c085141ab53
  , 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373
  , 0x682e6ff3d6b2b8a3, 0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec
  , 0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b, 0xca273eceea26619c
  , 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba, 0x0a637dc5a2c898a6
  , 0x113f9804bef90dae, 0x1b710b35131c471b, 0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc
  , 0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817 ]

sha512_extend_message : Vect 16 Bits64 -> Stream Bits64
sha512_extend_message xs = prepend (toList xs) $ go xs
  where
  public export
  go : Vect 16 Bits64 -> Stream Bits64
  go xs =
    let
      [wi_16, wi_15, wi_7, wi_2] = the (Vect 4 _) $ map (flip index xs) [0, 1, 9, 14]
      s0 = rotr 1  wi_15 `xor` rotr 8  wi_15 `xor` shiftR wi_15 7
      s1 = rotr 19 wi_2  `xor` rotr 61 wi_2  `xor` shiftR wi_2  6
      w = wi_16 + s0 + wi_7 + s1
    in
      w :: go (tail xs `snoc` w)

sha512_compress : (block : Vect 128 Bits8) -> (h : Vect 8 Bits64) -> Vect 8 Bits64
sha512_compress block hash_values = zipWith (+) hash_values $ go sha512_round_constants (take _ $ sha512_extend_message $ map (from_be {a = Bits64}) $ group 16 8 block) hash_values
  where
  go : (ks : Vect kn Bits64) -> (ws : Vect kn Bits64) -> (h : Vect 8 Bits64) -> Vect 8 Bits64
  go [] _ h = h
  go (k :: ks) (w :: ws) [a,b,c,d,e,f,g,h] =
    let
      s1 = rotr 14 e `xor` rotr 18 e `xor` rotr 41 e
      ch = (e .&. f) `xor` (complement e .&. g)
      temp1 = h + s1 + ch + k + w
      s0 = rotr 28 a `xor` rotr 34 a `xor` rotr 39 a
      maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c)
      temp2 = s0 + maj
    in
      go ks ws [temp1 + temp2, a, b, c, d + temp1, e, f, g]

sha512_update : List Bits8 -> Sha512 -> Sha512
sha512_update input (MkSha512 s) =
  let
    Fraction _ 128 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 128
    (blocks, residue) = splitAt (mult nblocks 128) (replace_vect (sym prf) (s.buffer ++ fromList input))
  in
    MkSha512 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte }
      ( foldl (\s_, block_ => {hash_values $= sha512_compress block_, npassed_blocks $= S} s_) s (group nblocks 128 blocks) )

sha512_finalize : Sha512 -> Vect 64 Bits8
sha512_finalize (MkSha512 s) =
  concat $ map (to_be {n = 8}) $
    case pad_theorem {block_nbyte = 128} {residue_max_nbyte = 111} {length_nbyte = 16} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_be _ $ 8 * (cast s.npassed_blocks * 128 + cast s.buffer_nbyte)) of
      Left block => sha512_compress block s.hash_values
      Right blocks => let (x1, x2) = splitAt 128 blocks in sha512_compress x2 $ sha512_compress x1 s.hash_values

sha384_init_hash_values : Vect 8 Bits64
sha384_init_hash_values =
  [ 0xcbbb9d5dc1059ed8, 0x629a292a367cd507, 0x9159015a3070dd17, 0x152fecd8f70e5939
  , 0x67332667ffc00b31, 0x8eb44a8768581511, 0xdb0c2e0d64f98fa7, 0x47b5481dbefa4fa4 ]

export
Digest Sha256 where
  digest_nbyte = 32
  update = sha256_update
  finalize = sha256_finalize

export
Digest Sha224 where
  digest_nbyte = 28
  update xs (MkSha224 s) = MkSha224 $ update xs s
  finalize (MkSha224 s) = take _ $ finalize s

export
Digest Sha512 where
  digest_nbyte = 64
  update = sha512_update
  finalize = sha512_finalize

export
Digest Sha384 where
  digest_nbyte = 48
  update xs (MkSha384 s) = MkSha384 $ update xs s
  finalize (MkSha384 s) = take _ $ finalize s

export
Hash Sha256 where
  block_nbyte = 64
  initialize = MkSha256 $ mk_merkle_damgard sha256_init_hash_values

export
Hash Sha224 where
  block_nbyte = 64
  initialize = MkSha224 $ MkSha256 $ mk_merkle_damgard sha224_init_hash_values

export
Hash Sha512 where
  block_nbyte = 128
  initialize = MkSha512 $ mk_merkle_damgard sha512_init_hash_values

export
Hash Sha384 where
  block_nbyte = 128
  initialize = MkSha384 $ MkSha512 $ mk_merkle_damgard sha384_init_hash_values


||| An example Resource Dependent EDSL (based upon Robin Milner's BiGraphs) to specify the physical and behavioural connections for mobile devices.
|||
||| This EDSL encapsulates the following concepts:
|||
||| 1. Messages, an atomic entity of arity zero.
||| 2. Devices, a complex entity (nesting) that contains many messages, and
||| artiy one. Devices have at most one connection to another device.
||| 3. Rooms, a complex entity (merge) of arity zero that contains many devices.
||| 4. Buildings, a complex entity (merge) of arity zero that contains many
||| rooms
||| 5. Regions, a complex entity (parallel) of arity zero that situates buildings in different regions.
|||
||| We define a handler to construct EDSL instances into a pure BiGraph form based upon an algebraic graph representation.
module Examples.BiGraph

import Data.Vect
import Resources

%default total
%access public export

{- [ NOTE ] The types for our Wireless EDSL -}

||| Device Types
data DTy = MOBILE | LAPTOP

||| Node types.
data Ty = ROOM | BUILDING | DEVICE DTy | MESSAGE

||| Mobile devices can support upto two connections, laptops ten.
maxConn : DTy -> Nat
maxConn MOBILE = 2
maxConn LAPTOP = 10

||| An abstract resource to capture device states.
|||
||| As the device is used the number of free connections will decrease until zero.
|||
||| @dtype The devce type.
data StateD : (dtype : DTy) -> Type where
  ||| Capture connection status and max number of connections.
  MkD : (connected : Bool) -> (curr : Nat) -> StateD ty

||| Default status of unconnected and a calculated number of connections.
defState : (type : DTy) -> StateD type
defState type = MkD False (maxConn type)

||| Map node types to an abstract resource.
|||
||| 1. Rooms, and messages, contain placement status.
||| 2. Buildings have no associated abstract state.
||| 3. Devices have type `StateD`
|||
CalcStateType : Ty -> Type
CalcStateType ROOM = Bool
CalcStateType BUILDING = ()
CalcStateType (DEVICE ty) = StateD ty
CalcStateType MESSAGE = Bool

||| A predicate to capture if a node has been unassigned.
|||
||| @value The type of node.
||| @lbl the node's bound name.
||| @item the nodes abstract state.
data Unassigned : (value : Ty)
               -> (lbl : Var Ty value)
               -> (item : StateItem Ty CalcStateType value)
               -> Type where
                     -- Type       | Label | Abstract State
  URoom    : Unassigned ROOM         rm      (MkStateItem ROOM         rm  False)
  UDevice  : Unassigned (DEVICE ty)  dev     (MkStateItem (DEVICE ty)  dev (MkD False c))
  UMessage : Unassigned MESSAGE      msg     (MkStateItem MESSAGE      msg False)

||| Function to update a node's abstract state to indicate node usage.
|||
||| @item the nodes abstract state.
||| @prf  that the node has not been assigned.
Use : (item : StateItem Ty CalcStateType value)
   -> (prf  : Unassigned value lbl item)
   -> StateItem Ty CalcStateType value
Use {value = ROOM} (MkStateItem ROOM lbl False) URoom = MkStateItem ROOM lbl True
Use {value = DEVICE ty} (MkStateItem (DEVICE ty) lbl (MkD False curr)) UDevice = MkStateItem (DEVICE ty) lbl (MkD True curr)
Use {value = MESSAGE} (MkStateItem MESSAGE lbl False) UMessage = MkStateItem MESSAGE lbl True

||| A predicate to capture that a node can be assigned to.
|||
||| @thisValue The type of node.
||| @thisVar the node's bound name.
||| @item the nodes abstract state.
data CanAssign : (thisValue : Ty)
              -> (thisVar   : Var Ty valueThis)
              -> (item  : StateItem Ty CalcStateType valueThis)
              -> Type where
                        -- Type      | Label | Abstract State
   ToABuilding : CanAssign BUILDING    bld     (MkStateItem BUILDING bld ())
   ToARoom     : CanAssign ROOM        rm      (MkStateItem ROOM     rm  True)
   ToADevice   : CanAssign (DEVICE ty) dev     (MkStateItem (DEVICE ty)   dev (MkD True (S n)))

||| A predicate to capture valid nesting of nodes.
data ValidAssign : Ty -> Ty -> Type where
  IsValidAssignBR : ValidAssign BUILDING    ROOM
  IsValidAssignRD : ValidAssign ROOM        (DEVICE ty)
  IsValidAssignDM : ValidAssign (DEVICE ty) MESSAGE

||| A type level function to update the abstract state of a node to indicate it's assignment.
|||
||| @var  the node's label
||| @prfV proof that it is a valid assignment.
||| @item the nodes abstract state.
||| @prf  that the node can be assigned.
Assign : (var  : Var Ty x)
      -> (prfV : ValidAssign value x)
      -> (item : StateItem Ty CalcStateType value)
      -> (prf  : CanAssign value lbl item)
      -> StateItem Ty CalcStateType value
Assign {value = BUILDING} var prfV (MkStateItem BUILDING lbl ()) ToABuilding =
  MkStateItem BUILDING lbl ()
Assign {value = ROOM} var prfV (MkStateItem ROOM lbl True) ToARoom = MkStateItem ROOM lbl True
Assign {value = (DEVICE ty)} var prfV (MkStateItem (DEVICE ty) lbl (MkD True (S n))) ToADevice =
  MkStateItem (DEVICE ty) lbl (MkD True n)

||| A predicate to capture that a device has sufficient space to handle more connections
data CanConnect : (to   : Var Ty (DEVICE type))
               -> (item : StateItem Ty CalcStateType (DEVICE type))
               -> Type where
  HasSpace : CanConnect dev (MkStateItem (DEVICE type) lbl (MkD True (S n)))

||| A type-level function to update the abstract state of a device.
|||
||| This decreases the number of free connections.
|||
||| @item the nodes abstract state.
||| @prf  that the node can be assigned.
Connect : (item : StateItem Ty CalcStateType (DEVICE type))
       -> (prf  : CanConnect to item)
       -> StateItem Ty CalcStateType (DEVICE type)
Connect (MkStateItem (DEVICE type) lbl (MkD True (S n))) HasSpace =
    MkStateItem (DEVICE type) lbl (MkD True n)

{- [ Language Definition ] -}

data Wireless : Lang Ty CalcStateType where
  ||| Create a new building.
  NewBuilding : Wireless (Var Ty BUILDING) old (\lbl => MkStateItem BUILDING lbl () :: old)

  ||| Create a new room.
  NewRoom : Wireless (Var Ty ROOM) old (\lbl => MkStateItem ROOM lbl False :: old)

  ||| Create a new device.
  NewDevice : (type : DTy)
           -> Wireless (Var Ty (DEVICE type)) old (\lbl => MkStateItem (DEVICE type) lbl (defState type) :: old)

  ||| Create a new message.
  NewMessage  : Wireless (Var Ty MESSAGE) old (\lbl => MkStateItem MESSAGE lbl False :: old)

  ||| Insert `varX` into `varY`
  |||
  ||| @varX The child node.
  ||| @varY The parent node.
  ||| @prfValid that it is a valid assignment.
  ||| @prfFree that one can insert into `varX`.
  ||| @prfInsert that one can assign `varY`
  Insert : (varX : Var Ty x)
        -> (varY : Var Ty y)
        -> (prfValid : ValidAssign y x)
        -> (prfFree : InContext x (Unassigned x varX) old)
        -> (prfInsert : InContext y (CanAssign y varY) (update old prfFree Use))
        -> Wireless () old (const $ update (update old prfFree Use) prfInsert (Assign varX prfValid))

  ||| Connect `varX` to `varY`
  |||
  ||| @varX The sending node.
  ||| @varY The receiving node.
  ||| @prfSpaceX that `varX` can be linked.
  ||| @prfSpaceY that `varY` can be linked.
  Link : (varX : Var Ty (DEVICE typeX))
      -> (varY : Var Ty (DEVICE typeY))
      -> (prfSpaceX : InContext (DEVICE typeX) (CanConnect varX) old)
      -> (prfSpaceY : InContext (DEVICE typeY) (CanConnect varY) (update old prfSpaceX Connect))
      -> Wireless () old (const $ update (update old prfSpaceX Connect) prfSpaceY Connect)

  ||| End the specification.
  End : Wireless () old (const Nil)

{- [ NOTE ]

A high-level API to embedd language expressions within `LangM`, and calculate language proofs.

-}

||| An resource dependent EDSL to describe communication networks and state.
WIRELESS : LANG Ty CalcStateType
WIRELESS = MkLang Ty CalcStateType Wireless

||| Create a new building.
newBuilding : LangM m (Var Ty BUILDING) WIRELESS old (\lbl => MkStateItem BUILDING lbl () :: old)
newBuilding = Expr $ NewBuilding

||| Create a new room.
newRoom : LangM m (Var Ty ROOM) WIRELESS old (\lbl => MkStateItem ROOM lbl False :: old)
newRoom = Expr $ NewRoom

||| Create a new device.
|||
||| @type The devices type.
newDevice : (type : DTy)
         -> LangM m (Var Ty (DEVICE type))
                    WIRELESS
                    old
                    (\lbl => MkStateItem (DEVICE type) lbl (defState type) :: old)
newDevice ty = Expr $ NewDevice ty

||| Create a new message
newMessage : LangM m (Var Ty MESSAGE)
                     WIRELESS
                     old
                     (\lbl => MkStateItem MESSAGE lbl False :: old)
newMessage = Expr $ NewMessage

||| Insert `varX` into `varY`.
insert : (varX : Var Ty x)
      -> (varY : Var Ty y)
      -> {auto prfValid : ValidAssign y x}
      -> {auto prfFree : InContext x (Unassigned x varX) old}
      -> {auto prfInsert : InContext y (CanAssign y varY) (update old prfFree Use)}
      -> LangM m () WIRELESS old (const $ update (update old prfFree Use) prfInsert (Assign varX prfValid))
insert x y {prfValid} {prfFree} {prfInsert} = Expr (Insert x y prfValid prfFree prfInsert)

||| Link two devices together.
link : (varX : Var Ty (DEVICE typeX))
    -> (varY : Var Ty (DEVICE typeY))
    -> {auto prfSpaceXY : InContext (DEVICE typeX) (CanConnect varX) old}
    -> {auto prfSpaceYX : InContext (DEVICE typeY) (CanConnect varY) (update old prfSpaceXY Connect)}
    -> LangM m () WIRELESS old (const $ update (update old prfSpaceXY Connect) prfSpaceYX Connect)
link x y {prfSpaceXY} {prfSpaceYX} = Expr (Link x y prfSpaceXY prfSpaceYX)

||| End a specification.
end : LangM m () WIRELESS old (const Nil)
end = Expr End

||| Type given to programs to ensure that they are closed.
|||
WirelessDesc : (m : Type -> Type) -> Type
WirelessDesc m = LangM m () WIRELESS Nil (const Nil)

{- [ NOTE]

Here we given an example before giving the evaluation context.

-}

|||
example : WirelessDesc m
example = do
  buildingA <- newBuilding
  buildingB <- newBuilding

  roomA <- newRoom
  roomB <- newRoom
  roomC <- newRoom

  laptopA <- newDevice LAPTOP
  laptopB <- newDevice LAPTOP
  laptopC <- newDevice LAPTOP
  mobile  <- newDevice MOBILE

  msg <- newMessage

  insert roomA buildingA
  insert laptopA roomA
  insert mobile  roomA
  insert msg mobile

  insert roomB buildingA
  insert laptopB roomB

  insert roomC buildingB
  insert laptopC roomC

  link laptopA laptopC
  link mobile laptopB
  end

{- [ Evaluation context ]
-}

||| An entity has an arity, an identifier, and is typed according to the EDSLs variable type.
data Entity : (type : Type) -> (value : type) -> Type where
  MkEntity : (n : Nat) -> (arity : Nat) -> Entity type value

namespace Algebra

 ||| An algebraic graph view of a Bigraph.
 |||
 ||| The shape of a bigraph follows its algebraic definition.
 ||| The type is indexed by the entity's concrete type.
 data BiGraph : Type -> Type where
   Identity : BiGraph a

   Node : Entity a value -> BiGraph a
   Outside : String -> BiGraph a

   Nesting : (BiGraph a) -> (BiGraph a) -> BiGraph a
   Merge   : (BiGraph a) -> (BiGraph a) -> BiGraph a
   Par     : (BiGraph a) -> (BiGraph a) -> BiGraph a
   Connect : (BiGraph a) -> (BiGraph a) -> BiGraph a
   Overlay : (BiGraph a) -> (BiGraph a) -> BiGraph a

||| We map the EDSL's variable types to concrete entity specifications.
public export
RealVar Ty where
  CalcRealType ROOM       = Entity Ty ROOM
  CalcRealType BUILDING   = Entity Ty BUILDING
  CalcRealType (DEVICE x) = Entity Ty (DEVICE x)
  CalcRealType MESSAGE    = Entity Ty MESSAGE

||| A handler to construct `BiGraph` instances from `WIRELESS` specifications.
|||
||| We run the evaluation in a pure context to enable bigraph construction.
|||
||| **Note** The accumulator in this instance is a counter to generate node identifiers, and the resulting bigraph itself.
public export
Handler Ty CalcStateType Wireless (Nat, BiGraph Ty) (Basics.id) where
  handle env NewBuilding      (ctr,g) cont = cont MkVar (MkTag (MkEntity ctr Z)::env)              (S ctr,g)
  handle env NewRoom          (ctr,g) cont = cont MkVar (MkTag (MkEntity ctr Z)::env)              (S ctr,g)
  handle env (NewDevice type) (ctr,g) cont = cont MkVar (MkTag (MkEntity ctr (maxConn type))::env) (S ctr,g)
  handle env NewMessage       (ctr,g) cont = cont MkVar (MkTag (MkEntity ctr Z)::env)              (S ctr,g)

  handle env (Insert varX varY prfValid prfFree prfInsert) (ctr,g) cont with (prfValid)
    handle env (Insert varX varY prfValid prfFree prfInsert) (ctr,g) cont | IsValidAssignBR = do
        let MkTag rm  = lookup env prfFree
        let env' = (update env prfFree Use)
        let MkTag bld = lookup env' prfInsert
        let env'' = update env' prfInsert (Assign varX IsValidAssignBR)
        cont () env'' (ctr, Overlay (Nesting (Node bld) (Node rm)) g)
    handle env (Insert varX varY prfValid prfFree prfInsert) (ctr,g) cont | IsValidAssignRD = do
        let MkTag dev  = lookup env prfFree
        let env' = (update env prfFree Use)
        let MkTag rm = lookup env' prfInsert
        let env'' = update env' prfInsert (Assign varX IsValidAssignRD)
        cont () env'' (ctr, Overlay (Nesting (Node rm) (Node dev)) g)
    handle env (Insert varX varY prfValid prfFree prfInsert) (ctr,g) cont | IsValidAssignDM = do
        let MkTag msg  = lookup env prfFree
        let env' = (update env prfFree Use)
        let MkTag dev = lookup env' prfInsert
        let env'' = update env' prfInsert (Assign varX IsValidAssignDM)
        cont () env'' (ctr, Overlay (Nesting (Node dev) (Node msg)) g)

  handle env (Link varX varY prfSpaceX prfSpaceY) (ctr,g) cont = do
    let MkTag x = lookup env prfSpaceX
    let env' = update env prfSpaceX Connect
    let MkTag y = lookup env' prfSpaceY
    let env'' = update env' prfSpaceY Connect
    cont () env'' (ctr, Overlay (Connect (Node x) (Node y)) g)

  handle env End (ctr,g) cont = cont () Nil (ctr,g)

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


module Cordial.Model.Common.Name

%default total
%access public export

data NameKind = WHOLE | INDEXED | ANY

data Name : (kind : NameKind) -> (type : Type) -> Type where
  WName : List String -> type -> Name WHOLE type
  IName : List String -> type -> Nat -> Name INDEXED type
  NoName : Name ANY type


import Control.Monad.State

increment : Nat -> State Nat ()
increment inc = do current <- get
                   put (current + inc)


module Service
%default total

||| Placeholder description of a smart contract
public export
data Contract : IO t -> Type -> Type where
     MkContract : (a : IO b) -> Contract a b

public export
trustContract : Contract a b -> b
-- This definition left blank for now, but in the future
-- it should provide proof of the existence of a smart contract

||| Abstract Syntax Tree for the Service DSL
public export
data Service : Type -> Type where
     ||| A Service that is definitely of type `a`
     Val     : a -> Service a
     ||| A contract has promised a reward if `a` is not a Service b
     Promise : Contract a b ->  Service b
     ||| Application of a Service to another Service
     App     : Service (a -> b) -> Service a -> Service b
     ||| Explicitly construct a Service using monadic binding
     Bind    : Service a -> (a -> Service b) -> Service b

public export
Functor Service where
        map f (Val a) = Val $ f a
        map f (Promise c) = Val $ f $ trustContract c  --TODO It might be better to never allow Vals to be made from Promises
        map f s = App (Val f) s

public export
Applicative Service where
            pure = Val
            (<*>) = App

public export
Monad Service where
      (>>=) = Bind
      join m = !m

||| Execute an entire service in an IO context
public export
execute : Service a -> IO a
execute (Val x) = pure x
execute (Promise (MkContract c)) = c
execute (App sf sx) = do
                        f <- execute sf
                        x <- execute sx
                        pure $ f x
execute (Bind sx f) = do
                        x <- execute sx
                        execute $ f x


foo : Nat -> Nat -> Bool
foo x y with (x == y)
  foo x y | True with (y == x)
    foo x y | True | False | 10 = x
    foo x y | True | True = x
  foo x y | False = y


import Aoc
import Data.List
import Data.List1
import Data.Strings
%default total

record Range where
  constructor mkRange
  low : Int
  high : Int
Show Range where
  show r = show r.low ++ "~" ++ show r.high

inRange : Range -> Int -> Bool
inRange r i = i >= r.low && i <= r.high

inRanges : List Range -> Int -> Bool
inRanges rs i = any (flip inRange i) rs

record Field where
  constructor mkField
  name : String
  ranges : List Range

Show Field where
  show f = show (f.name, f.ranges)

parseRange : String -> Maybe Range
parseRange s =
  case split (=='-') s of
    (a:::[b]) => mkRange <$> parseInteger a <*> parseInteger b
    _ => Nothing

parseField : String -> Maybe Field
parseField s =
  case split (==':') s of
    (name:::[rs]) => Just $ mkField name $ mapMaybe parseRange $ assert_total words rs
    _ => Nothing

onlyOne : List a -> Maybe a
onlyOne [x] = Just x
onlyOne _ = Nothing

whittle : Eq a => List (List a) -> List (List a)
whittle sets =
  let isolated = mapMaybe onlyOne sets
  in map (\s => if length s == 1 then s else filter (not . (`elem` isolated)) s) sets

main : IO ()
main = do
  let pcsi = parseCommaSeparatedIntegers {a=Int}
  (sfs:::[[_,smt],_::snts]) <- readParagraphs | _ => putStrLn "need 3 paragraphs"
  Just fs <- pure (traverse parseField sfs) | _ => putStrLn "fields parse error"
  Just mt <- pure (pcsi smt) | _ => putStrLn "my ticket parse error"
  Just nts <- pure (traverse pcsi snts) | _ => putStrLn "nearby tickets parse error"

  let values = concat nts
  let validAtAll = \i => any (`inRange` i) (concatMap (.ranges) fs)
  putStr "*   "; printLn $ sum $ filter (not . validAtAll) values

  let validTickets = filter (all validAtAll) nts
  let columns = transpose validTickets
  let sudoku = [[f.name | f <- fs, all (inRanges f.ranges) col] | col <- columns]
  let merryChristmas = 40 -- :) !!!!
  let solution = times merryChristmas whittle sudoku
  Just fieldOrder <- pure $ traverse onlyOne solution | _ => putStrLn "not enough progress"
  putStr "**  "; printLn $ product [v | (k,v) <- zip fieldOrder mt, "departure" `isPrefixOf` k]