module DataStore

import Data.Vect

infixr 5 .+.

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

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

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

export
empty: DataStore schema
empty = MkData 0 []

export
addToStore : (value: SchemaType schema) -> (store: DataStore schema) -> DataStore schema
addToStore value (MkData size items) = MkData _ (value :: items)

public export
data StoreView : DataStore schema -> Type where
  SNil : StoreView empty
  SAdd: (rec: StoreView store) -> StoreView (addToStore value store)

storeViewHelp : (items: Vect size (SchemaType schema)) -> StoreView (MkData size items)
storeViewHelp [] = SNil
storeViewHelp (val :: xs) = SAdd (storeViewHelp xs)

export
storeView : (store : DataStore schema) -> StoreView store
storeView (MkData size items) = storeViewHelp items

listItems : DataStore schema -> List (SchemaType schema)
listItems input with (storeView input)
  listItems empty                    |  SNil      = []
  listItems (addToStore value store) | (SAdd rec) = value :: (listItems store | rec)

filterKeys : (test : SchemaType schema -> Bool) -> DataStore (SString .+. schema) -> List String
filterKeys test input with (storeView input)
  filterKeys test empty                           |  SNil      = []
  filterKeys test (addToStore (key, value) store) | (SAdd rec) =
    if test value
    then key :: (filterKeys test store | rec)
    else filterKeys test store | rec

getValues : DataStore (SString .+. schema) -> List (SchemaType schema)
getValues input with (storeView input)
  getValues input                       |  SNil      = []
  getValues (addToStore (_, val) store) | (SAdd rec) = val :: (getValues store | rec)

testStore : DataStore (SString .+. SString .+. SInt)
testStore = addToStore ("Mercury", "Mariner 10",  1974) $
            addToStore ("Venus",   "Venera",      1961) $
            addToStore ("Uranus",  "Voyager 2",   1986) $
            addToStore ("Pluto",   "New Horizons",2015) $
            empty


module Adjoint
import Data.Morphisms

interface (Functor f, Functor g) => Adjoint (f : Type -> Type) (g : Type -> Type) where
  unit : a -> g (f a)
  counit : f (g a) -> a

phi : Adjoint f g => (f a -> b) -> a -> g b
phi f = map f . unit

psi : Adjoint f g => (a -> g b) -> f a -> b
psi f = counit . map f

Adjoint (Pair a) (Morphism a) where
  unit x = Mor (\y => (y, x))
  counit (x, Mor f) = f x

record Compose (f : Type -> Type) (g : Type -> Type) (a : Type) where
  constructor Comp
  getComp : f (g a)

(Functor f, Functor g) => Functor (Compose f g) where
  map f = Comp . map (map f) . getComp

interface Functor m => Monad' (m : Type -> Type) where
  eta : a -> m a
  mu  : m (m a) -> m a

  (>>=) : m a -> (a -> m b) -> m b
  ma >>= f = (mu . map f) ma

Adjoint f g => Monad' (Compose g f) where
  eta x = Comp (unit x)
  mu = Comp . map (counit . map getComp) . getComp

get : Compose (Morphism s) (Pair s) s
get = (Comp (Mor (\st => (st, st))))

set : s -> Compose (Morphism s) (Pair s) ()
set st = (Comp (Mor (\_ => (st, ()))))

example : Monad' (Compose (Morphism Int) (Pair Int)) => Compose (Morphism Int) (Pair Int) ()
example = do st <- get
             set (st + 1)
             eta ()

test : Int -> (Int, ())
test = applyMor (getComp example)


module EnumTypes

data Day = Monday
          | Tuesday
          | Wednesday
          | Thursday
          | Friday
          | Saturday
          | Sunday
%name Day day, day1, day2

nextWeekday : Day -> Day
nextWeekday Monday = Tuesday
nextWeekday Tuesday = Wednesday
nextWeekday Wednesday = Thursday
nextWeekday Thursday = Friday
nextWeekday Friday = Saturday
nextWeekday Saturday = Sunday
nextWeekday Sunday = Monday

testNextWeekday : (nextWeekday (nextWeekday Saturday)) = Monday
testNextWeekday = Refl


module Assn

import Expr
import Logic
import Maps

%access public export

%default total

Assertion : Type
Assertion = State -> Type

namespace ExAssertions
  as1 : Assertion
  as1 = \st => st X = 3

  as2 : Assertion
  as2 = \st => LTE (st X) (st Y)

  as3 : Assertion
  as3 = \st => Either (st X = 3) (LTE (st X) (st Y))

  as4 : Assertion
  as4 = \st => (LTE (st Z * st Z) (st X), Not (LTE (S (st Z) * S (st Z)) (st X)))

  as5 : Assertion
  as5 = \st => ()

  as6 : Assertion
  as6 = \st => Void

AssertImplies : (p, q : Assertion) -> Type
AssertImplies p q = (st : State) -> p st -> q st

infixr 8 ->>

(->>) : (p, q : Assertion) -> Type
(->>) = AssertImplies

assertImpliesRefl : p ->> p
assertImpliesRefl _ p_st = p_st

assertImpliesTrans : p ->> q -> q ->> r -> p ->> r
assertImpliesTrans p_imp_q q_imp_r = \st, p_st =>
  q_imp_r st (p_imp_q st p_st)

infix 8 <<->>

(<<->>) : (p, q : Assertion) -> Type
(<<->>) p q = (AssertImplies p q, AssertImplies q p)

assertEquivRefl : p <<->> p
assertEquivRefl = (assertImpliesRefl, assertImpliesRefl)

assertEquivTrans : p <<->> q -> q <<->> r -> p <<->> r
assertEquivTrans (p_imp_q, q_imp_p) (q_imp_r, r_imp_q) =
  (assertImpliesTrans p_imp_q q_imp_r, assertImpliesTrans r_imp_q q_imp_p)

AssignSub : (x : Id) -> (a : AExp) -> (p : Assertion) -> Assertion
AssignSub x a p = \st => p (t_update x (aeval st a) st)

BAssn : (b : BExp) -> Assertion
BAssn b = \st => beval st b = True

bexp_eval_true : beval st b = True -> BAssn b st
bexp_eval_true prf = prf

bexp_eval_false : beval st b = False -> Not (BAssn b st)
bexp_eval_false bfalse btrue = absurd $ trans (sym bfalse) btrue

bassn_eval_false : Not (BAssn b st) -> beval st b = False
bassn_eval_false contra = fst not_true_iff_false contra


module UnderscoredIntegerLiterals

-- grouping decimal numbers by thousands
amount : Integer
amount = 10_000_000_000

equalAmounts : Bool
equalAmounts = amount == 10000000000

-- grouping hexadecimal addresses by words
addr : Int
addr = 0xCAFE_F00D

equalAddrs : Bool
equalAddrs = addr == 0xCAFEF00D

-- grouping bits into nibbles in a binary literal
equalFlags : Bool
equalFlags = 0b0011_1111_0100_1110 == 0b0011111101001110

-- grouping octals
equalOctals : Bool
equalOctals = 0o455_777 == 0o455777


module VectMissing

import Data.Fin
import Data.Vect

export
shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a
shrink (x :: ys) Here = ys
shrink (y :: []) (There p) = absurd p
shrink (y :: (x :: xs)) (There p) = y :: shrink (x :: xs) p


--
-- A module about shapes
--

||| a Shape
data Shape =
  ||| Triangle with base and heigth
  Triangle Double Double |
  ||| Circle with radius
  Circle Double

||| computes the area of a shape
area : Shape -> Double
area (Triangle x y) = 0.5 * x * y
area (Circle x) = pi * x * x
                  -- pi is known by idris

{-
commented out code
-}


import Stuff

foo : Int -> Maybe Int
foo 0 = Nothing
foo x = Just (prim__mul_Int x 2)

testLet : Int -> Int
testLet x = let y = prim__mul_Int x 2
                Just ans = foo y
                     | Nothing => 99
                z = prim__mul_Int ans 2
              in z


init : a -> c -> List b -> List (a, b, c)
init a c = map (uncurry (,)) . map (a,) . map (,c)

unzip : List (a, b) -> (List a, List b)
unzip [] = ([], [])
unzip ((a, b) :: abs)
  = let (as, bs) = unzip abs in
    (a :: as, b :: bs)

unzip4 : List (a, b, c, d) -> (List a, List b, List c, List d)
unzip4 [] = ([], [], [], [])
unzip4 (abcd :: abcds)
  = let (a, b, c, d) = abcd
        (as, bs, cs, ds) = unzip4 abcds
    in (a :: as, b :: bs, c :: cs, d :: ds)


import Data.List
import Data.List.Views

{-
Note:
The | says that, in the recursive calls,
you want to bypass constructing the view,
because you already have appropriate views for lefts and rights.
-}

mergeSort : Ord a => List a -> List a
mergeSort input with (splitRec input)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | (SplitRecOne x) = [x]
  mergeSort (lefts ++ rights) | (SplitRecPair lefts rights lrec rrec)
            = merge (mergeSort lefts | lrec) (mergeSort rights | rrec)


module Learn.Elab

import Language.Reflection.Utils

mkId : Elab ()
mkId = do x <- gensym "x"
          attack
          intro x
          fill (Var x)
          solve
          solve

%language ElabReflection

idNat : Nat -> Nat
idNat = %runElab mkId

idNat2 : Nat -> Nat
idNat2 = %runElab (do intro `{{x}}
                      fill (Var `{{x}})
                      solve)

idNat3 : Nat -> Nat
idNat3 = ?myhole

--total
quicksort : List Nat -> List Nat
quicksort [] = []
quicksort (x::xs) =
  quicksort (filter (< x) xs) ++ x :: quicksort (filter (>= x) xs)

---------- Proofs ----------

Learn.Elab.myhole = %runElab (do x <- gensym "x"
                                 attack
                                 intro x
                                 fill (Var x)
                                 solve
                                 solve)

data QSAcc : List Nat -> Type where
  QSAccCase0 : QSAcc []
  QSAccCase1 : QSAcc (filter (< x) xs) ->
               QSAcc (filter (>= x) xs) ->
               QSAcc (x :: xs)

qs' : (xs : List Nat) -> QSAcc xs -> List Nat
qs' [] QSAccCase0 = []
qs' (x :: xs) (QSAccCase1 l r) =
  qs' (filter (< x) xs) l ++
  x :: qs' (filter (>= x) xs) r

{- bc : (inFun, outFun, accPred : TTName) -> Elab ()
bc inFun outFun accPred = do
  (inFun', Ref, inTy) <- lookupTyExact inFun
     | _ => fail [TextPart "Not a function"]
  (_, args, res) <- lookupArgsExact inFun'
  declareDatatype $ Declare accPred args `(Type)
  let accArg = MkFunArg `{{acc}}
                (mkApp (Var accPred)
                   (map (Var . name) args))
                Explicit
                NotErased
  declareType $
    Declare outFun (args ++ [accArg]) res
  DefineFun _ oldClauses <- lookupFunDefnExact inFun'
  (newClauses, ctors) <-
    unzip <$> ?processClauses Z oldClauses
  defineDatatype $ DefineDatatype accPred ctors
  defineFunction $ DefineFun outFun newClauses

--%runElab (bc `{quicksort} `{{qs'}} `{{QSAcc}})
-}

-- foo : Nat -> Nat
-- foo k = ?foo_rhs

-- getAllNames : TT -> List TTName
-- getAllNames (P Bound (UN x) tm) = ?getAllNames_rhs_1
-- getAllNames (P Bound (NS n xs) tm) = ?getAllNames_rhs_13
-- getAllNames (P Bound (MN x y) tm) = ?getAllNames_rhs_14
-- getAllNames (P Bound (SN sn) tm) = ?getAllNames_rhs_15
-- getAllNames (P Ref n tm) = ?getAllNames_rhs_10
-- getAllNames (P (DCon x y) n tm) = ?getAllNames_rhs_11
-- getAllNames (P (TCon x y) n tm) = ?getAllNames_rhs_12
-- getAllNames (V x) = ?getAllNames_rhs_2
-- getAllNames (Bind n b tm) = ?getAllNames_rhs_3
-- getAllNames (App tm tm') = ?getAllNames_rhs_4
-- getAllNames (TConst c) = ?getAllNames_rhs_5
-- getAllNames Erased = ?getAllNames_rhs_6
-- getAllNames (TType uexp) = ?getAllNames_rhs_7
-- getAllNames (UType x) = ?getAllNames_rhs_8

data Foo = Fee | Food


module parser

import lexer
import tipos

%access public export

mutual

--------------------------------- Parser de Expressões Aritmeticas ---------------------------------
  num : List Token -> (Maybe AExp, List Token)
  num ((TokenInt n)::l) = (Just (N n), l)
  num ((TokenVarId id)::xs) = let (exp, r) = parseId ((TokenVarId id)::xs) in case exp of
    Nothing => (Nothing, r)
    Just k => (Just (IdA k), xs)
  num l = (Nothing, l)

  factor : List Token -> (Maybe AExp, List Token)
  factor = orParser num parenExp

  parenExp : List Token -> (Maybe AExp, List Token)
  parenExp ((TokenLParen)::xs) = let (e,r) = arithExp xs in parenExpAux e r where
    parenExpAux : Maybe AExp -> List Token -> (Maybe AExp, List Token)
    parenExpAux Nothing r = (Nothing, (TokenLParen::r))
    parenExpAux (Just e) (TokenRParen::xs) = ((Just e),xs)
    parenExpAux (Just e) l = (Nothing,(TokenLParen::xs))
  parenExp l = (Nothing, l)

  mul : List Token -> (Maybe AExp, List Token)
  mul l = let (exp, r) = factor l in mulAux exp r where
    mulAux : Maybe AExp -> List Token -> (Maybe AExp, List Token)
    mulAux Nothing r = (Nothing, r)
    mulAux (Just e) ((TokenTimes)::xs) = let (exp', r2) = factor xs in case exp' of
      Nothing => (Just e, (TokenTimes::xs))
      Just k => mulAux (Just (Mul e k)) r2
    mulAux (Just e) ((TokenDiv)::xs) = let (exp', r2) = factor xs in case exp' of
      Nothing => (Just e, (TokenDiv::xs))
      Just k => mulAux (Just (Div e k)) r2
    mulAux (Just e) l = ((Just e),l)

  sum : List Token -> (Maybe AExp, List Token)
  sum l = let (exp, r) = mul l in sumAux exp r where
    sumAux : Maybe AExp -> List Token -> (Maybe AExp, List Token)
    sumAux Nothing r = (Nothing, r)
    sumAux (Just e) ((TokenPlus)::xs) = let (exp', r2) = mul xs in case exp' of
      Nothing => (Just e, (TokenPlus::xs))
      Just k => sumAux (Just (Sum e k)) r2
    sumAux (Just e) ((TokenMinus)::xs) = let (exp', r2) = mul xs in case exp' of
      Nothing => (Just e, (TokenMinus::xs))
      Just k => sumAux (Just (Sub e k)) r2
    sumAux (Just e) l = ((Just e),l)

  arithExp : List Token -> (Maybe AExp, List Token)
  arithExp = sum

--------------------------------- Parser de Expressões Booleanas ---------------------------------
  bool : List Token -> (Maybe BExp, List Token)
  bool (TokenTrue::xs) = (Just (Boo True), xs)
  bool (TokenFalse::xs) = (Just (Boo False), xs)
  bool l = (Nothing, l)

  idBExp : List Token -> (Maybe BExp, List Token)
  idBExp ((TokenVarId id)::xs) = let (exp, r) = parseId ((TokenVarId id)::xs) in idAux exp r where
    idAux : Maybe Id -> List Token -> (Maybe BExp, List Token)
    idAux (Just e) (TokenPlus::xs) = (Nothing, (TokenPlus::xs))
    idAux (Just e) (TokenMinus::xs) = (Nothing, (TokenMinus::xs))
    idAux (Just e) (TokenTimes::xs) = (Nothing, (TokenTimes::xs))
    idAux (Just e) (TokenDiv::xs) = (Nothing, (TokenDiv::xs))
    idAux (Just e) l = (Just (IdB e), l)

  factorBExp : List Token -> (Maybe BExp, List Token)
  factorBExp ((TokenVarId id)::xs) = idBExp ((TokenVarId id)::xs)
  factorBExp (TokenNot::xs) = let (exp, r) = conditExp xs in case exp of
    Nothing => (Nothing, (TokenNot::xs))
    Just k => (Just (Not k), r)
  factorBExp l = orParser bool parenBExp l

  parenBExp : List Token -> (Maybe BExp, List Token)
  parenBExp ((TokenLParen)::xs) = let (e,r) = boolExp xs in parenBExpAux e r where
    parenBExpAux : Maybe BExp -> List Token -> (Maybe BExp, List Token)
    parenBExpAux Nothing r = (Nothing, (TokenLParen::r))
    parenBExpAux (Just e) (TokenRParen::xs) = ((Just e),xs)
    parenBExpAux (Just e) l = (Nothing,(TokenLParen::xs))
  parenBExp l = (Nothing, l)

  conditExp : List Token -> (Maybe BExp, List Token)
  conditExp = orParser aux factorBExp

  aux : List Token -> (Maybe BExp, List Token)
  aux l = let (e,r) = arithExp l in conditExpAux e r where
    conditExpAux : Maybe AExp -> List Token -> (Maybe BExp, List Token)
    conditExpAux Nothing r = (Nothing, r)
    conditExpAux (Just e) ((TokenEqual)::xs) = let (exp', r2) = arithExp xs in case exp' of
      Nothing => (Nothing, (TokenEqual::xs))
      Just k => ((Just (Equal e k)), r2)
    conditExpAux (Just e) ((TokenMaior)::xs) = let (exp', r2) = arithExp xs in case exp' of
      Nothing => (Nothing, (TokenMaior::xs))
      Just k => ((Just (GT e k)), r2)
    conditExpAux (Just e) ((TokenMenor)::xs) = let (exp', r2) = arithExp xs in case exp' of
      Nothing => (Nothing, (TokenMenor::xs))
      Just k => ((Just (LT e k)), r2)
    conditExpAux (Just e) ((TokenMaiorIgual)::xs) = let (exp', r2) = arithExp xs in case exp' of
      Nothing => (Nothing, (TokenMaiorIgual::xs))
      Just k => ((Just (GE e k)), r2)
    conditExpAux (Just e) ((TokenMenorIgual)::xs) = let (exp', r2) = arithExp xs in case exp' of
      Nothing => (Nothing, (TokenMenorIgual::xs))
      Just k => ((Just (LE e k)), r2)
    conditExpAux (Just e) l' = (Nothing,l)

  logic : List Token -> (Maybe BExp, List Token)
  logic l = let (exp, r) = conditExp l in logicAux exp r where
    logicAux : Maybe BExp -> List Token -> (Maybe BExp, List Token)
    logicAux Nothing r = (Nothing, r)
    logicAux (Just e) ((TokenOr)::xs) = let (exp', r2) = conditExp xs in case exp' of
      Nothing => (Just e, (TokenOr::xs))
      Just k => logicAux (Just (OR e k)) r2
    logicAux (Just e) ((TokenAnd)::xs) = let (exp', r2) = conditExp xs in case exp' of
      Nothing => (Just e, (TokenAnd::xs))
      Just k => logicAux (Just (And e k)) r2
    logicAux (Just e) l = ((Just e),l)

  boolExp : List Token -> (Maybe BExp, List Token)
  boolExp = logic

--------------------------------- Ajustes para Exp ---------------------------------
  parseBExp : List Token -> (Maybe Exp, List Token)
  parseBExp l = let (exp, r) = logic l in case exp of
    Nothing => (Nothing, l)
    Just k => ((Just (BExpR k)), r)

  parseAExp : List Token -> (Maybe Exp, List Token)
  parseAExp l = let (exp, r) = arithExp l in case exp of
    Nothing => (Nothing, l)
    Just k => ((Just (AExpR k)), r)

  parseExp : List Token -> (Maybe Exp, List Token)
  parseExp (TokenCommercialE::l') = let (exp', r2) = parseId l' in case exp' of
    Nothing => (Nothing, l')
    Just k => (Just (DeRef k), r2)
  parseExp (TokenTimes::l') = let (exp', r2) = parseId l' in case exp' of
    Nothing => (Nothing, l')
    Just k => (Just(ValRef k), r2)
  parseExp l = orParser parseBExp parseAExp l

--------------------------------- Parser de Comandos ---------------------------------
  parseId : List Token -> (Maybe Id, List Token)
  parseId ((TokenVarId id)::xs) = (Just (ValID id), xs)
  parseId l = (Nothing, l)

  assign : List Token -> (Maybe Cmd, List Token)
  assign l = let (exp, r) = parseId l in assignAux exp r where
    assignAux : Maybe Id -> List Token -> (Maybe Cmd, List Token)
    assignAux Nothing r = (Nothing, r)
    assignAux (Just e) (TokenAssign::xs) = let (exp', r2) = parseExp xs in case exp' of
      Nothing => (Nothing, l)
      Just k => ((Just (Assign e k)), r2)
    assignAux (Just e) r = (Nothing, l)

  loop : List Token -> (Maybe Cmd, List Token)
  loop (TokenWhile::xs) = let (exp, r) = boolExp xs in loopAux exp r where
    loopAux : Maybe BExp -> List Token -> (Maybe Cmd, List Token)
    loopAux Nothing l = (Nothing, (TokenWhile::xs))
    loopAux (Just e) (TokenDo::xs) = let (exp', r2) = seq xs in case exp' of
      Nothing => (Nothing, (TokenDo::xs))
      Just k => (Just (Loop e k), r2)
    loopAux (Just e) l = (Nothing, l)
  loop l = (Nothing, l)

  partials : List Token -> (Maybe Cmd, List Token)
  partials (TokenElse::xs) = seq xs
  partials l = (Nothing, l)

  comandCall : List Token -> (Maybe Cmd, List Token)
  comandCall = orParser call bloc

  auxComand : List Token -> (Maybe Cmd, List Token)
  auxComand = orParser loop comandCall

  comandUnityAux : List Token -> (Maybe Cmd, List Token)
  comandUnityAux = orParser assign auxComand

  comandUnity : List Token -> (Maybe Cmd, List Token)
  comandUnity = orParser cond comandUnityAux

  cond : List Token -> (Maybe Cmd, List Token)
  cond (TokenIf::xs) = let (exp, r) = boolExp xs in condAux exp r where
    condAux : Maybe BExp -> List Token -> (Maybe Cmd, List Token)
    condAux Nothing l = (Nothing, (TokenIf::xs))
    condAux (Just e) (TokenThen::xs) = let (c1, r2) = seq xs in case c1 of
      Nothing => (Nothing, (TokenThen::xs))
      Just k => let (c2, r3) = partials r2 in case c2 of
        Nothing => (Just (Cond e k NOP), r3)
        Just p => (Just (Cond e k p), r3)
    condAux (Just e) l = (Nothing, l)
  cond l = (Nothing, l)

  seq : List Token -> (Maybe Cmd, List Token)
  seq l = let (exp, r) = comandUnity l in seqAux exp r where
    seqAux : Maybe Cmd -> List Token -> (Maybe Cmd, List Token)
    seqAux Nothing l' = (Nothing, l')
    seqAux (Just e) (TokenEnd::xs) = ((Just e), xs)
    seqAux (Just e) l' = let (c2, r2) = seq l' in case c2 of
      Nothing => ((Just e), l')
      Just k => (Just (CSeq e k), r2)

  comands : List Token -> (Maybe Cmd, List Token)
  comands = seq

  declaration : List Token -> (Maybe Dec, List Token)
  declaration (TokenCons::xs) = const (TokenCons::xs)
  declaration (TokenVar::xs) = let (exp, r) = parseId xs in declarationAux exp r where
    declarationAux : Maybe Id -> List Token -> (Maybe Dec, List Token)
    declarationAux Nothing l' = (Nothing, l')
    declarationAux (Just e) (TokenAssign::l') = let (exp', r2) = parseExp l' in case exp' of
      Nothing => (Nothing, l')
      Just k => (Just (Bind e (Ref k)), r2)
    declarationAux (Just e) l' = (Nothing, l')
  declaration l = (Nothing, l)

  const :List Token -> (Maybe Dec, List Token)
  const (TokenCons::xs) = let (exp, r) = parseId xs in constAux exp r where
    constAux : Maybe Id -> List Token -> (Maybe Dec, List Token)
    constAux Nothing l' = (Nothing, l')
    constAux (Just e) (TokenAssign::l') = let (exp', r2) = parseExp l' in case exp' of
      Nothing => (Nothing, l')
      Just k => (Just (Bind e k), r2)
    constAux (Just e) l' = (Nothing, l')
  const l = (Nothing, l)

  dec : List Token -> (Maybe Dec, List Token)
  dec = orParser seqDec function

  bloc : List Token -> (Maybe Cmd, List Token)
  bloc (TokenLet::xs) = let (dec, r) = dec xs in blocAux dec r where
    blocAux : Maybe Dec -> List Token -> (Maybe Cmd, List Token)
    blocAux Nothing l' = (Nothing, l')
    blocAux (Just c) (TokenIn::xs) = let (c1, r2) = comands xs in case c1 of
      Nothing => (Nothing, r2)
      Just k => (Just (Blk c k), r2)
    blocAux (Just e) l' = (Nothing, l')
  bloc l = (Nothing, l)

  seqDec : List Token -> (Maybe Dec, List Token)
  seqDec l = let (exp, r) = declaration l in seqDecAux exp r where
    seqDecAux : Maybe Dec -> List Token -> (Maybe Dec, List Token)
    seqDecAux Nothing l' = (Nothing, l')
    seqDecAux (Just e) l' = let (c2, r2) = seqDec l' in case c2 of
      Nothing => ((Just e), l')
      Just k => (Just (DSeq e k), r2)

  ctrlParser : List Token -> (Maybe Ctrl, List Token)
  ctrlParser l = let (exp, r) = bloc l in case exp of
    Nothing => (Nothing, l)
    Just k => ((Just (CtCmd k)), r)

--------------------------------- Parser de Comandos ---------------------------------
  formals : List Token -> (Maybe Formals, List Token)
  formals (TokenLParen::xs) = let (list, r) = listaParam xs in formalsAux list r where
    formalsAux : List Id -> List Token -> (Maybe Formals, List Token)
    formalsAux list (TokenRParen::xs) = (Just (Form list), xs)
    formalsAux list r2 = (Nothing, r2)
  formals l = (Nothing, l)

  listaParam : List Token -> (List Id, List Token)
  listaParam l = let (id, r) = parseId l in listaParamAux id r [] where
    listaParamAux : Maybe Id -> List Token -> List Id -> (List Id, List Token)
    listaParamAux Nothing r2 list = (list, r2)
    listaParamAux (Just k) r2 list = let (id', r3) = parseId r2 in listaParamAux id' r3 (k::list)

  abst : List Token -> (Maybe Abst, List Token)
  abst l =  let (f, r) = formals l in abstAux f r where
    abstAux : Maybe Formals -> List Token -> (Maybe Abst, List Token)
    abstAux Nothing r2 = (Nothing, r2)
    abstAux (Just f) (TokenIgual::xs) = let (cm, r3) = comands xs in case cm of
      Nothing => (Nothing, r3)
      Just c => (Just (Abstr f c), r3)
    abstAux (Just f) r2 = (Nothing, r2)

  function : List Token -> (Maybe Dec, List Token)
  function (TokenRec::TokenFn::xs)=  let (id, r) = parseId xs in case id of
    Nothing => (Nothing, xs)
    Just i => let (f, r2) = abst r in case f of
      Nothing => (Nothing, r2)
      Just abs => (Just (Rbnd i abs), r2)
  function (TokenFn::xs)=  let (id, r) = parseId xs in case id of
    Nothing => (Nothing, xs)
    Just i => let (f, r2) = abst r in case f of
      Nothing => (Nothing, r2)
      Just abs => (Just (BindF i abs), r2)
  function l = (Nothing, l)

  actuals : List Token -> (Maybe Actuals, List Token)
  actuals (TokenLParen::xs) = let (list, r) = listaExps xs in actualsAux list r where
    actualsAux : List Exp -> List Token -> (Maybe Actuals, List Token)
    actualsAux list (TokenRParen::xs) = (Just (Act list), xs)
    actualsAux list r2 = (Nothing, r2)
  actuals l = (Nothing, l)

  listaExps : List Token -> (List Exp, List Token)
  listaExps l = let (exp, r) = parseExp l in listaExpsAux exp r [] where
    listaExpsAux : Maybe Exp -> List Token -> List Exp -> (List Exp, List Token)
    listaExpsAux Nothing r2 list = (list, r2)
    listaExpsAux (Just k) r2 list = let (exp', r3) = parseExp r2 in listaExpsAux exp' r3 (k::list)

  call : List Token -> (Maybe Cmd, List Token)
  call l = let (id, r) = parseId l in case id of
    Nothing => (Nothing, r)
    Just i => let (act, r2) = actuals r in case act of
      Nothing => (Nothing, r2)
      Just k => (Just (Call i k), r2)

-- funçao para tentar parser de AExp e BExp
-- tenta aplicar o parser1 a lista
  orParser : (List Token -> (Maybe a, List Token)) -> (List Token -> (Maybe a, List Token)) -> (List Token -> (Maybe a, List Token))
  orParser parser1 parser2 list = let (exp,r) = parser1 list in orParserAux exp r where
-- orParserAux verifica se o parser1 falhou (Nothing) ou retornou com sucesso um (exp, resto da lista)
    orParserAux : Maybe a -> List Token -> (Maybe a, List Token)
    orParserAux Nothing l = parser2 l
    orParserAux (Just exp') l = (Just exp', l)


module Text.WebIDL.Types.Numbers

import Generics.Derive

%default total

%language ElabReflection

||| The default Eq for Nat runs in O(n), which is too slow
||| if we want to support large natlits in our tests.
export
[FastNatEq] Eq Nat where
  (==) = (==) `on` natToInteger

--------------------------------------------------------------------------------
--          IntLit
--------------------------------------------------------------------------------

||| An integer literal in hexadecimal, octal, or decimal representation.
||| The code generator will use the same representation when
||| generating code for constants and default values.
public export
data IntLit = Hex Nat | Oct Nat | I Integer

%runElab derive "IntLit" [Generic,Meta,Show]

export
Eq IntLit using FastNatEq where (==) = genEq

--------------------------------------------------------------------------------
--          Parsing Integers
--------------------------------------------------------------------------------

digitToInt : Char -> Integer
digitToInt c = cast $ if isDigit c
                         then ord c - ord '0'
                         else ord (toUpper c) - ord 'A' + 10

charsToPosInt : (base : Integer) -> List Char -> Maybe Integer
charsToPosInt base t = calc <$> traverse readDigit t
  where readDigit : Char -> Maybe Integer
        readDigit c = let d = digitToInt c
                       in if d >= 0 && d < base then Just d else Nothing

        calc : List Integer -> Integer
        calc = foldl (\a,e => a * base + e) 0

||| Tries to read an integer literal from a `String`.
export
readInt : String -> Maybe IntLit
readInt s = case fastUnpack s of
                 '0'::'x'::t => map (Hex . fromInteger) $ charsToPosInt 16 t
                 '0'::'X'::t => map (Hex . fromInteger) $ charsToPosInt 16 t
                 '0'::t      => map (Oct . fromInteger) $ charsToPosInt 8  t
                 '-'::t      => I . negate <$> charsToPosInt 10 t
                 t           => map I $ charsToPosInt 10 t

--------------------------------------------------------------------------------
--          Floating Point Literals
--------------------------------------------------------------------------------

||| The sign of a floating point literal.
public export
data Signum = Plus | Minus

%runElab derive "Signum" [Generic,Meta,Eq,Show]

||| A parsed floating point literal.
|||
||| A floating point literal is either one of three
||| special values (`NaN`, `Infinity`, or `-Infinity`)
||| or a decimal floating point number (`NoExp`: dot is
||| mandatory), or a float in scientific notation (`Exp`:
||| dot is optional).
|||
||| The main focus of this data type is one of
||| preserving information. Encoding a `FloatLit` should
||| yield (almost) exactly the same literal as the one
||| encountered during parsin with two minor exceptions:
||| a) The encoded literal will always use a lowercase 'e' as
||| the delimiter for the exponent and b) in case of a
||| positive exponent, there will not be a '+' in the
||| encoded literal.
public export
data FloatLit : Type where
  ||| Floating point number in scientific notation.
  |||
  ||| Example: `-12.10e10`
  Exp :  (signum    : Signum)
      -> (beforeDot : Nat)
      -> (afterDot  : Maybe Nat)
      -> (exp       : Integer)
      -> FloatLit

  ||| Floating point number without exponent.
  |||
  ||| Example: `-12.1002`
  NoExp :  (signum    : Signum)
        -> (beforeDot : Nat)
        -> (afterDot  : Nat)
        -> FloatLit

  ||| Corresponds to the WebIDL keyword `Infinity`
  Infinity         : FloatLit

  ||| Corresponds to the WebIDL keyword `-Infinity`
  NegativeInfinity : FloatLit

  ||| Corresponds to the WebIDL keyword `NaN`
  NaN              : FloatLit

%runElab derive "FloatLit" [Generic,Meta,Show]

export
Eq FloatLit using FastNatEq where (==) = genEq

--------------------------------------------------------------------------------
--          Parsing Floats
--------------------------------------------------------------------------------

charsToNat : List Char -> Maybe Nat
charsToNat = map fromInteger . charsToPosInt 10

beforeDot : List Char -> (Signum,Maybe Nat)
beforeDot ('-'::cs) = (Minus,charsToNat cs)
beforeDot cs        = (Plus, charsToNat cs)

exp : String -> Maybe String -> String -> Maybe FloatLit
exp bds ads es =
  let (s,bdNat) = beforeDot (fastUnpack bds)
   in do bd <- bdNat
         ad <- maybe (Just Nothing) (map Just . charsToNat . fastUnpack) ads
         e  <- afterExp (fastUnpack es)
         pure $ Exp s bd ad e

  where afterExp : List Char -> Maybe Integer
        afterExp ('-'::cs) = negate <$> charsToPosInt 10 cs
        afterExp ('+'::cs) = charsToPosInt 10 cs
        afterExp cs        = charsToPosInt 10 cs

noExp : String -> String -> Maybe FloatLit
noExp bds ads =
  let (s,bdNat) = beforeDot $ fastUnpack bds
   in do bd <- bdNat
         ad <- charsToNat $ fastUnpack ads
         pure $ NoExp s bd ad

||| Tries to read a floating point literal
||| from a `String`.
export
readFloat : String -> Maybe FloatLit
readFloat s =
  case split (('E' ==) . toUpper) s of
    -- with exponent, dot is optional
    h ::: [e] => case split ('.' ==) h of
      h2 ::: [t2] => exp h2 (Just t2) e
      h2 ::: []   => exp h2 Nothing e
      _  ::: _    => Nothing

    -- without exponent, dot is mandatory
    -- (otherwise it is an integer)
    h ::: [] => case split ('.' ==) h of
      h2 ::: [t2] => noExp h2 t2
      _  ::: _    => Nothing

    -- more than one E in string
    _ ::: _  => Nothing


module Main

import Prelude

-- https://stackoverflow.com/a/11554793/3574379

interface Twice f where
  twice : f -> f

Twice (a -> a) where
  twice f = f . f

interface Example a where
  transform : Int -> a

Example Int where
  transform n = n + 1

Example Char where
  transform _ = 'x'

-- run in REPL to see that it derives properly:

-- $ idris src/15_EqualityConstraint_Twice_class.idr
-- *src/15_EqualityConstraint_Twice_class> :t twice transform
-- twice transform : Int -> Int

-- Summary:
-- in idris you dont need equality constaint to derive type of such functions properly


module Main

import Data.Vect

data DataStore : Type where
     MkData : (size : Nat) ->
              (items : Vect size String) ->
              DataStore

data Command = Add String
               | Get Integer
               | Size
               | Quit

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

items : (store : DataStore) -> Vect (size store) String
items (MkData _ items') = items'

addToStore : DataStore -> String -> DataStore
addToStore (MkData _ items) item = MkData _ (add item items)
           where
            add : String -> Vect old String -> Vect (S old) String
            add item [] = [item]
            add item (x :: xs) = x :: add item xs

parseCommand : (cmd : String) -> (args : String) -> Maybe Command
parseCommand "add" str = Just (Add str)
parseCommand "get" val = case all isDigit (unpack val) of
                              False => Nothing
                              True => Just (Get (cast val))
parseCommand "size" _ = Just Size
parseCommand "quit" "" = Just Quit
parseCommand _ _ = Nothing

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

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

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store inp = case parse inp 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 => let (MkData size _) = store in Just (("Size = " ++ show size ++ "\n"), store)
                              Just Quit => Nothing

main : IO ()
main = replWith (MkData _ ["Moscow", "Kurgan", "Ekaterinburg"]) "Command: " processInput

Enter the sequantally strings and press Enter when input will be compleated.


%default partial

foo : (Nat, Nat) -> Nat
foo (Z, Z) = Z

bar : {a : _} -> a -> Nat
bar Z = Z
bar (S _) = S Z

cty : (a : Type) -> a -> Nat
cty Nat Z = Z
cty Nat (S _) = S Z
cty _ x = S (S Z)

badBar : a -> Nat
badBar Z = Z
badBar (S _) = S Z


module Main

data RLE : Vect n Char -> Type where
     REnd  : RLE []
     RChar : {xs : Vect k Char} ->
             (n : Nat) -> (c : Char) -> (rs : RLE xs) ->
             RLE (replicate (S n) c ++ xs)

------------

rle : (xs : Vect n Char) -> RLE xs
rle [] = REnd
rle (x :: xs) with (rle xs)
  rle (x :: []) | REnd = RChar 0 x REnd
  rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) with (decEq x c)
    rle (x :: (x :: (replicate n x ++ ys))) | (RChar n x rs) | (Yes refl)
        = RChar (S n) x rs
    rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) | (No f)
        = RChar 0 x (RChar n c rs)

compress : Vect n Char -> String
compress xs with (rle xs)
  compress [] | REnd = ""
  compress (c :: (replicate n c ++ xs1)) | (RChar n c rs)
       = show (the Integer (cast (S n))) ++
           strCons c (compress xs1)

compressString : String -> String
compressString xs = compress (fromList (unpack xs))

main : IO ()
main = putStrLn (compressString "foooobaaaarbaaaz")


module Main

data Expr = Var String
          | Val Int
          | Add Expr Expr

data Eval : Type -> Type where
   MkEval : (List (String, Int) -> Maybe a) -> Eval a

fetch : String -> Eval Int
fetch x = MkEval (\e => fetchVal e) where
    fetchVal : List (String, Int) -> Maybe Int
    fetchVal [] = Nothing
    fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs)

implementation Functor Eval where
    map f (MkEval g) = MkEval (\e => map f (g e))

implementation Applicative Eval where
    pure x = MkEval (\e => Just x)

    (<*>) (MkEval f) (MkEval g) = MkEval (\x => appAux (f x) (g x)) where
       appAux : Maybe (a -> b) -> Maybe a -> Maybe b
       appAux (Just fx) (Just gx) = Just (fx gx)
       appAux _         _         = Nothing

eval : Expr -> Eval Int
eval (Var x)   = fetch x
eval (Val x)   = [| x |]
eval (Add x y) = [| eval x + eval y |]

runEval : List (String, Int) -> Expr -> Maybe Int
runEval env e with (eval e) {
    | MkEval envFn = envFn env
}

main : IO ()
main = do printLn [| (\x => x *2) (Just 4) |]
          printLn [| plus (Just 4) (Just 5) |]
          printLn (runEval [("x",21), ("y", 20)] (Add (Val 1) (Add (Var "x") (Var "y"))))
          printLn (runEval [("x",21)] (Add (Val 1) (Add (Var "x") (Var "y"))))


> module SequentialDecisionProblems.applications.Main

> import Data.Vect
> -- import Data.Fin
> -- import Data.List
> -- import Data.List.Quantifiers
> import Data.So
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.TabBackwardsInduction
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.NonDeterministicDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.TabBackwardsInductionOptDefaults

> import BoundedNat.BoundedNat
> -- import FastSimpleProb.SimpleProb
> -- import FastSimpleProb.BasicOperations
> -- import FastSimpleProb.BasicProperties
> -- import FastSimpleProb.MonadicOperations
> -- import FastSimpleProb.MonadicProperties
> -- import FastSimpleProb.Measures
> -- import FastSimpleProb.MeasuresProperties
> -- import FastSimpleProb.Operations
> -- import Sigma.Sigma
> import Double.Predicates
> -- import Double.Postulates
> -- import Double.Operations
> -- import Double.Properties
> import NonNegDouble.NonNegDouble
> -- import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> -- import Finite.Predicates
> -- import Finite.Operations
> -- import Finite.Properties
> -- import Decidable.Predicates
> -- import Decidable.Properties
> -- import LocalEffect.Exception
> -- import LocalEffect.StdIO
> -- import Fin.Operations
> -- import List.Operations
> -- import Unit.Properties

> -- %default total
> %auto_implicits off

> -- %logging 5

* States

> data Tag = V | X | O

> Board : Type
> Board = Vect 9 Tag

> validBoard : Nat -> Board -> Bool

> data ValidBoard : Nat -> Type where
>   MkValidBoard : (t : Nat) -> (b : Board) -> validBoard t b = True -> ValidBoard t

> SequentialDecisionProblems.CoreTheory.State = ValidBoard

* Controls

> Move : Type
> Move = Maybe (LTB 9) -- Nothing is for the case the game is over before 5 rounds

> validMove : (t : Nat) -> ValidBoard t -> Move -> Bool

> data ValidMove : (t : Nat) -> ValidBoard t -> Type where
>   MkValidMove : (t : Nat) -> (b : ValidBoard t) -> (m : Move) -> validMove t b m = True -> ValidMove t b

> SequentialDecisionProblems.CoreTheory.Ctrl = ValidMove

* Transition function

> possible : (t : Nat) -> (b : ValidBoard t) -> (m : ValidMove t b) -> List (ValidBoard (S t))

> SequentialDecisionProblems.CoreTheory.nexts t x y = possible t x y

* |Val| and |LTE|:

> SequentialDecisionProblems.CoreTheory.Val =
>   NonNegDouble.NonNegDouble

> SequentialDecisionProblems.CoreTheory.plus =
>   NonNegDouble.Operations.plus

> SequentialDecisionProblems.CoreTheory.zero =
>   fromInteger 0

> SequentialDecisionProblems.CoreTheory.LTE =
>   NonNegDouble.Predicates.LTE

> SequentialDecisionProblems.FullTheory.reflexiveLTE =
>   NonNegDouble.LTEProperties.reflexiveLTE

> SequentialDecisionProblems.FullTheory.transitiveLTE =
>   NonNegDouble.LTEProperties.transitiveLTE

> SequentialDecisionProblems.FullTheory.monotonePlusLTE =
>   NonNegDouble.LTEProperties.monotonePlusLTE

> SequentialDecisionProblems.CoreTheoryOptDefaults.totalPreorderLTE =
>   NonNegDouble.LTEProperties.totalPreorderLTE

* Reward function

> won  : (t : Nat) -> (b : ValidBoard t) -> Bool
> lost : (t : Nat) -> (b : ValidBoard t) -> Bool

> SequentialDecisionProblems.CoreTheory.reward t x y x' =
>   if won (S t) x'
>   then cast 2.0
>   else if lost (S t) x'
>        then cast 0.0
>        else cast 1.0

> {-

* Completing the problem specification

To be able to apply the verified, generic backwards induction algorithm
of |CoreTheory| to compute optimal policies for our problem, we have to
explain how the decision maker accounts for uncertainties on rewards
induced by uncertainties in the transition function. We first assume
that the decision maker measures uncertain rewards by their expected
value:

> SequentialDecisionProblems.CoreTheory.meas = expectedValue -- worst -- expectedValue
> SequentialDecisionProblems.FullTheory.measMon = monotoneExpectedValue -- monotoneWorst -- monotoneExpectedValue

Further on, we have to implement the notions of viability and
reachability. We start by positing that all states are viable for any
number of steps:

> -- Viable : (n : Nat) -> State t -> Type
> SequentialDecisionProblems.CoreTheory.Viable n x = Unit

From this definition, it trivially follows that all elements of an
arbitrary list of states are viable for an arbitrary number of steps:

> viableLemma : {t, n : Nat} -> (xs : List (State t)) -> All (Viable n) xs
> viableLemma  Nil      = Nil
> viableLemma {t} {n} (x :: xs) = () :: (viableLemma {t} {n} xs)

This fact and the (less trivial) result that simple probability
distributions are never empty, see |nonEmptyLemma| in
|MonadicProperties| in |SimpleProb|, allows us to show that the above
definition of |Viable| fulfills |viableSpec1|:

> -- viableSpec1 : (x : State t) -> Viable (S n) x -> GoodCtrl t x
> SequentialDecisionProblems.CoreTheory.viableSpec1 {t} {n} s v =
>   MkSigma High (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t s High)
>     ne = nonEmptyLemma (nexts t s High)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t s High)
>     av = viableLemma {t = S t} (support (nexts t s High))

> SequentialDecisionProblems.Utils.finiteViable n x = finiteUnit

> SequentialDecisionProblems.Utils.decidableViable n x = decidableUnit

For reachability, we proceed in a similar way. We say that all states
are reachable

> -- Reachable : State t' -> Type
> SequentialDecisionProblems.CoreTheory.Reachable x' = Unit

which immediately implies |reachableSpec1|:

> -- reachableSpec1 : (x : State t) -> Reachable {t' = t} x -> (y : Ctrl t x) -> All (Reachable {t' = S t}) (nexts t x y)
> SequentialDecisionProblems.CoreTheory.reachableSpec1 {t} x r y = all (nexts t x y) where
>   all : (sp : SimpleProb  (State (S t))) -> SequentialDecisionProblems.CoreTheory.All (Reachable {t' = S t}) sp
>   all sp = all' (support sp) where
>     all' : (xs : List (State (S t))) -> Data.List.Quantifiers.All (Reachable {t' = S t}) xs
>     all' Nil = Nil
>     all' (x :: xs) = () :: (all' xs)

and decidability of |Reachable|:

> SequentialDecisionProblems.TabBackwardsInduction.decidableReachable x = decidableUnit

Finally, we have to show that controls are finite

> -- finiteCtrl : {t : Nat} -> (x : State t) -> Finite (Ctrl t x)
> SequentialDecisionProblems.Utils.finiteCtrl _ = finiteLowHigh

and, in order to use the fast, tail-recursive tabulated version of
backwards induction, that states are finite:

> SequentialDecisionProblems.TabBackwardsInduction.finiteState t =
>   finiteTuple4 finiteFin finiteLowHigh finiteAvailableUnavailable finiteGoodBad

* Optimal policies, optimal decisions, ...

We can now apply the results of our |CoreTheory| and of the |FullTheory|
to compute verified optimal policies, possible state-control sequences,
etc. To this end, we need to be able to show the outcome of the decision
process. This means implemeting functions to print states and controls:

> -- showState : {t : Nat} -> State t -> String
> SequentialDecisionProblems.Utils.showState {t} (e, High, Unavailable, Good) =
>   "(" ++ show (finToNat e) ++ ",H,U,G)"
> SequentialDecisionProblems.Utils.showState {t} (e, High, Unavailable,  Bad) =
>   "(" ++ show (finToNat e) ++ ",H,U,B)"
> SequentialDecisionProblems.Utils.showState {t} (e, High,   Available, Good) =
>   "(" ++ show (finToNat e) ++ ",H,A,G)"
> SequentialDecisionProblems.Utils.showState {t} (e, High,   Available,  Bad) =
>   "(" ++ show (finToNat e) ++ ",H,A,B)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low, Unavailable, Good) =
>   "(" ++ show (finToNat e) ++ ",L,U,G)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low, Unavailable,  Bad) =
>   "(" ++ show (finToNat e) ++ ",L,U,B)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low,   Available, Good) =
>   "(" ++ show (finToNat e) ++ ",L,A,G)"
> SequentialDecisionProblems.Utils.showState {t} (e,  Low,   Available,  Bad) =
>   "(" ++ show (finToNat e) ++ ",L,A,B)"

> -- showControl : {t : Nat} -> {x : State t} -> Ctrl t x -> String
> SequentialDecisionProblems.Utils.showCtrl {t} {x}  Low = "L"
> SequentialDecisionProblems.Utils.showCtrl {t} {x} High = "H"

> -- ad-hoc trajectories computation
> adHocPossibleStateCtrlSeqs : {t, n : Nat} ->
>                              (ps : PolicySeq t n) ->
>                              (x : State t) ->
>                              SimpleProb (StateCtrlSeq t n)
> adHocPossibleStateCtrlSeqs {t} {n = Z}         Nil  x =
>   FastSimpleProb.MonadicOperations.ret (Nil x)
> adHocPossibleStateCtrlSeqs {t} {n = S m} (p :: ps') x =
> {-
>   FastSimpleProb.MonadicOperations.fmap ((MkSigma x y) ::) (FastSimpleProb.MonadicOperations.naivebind mx' f) where
>     y   :  Ctrl t x
>     y   =  ctrl (p x () ())
>     mx' :  SimpleProb (State (S t))
>     mx' =  nexts t x y
>     f   :  State (S t) -> M (StateCtrlSeq (S t) m)
>     f   =  adHocPossibleStateCtrlSeqs {n = m} ps'
> ---}
> --{-
>   let y   = ctrl (p x () ()) in
>   let mx' =  nexts t x y in
>   let f   =  adHocPossibleStateCtrlSeqs {n = m} ps' in
>   FastSimpleProb.MonadicOperations.fmap ((MkSigma x y) ::) (FastSimpleProb.MonadicOperations.naivebind mx' f)
> ---}

> constHigh : (t : Nat) -> (n : Nat) -> PolicySeq t n
> constHigh t  Z    = Nil
> constHigh t (S n) = p :: (constHigh (S t) n) where
>   p : Policy t (S n)
>   p x r v = MkSigma High (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t x High)
>     ne = nonEmptyLemma (nexts t x High)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t x High)
>     av = viableLemma {t = S t} (support (nexts t x High))

> ||| Constant low policy sequences
> constLow : (t : Nat) -> (n : Nat) -> PolicySeq t n
> constLow t  Z    = Nil
> constLow t (S n) = p :: (constLow (S t) n) where
>   p : Policy t (S n)
>   p x r v = MkSigma Low (ne, av) where
>     ne : SequentialDecisionProblems.CoreTheory.NotEmpty (nexts t x Low)
>     ne = nonEmptyLemma (nexts t x Low)
>     av : SequentialDecisionProblems.CoreTheory.All (Viable {t = S t} n) (nexts t x Low)
>     av = viableLemma {t = S t} (support (nexts t x Low))

> computation : { [STDIO] } Eff ()
> computation =
>   do putStr ("enter number of steps:\n")
>      nSteps <- getNat
>      putStrLn "nSteps (number of decision steps):"
>      putStrLn ("  " ++ show nSteps)
>
>      putStrLn "crE (crit. cumulated emissions threshold):"
>      putStrLn ("  " ++ show crE)
>      putStrLn "crN (crit. number of decision steps):"
>      putStrLn ("  " ++ show crN)
>
>      putStrLn "pS1 (prob. of staying in a good world, cumulated emissions below crE):"
>      putStrLn ("  " ++ show pS1)
>      putStrLn "pS2 (prob. of staying in a good world, cumulated emissions above crE):"
>      putStrLn ("  " ++ show pS2)
>
>      putStrLn "pA1 (prob. of eff. tech. becoming available, number of steps below crN):"
>      putStrLn ("  " ++ show pA1)
>      putStrLn "pA2 (prob. of eff. tech. becoming available, number of steps above crN):"
>      putStrLn ("  " ++ show pA2)
>
>      putStrLn "pLL (prob. of low emission policies, emissions low, low selected):"
>      putStrLn ("  " ++ show pLL)
>      putStrLn "pLH (prob. of low emission policies, emissions high, low selected):"
>      putStrLn ("  " ++ show pLH)
>      putStrLn "pHL (prob. of high emission policies, emissions low, high selected):"
>      putStrLn ("  " ++ show pHL)
>      putStrLn "pHH (prob. of high emission policies, emissions high, high selected):"
>      putStrLn ("  " ++ show pHH)
>
>      putStrLn "badOverGood (step benefits ratio: bad over good world):"
>      putStrLn ("  " ++ show badOverGood)
>      putStrLn "lowOverGoodUnavailable (benefits ratio: low emissions over step, good world, eff. tech. unavailable):"
>      putStrLn ("  " ++ show lowOverGoodUnavailable)
>      putStrLn "lowOverGoodAvailable (benefits ratio: low emissions over step, good world, eff. tech. available):"
>      putStrLn ("  " ++ show lowOverGoodAvailable)
>      putStrLn "highOverGood (benefits ratio: High emissions over step, good world):"
>      putStrLn ("  " ++ show highOverGood)
>
>      putStrLn "computing constHigh policies ..."
>      constHigh_ps <- pure (constHigh Z nSteps)
>
>      putStrLn "computing constHigh state-control sequences ..."
>      constHigh_mxys <- pure (adHocPossibleStateCtrlSeqs constHigh_ps (FZ, High, Unavailable, Good))
>      putStrLn "pairing constHigh state-control sequences with their values ..."
>      constHigh_mxysv <- pure (possibleStateCtrlSeqsRewards' constHigh_mxys)
>      -- putStrLn "constHigh state-control sequences and their values:"
>      -- putStrLn (showlong constHigh_mxysv)
>
>      putStrLn "computing (naively) the number of constHigh state-control sequences ..."
>      constHigh_n <- pure (length (toList constHigh_mxysv))
>      putStrLn "number of constHigh state-control sequences:"
>      putStrLn ("  " ++ show constHigh_n)
>
>      putStrLn "computing (naively) the most probable constHigh state-control sequence ..."
>      constHigh_xysv <- pure (naiveMostProbableProb constHigh_mxysv)
>      putStrLn "most probable constHigh state-control sequence and its probability:"
>      putStrLn ("  " ++ show constHigh_xysv)
>
>      putStrLn "sorting (naively) the constHigh state-control sequence ..."
>      constHigh_xysvs <- pure (naiveSortToList constHigh_mxysv)
>      putStrLn "most probable constHigh state-control sequences (first 3) and their probabilities:"
>      putStrLn (showlong (take 3 constHigh_xysvs))
>
>      putStrLn "measure of constHigh rewards:"
>      putStrLn ("  " ++ show (meas (SequentialDecisionProblems.CoreTheory.fmap snd constHigh_mxysv)))
>
>      putStrLn "computing constLow policies ..."
>      constLow_ps <- pure (constLow Z nSteps)
>
>      putStrLn "computing constLow state-control sequences ..."
>      constLow_mxys <- pure (adHocPossibleStateCtrlSeqs constLow_ps (FZ, High, Unavailable, Good))
>      putStrLn "pairing constLow state-control sequences with their values ..."
>      constLow_mxysv <- pure (possibleStateCtrlSeqsRewards' constLow_mxys)
>
>      putStrLn "computing (naively) the number of constLow state-control sequences ..."
>      constLow_n <- pure (length (toList constLow_mxysv))
>      putStrLn "number of constLow state-control sequences:"
>      putStrLn ("  " ++ show constLow_n)
>
>      putStrLn "computing (naively) the most probable constLow state-control sequence ..."
>      constLow_xysv <- pure (naiveMostProbableProb constLow_mxysv)
>      putStrLn "most probable constLow state-control sequence and its probability:"
>      putStrLn ("  " ++ show constLow_xysv)
>
>      putStrLn "sorting (naively) the constLow state-control sequence ..."
>      constLow_xysvs <- pure (naiveSortToList constLow_mxysv)
>      putStrLn "most probable constLow state-control sequences (first 3) and their probabilities:"
>      putStrLn (showlong (take 3 constLow_xysvs))
>
>      putStrLn "measure of constLow rewards:"
>      putStrLn ("  " ++ show (meas (SequentialDecisionProblems.CoreTheory.fmap snd constLow_mxysv)))
>
>      putStrLn "computing optimal policies ..."
>      ps <- pure (tabTailRecursiveBackwardsInduction Z nSteps)
>
>      putStrLn "computing possible state-control sequences ..."
>      mxys <- pure (adHocPossibleStateCtrlSeqs ps (FZ, High, Unavailable, Good))
>      putStrLn "pairing possible state-control sequences with their values ..."
>      mxysv <- pure (possibleStateCtrlSeqsRewards' mxys)
>      -- putStrLn "possible state-control sequences and their values:"
>      -- putStrLn (showlong mxysv)
>
>      putStrLn "computing (naively) the number of possible state-control sequences ..."
>      n <- pure (length (toList mxysv))
>      putStrLn "number of possible state-control sequences:"
>      putStrLn ("  " ++ show n)
>
>      putStrLn "computing (naively) the most probable state-control sequence ..."
>      xysv <- pure (naiveMostProbableProb mxysv)
>      putStrLn "most probable state-control sequence and its probability:"
>      putStrLn ("  " ++ show xysv)
>
>      putStrLn "sorting (naively) the possible state-control sequence ..."
>      xysvs <- pure (naiveSortToList mxysv)
>      putStrLn "most probable state-control sequences (first 3) and their probabilities:"
>      putStrLn (showlong (take 3 xysvs))
>
>      putStrLn "measure of possible rewards:"
>      putStrLn ("  " ++ show (meas (SequentialDecisionProblems.CoreTheory.fmap snd mxysv)))

>      putStrLn "done!"

> main : IO ()
> main = run computation

> ---}

-- Local Variables:
-- idris-packages: ("effects")
-- End:


||| Drawing a Sierpinski triangle
||| Ported from https://www.linuxjournal.com/content/getting-started-ncurses

module Sierpinski

import Data.Fin
import Data.Nat
import Data.Vect
import Data.String
import NCurses
import System.Random

%default total

main : IO ()
main = runNCurses $ NCurses.do
  -- Initialise curses
  cBreak
  noEcho
  clear
  setCursorVisibility CInvisible

  -- Initialise triangle
  size <- getSize
  let maxlines = pred size.height
  let maxcols = pred size.width

  let p0 = MkPosition { row = 0, col = 0 }
  let p1 = MkPosition { row = maxlines, col = half maxcols }
  let p2 = MkPosition { row = 0, col = maxcols }
  let ps : Vect 3 ? = [p0,p1,p2]
  for_ @{NCURSES} Fin.range $ \ k => do
    let char = assert_total (show k `strIndex` 0)
    mvAddCh (index k ps) char

  -- Initialise position with random values
  let p = MkPosition { row = !(lift $ randNat maxlines)
                     , col = !(lift $ randNat maxcols) }
  -- Iterate the triangle
  loop ps 200000 p
  -- Done
  mvPrint (MkRow maxlines) "Press any key to quit"
  refresh
  ignore $ getCh

  where

    half : Nat -> Nat
    half n = (n `divNatNZ` 2) %search

    -- The bound better be smaller than MAX_INT32
    randNat : Nat -> IO Nat
    randNat bnd = do let i : Int32 = !randomIO
                     pure $ cast (abs i `mod` cast bnd)

    randIndex : (n : Nat) -> {auto 0 _ : NonZero n} -> IO (Fin n)
    randIndex (S n) = do k <- randNat (S n)
                         pure (restrict n $ cast k)

    loop : Vect 3 Position -> Nat -> Position ->
           NCurses Config.init Config.init ()
    loop ps Z     pi = pure ()
    loop ps (S n) pi = do
      k <- lift $ randIndex 3
      let pk = index k ps
      let pi' = { row $= \ xi => half (xi + pk.row)
                , col $= \ yi => half (yi + pk.col)
                } pi
      mvAddCh pi' '*'
      refresh
      loop ps n pi'


module Data.Fun

import public Data.Vect

%default total

||| Build an n-ary function type from a Vect of Types and a result type
public export
Fun : Vect n Type -> Type -> Type
Fun [] r = r
Fun (t::ts) r = t -> Fun ts r

public export
chain : {ts : Vect n Type} -> Fun [r] r' -> Fun ts r -> Fun ts r'
chain {ts = []} g r  = g r
chain {ts = (_::_)} g f = \ x => chain g (f x)

public export
[Nary] {ts : Vect n Type} -> Functor (Fun ts) where
  map = chain

||| Returns the co-domain of a n-ary function.
public export
target : {ts : Vect n Type} -> {r: Type} -> Fun ts r -> Type
target {r} _ = r


module Lexer

import Lightyear
import Lightyear.Char
import Lightyear.Strings

public export
data Lexeme
  = Numeral Integer
  | Plus
  | Minus
  | Times
  | Divide
  | LParen
  | RParen

-- XXX: deriving Eq?
export
implementation Eq Lexeme where
  (Numeral n1) == (Numeral n2) = n1 == n2
  Plus == Plus = True
  Minus == Minus = True
  Times == Times = True
  Divide == Divide = True
  LParen == LParen = True
  RParen == RParen = True
  _ == _ = False

-- XXX: deriving Show?
export
implementation Show Lexeme where
  show (Numeral n) = "(Numeral " ++ show n ++ ")"
  show Plus = "Plus"
  show Minus = "Minus"
  show Times = "Times"
  show Divide = "Divide"
  show LParen = "LParen"
  show RParen = "RParen"

-- XXX: Data.Fin finToInteger?
getInteger : List (Fin 10) -> Integer
getInteger = foldl (\a => \b => 10 * a + cast b) 0

numeral : Parser Lexeme
numeral = do
  digits <- some digit
  pure $ Numeral (getInteger digits)

tok : Parser Lexeme
tok = numeral
  <|> ((char '+') *> pure Plus)
  <|> ((char '-') *> pure Minus)
  <|> ((char '*') *> pure Times)
  <|> ((char '/') *> pure Divide)
  <|> ((char '(') *> pure LParen)
  <|> ((char ')') *> pure RParen)

export
lexer : Parser (List Lexeme)
lexer = spaces *> (many (tok <* spaces))


import Data.Either
import Data.List
import Data.List1
import Data.Maybe
import Data.String

import System.File

data BingoNum = M Nat | U Nat

Show BingoNum where
  show (M k) = "m " ++ show k
  show (U k) = "u " ++ show k

Card : Type
Card = List (List BingoNum)

parseLines : (String -> Maybe a) -> String -> List a
parseLines f s = catMaybes $ f <$> lines s

getNumbers : List String -> Maybe (List Nat, List String)
getNumbers [] = Nothing
getNumbers (x :: xs) = Just (catMaybes $ parsePositive <$> (forget $ split (== ',') x),  xs)

parseCard : List String -> Card
parseCard l = (\s => U <$> (catMaybes $ parsePositive <$> (forget $ split (== ' ') s))) <$> l

parseCards : List String -> List Card
parseCards [] = []
parseCards (_ :: xs) = parseCard (take 5 xs) :: parseCards (drop 5 xs)

isMarked : BingoNum -> Bool
isMarked (M _) = True
isMarked (U _) = False

winRow : Card -> Bool
winRow [] = False
winRow (x :: xs) = all isMarked x || winRow xs

winColumn : Card -> Bool
winColumn c = any id $ foldl (\a => \bs => (\(b1, b2) => b1 && b2) <$> zip a (isMarked <$> bs)) (replicate 5 True) c

wins : Card -> Bool
wins c = winRow c || winColumn c

drawNumber : Nat -> Card -> Card
drawNumber n [] = []
drawNumber n (x :: xs) = ((\d => case d of
                                      M m => M m
                                      U u => if u == n
                                                then M u
                                                else U u) <$> x) :: drawNumber n xs

drawNumbers : List Nat -> List Card -> Maybe (Card, Nat)
drawNumbers [] cs = Nothing
drawNumbers (x :: xs) [] = Nothing
drawNumbers (x :: xs) (c :: []) = let nc = drawNumber x c in
                                      if wins nc
                                         then Just (nc, x)
                                         else drawNumbers xs (nc :: [])
drawNumbers (x :: xs) cs = let ncs = drawNumber x <$> cs
                               losing = filter (not . wins) ncs in
                               drawNumbers xs losing

scoreOf : Card -> Nat
scoreOf [] = 0
scoreOf (x :: xs) = (foldl (\a => \b => case b of
                                             M n => a
                                             U n => n + a) 0 x) + scoreOf xs

run : String -> IO ()
run s = do let lines = lines s
           Just (ns, lines) <- pure $ getNumbers lines
             | Nothing => putStrLn $ "err"
           let cards = parseCards lines
           Just (win, n) <- pure $ drawNumbers ns cards
             | Nothing => putStrLn $ "no win"
           let score = n * scoreOf win
           putStrLn $ show $ score

main : IO ()
main = do Right s <- readFile "input.txt"
            | Left err => putStrLn $ show err
          run s


module Data.MergeList

import Decidable.Order
import Data.OrderedVect

%default total

export
data MergeList : (rank : Nat) -> (cnt : Nat) -> (constraint : Ordered ty to) -> Type where
  Nil : MergeList _ Z _
  Skip : (next : MergeList (n + n) cnt constraint)
      -> MergeList n cnt constraint
  (::) : OrderedVect n constraint
      -> .{cnt : Nat}
      -> (next : MergeList (n + n) cnt constraint)
      -> MergeList n (n + cnt) constraint

%name MergeList xs,ys,zs

insertVect : {constraint : Ordered ty to}
          -> {n : Nat}
          -> {cnt : Nat}
          -> MergeList n cnt constraint
          -> OrderedVect n constraint
          -> MergeList n (cnt + n) constraint
insertVect {n} {constraint} {cnt=Z} Nil v
  = rewrite rewriteType in v :: Nil
      where rewriteType : MergeList n n constraint = MergeList n (n + 0) constraint
            rewriteType = rewrite sym $ plusZeroRightNeutral n in Refl
insertVect {n} {cnt} (Skip next) v = rewrite plusCommutative cnt n in
                                     v :: next
insertVect {n} ((::) v next {cnt}) v'
  = rewrite sym $ plusCommutative cnt n in
    rewrite sym $ plusAssociative cnt n n in
    Skip $ insertVect next (merge n v n v')

export
empty : .{auto constraint : Ordered ty to} -> MergeList 1 0 constraint
empty = []

export
insert : .{constraint : Ordered ty to}
      -> {cnt : Nat}
      -> MergeList 1 cnt constraint
      -> ty
      -> MergeList 1 (cnt + 1) constraint
insert l x = insertVect l [x]

export
mergeListToOrderedVect : .{constraint : Ordered ty _}
                      -> (n : Nat)
                      -> (cnt : Nat)
                      -> MergeList n cnt constraint
                      -> OrderedVect cnt constraint
mergeListToOrderedVect _ _ Nil = []
mergeListToOrderedVect n cnt (Skip next) = mergeListToOrderedVect (n + n) cnt next
mergeListToOrderedVect n (n + nextCnt) (v :: next)
  = merge n v nextCnt $ mergeListToOrderedVect (n + n) nextCnt next

namespace CountedMergeList
  public export
  CountedMergeList : (n : Nat) -> (constraint: Ordered to rel) -> Type
  CountedMergeList n constraint = (cnt : Nat ** Lazy $ MergeList n cnt constraint)

  export
  empty : CountedMergeList 1 constraint
  empty = (Z ** empty)

  export
  insert : .{constraint : Ordered ty to} -> CountedMergeList 1 constraint -> ty -> CountedMergeList 1 constraint
  insert (cnt ** xs) x = (cnt + 1 ** insert xs x)


module Data.Verified.Zifunctor

import Data.Zifunctor

%default total
%access public export

||| Verified Zifunctor
||| A Zifunctor for which identity and composition laws are verified
interface Zifunctor t => VerifiedZifunctor (t : Type -> Type -> Type -> Type) where
  zifunctorIdentity : {a : Type} -> {b : Type} -> {c : Type} ->
                     (x : t a b c) ->
                     zimap Basics.id Basics.id Basics.id x = x
  zifunctorComposition : {a : Type} -> {b : Type} -> {c : Type} ->
                         {a1 : Type} -> {b1 : Type} -> {c1 : Type} ->
                         (x : t a b c) ->
                         (fa1 : a1 -> a) -> (fb1 : b -> b1) -> (fc1 : c -> c1) ->
                         (fa2 : a2 -> a1) -> (fb2 : b1 -> b2) -> (fc2 : c1 -> c2) ->
                         (zimap (fa1 . fa2) (fb2 . fb1) (fc2 . fc1) x) =
                         (zimap fa2 fb2 fc2 . zimap fa1 fb1 fc1) x


-- 7.3 Exercises

data Vect : Nat -> Type -> Type where
     Nil  : Vect Z a
     (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a
%name Vect xs, ys, zs

Eq a => Eq (Vect n a) where
     (==) [] [] = True
     (==) (x :: xs) (y :: ys) = x == y && xs == ys
     (==) _ _ = False

Foldable (Vect n) where
     foldr func init [] = init
     foldr func init (x :: xs) = let acc = func x init in foldr func acc xs

Functor (Vect n) where
     map func [] = []
     map func (x :: xs) = func x :: map func xs


module Typing.Term

import public Syntax.Term
import public Loc

mutual

  public export
  record TyProgram where
    constructor MkProgram
    fileName  : String
    typedDefs : List TyDef
    dataDefs  : List DataDef
    recordDef : List RecordDef

  public export
  record TyDef where
    constructor TyDefine
    name : Name
    type : Ty
    value : TyExpr

  record TyPath where
    constructor MkTypedPath
    path : Path
    type : Ty

  public export
  data TyExpr
    = TELambda   Range Ty Name TyExpr
    | TECall     Range Ty TyExpr TyExpr
    | TEDo       Range Ty (List TyExpr)
    | TECase     Range Ty TyExpr (List (TyPat, TyExpr))
    | TEId       Path  Ty
    | TELit      Range Ty Literal

  public export
  data TyPat
    = TPaId      Name  Ty
    | TPaList    Range Ty (List TyPat)
    | TPaHdTl    Range Ty TyPat TyPat
    | TPaData    Range Ty TyPath (List TyPat)
    | TPaLit     Range Ty Literal

  public export
  data Ty
    = TyPoly     Range Path Ty
    | TySimple   Range String
    | TyArrow    Range Ty Ty
    | TyVar      Range String

  public export
  data Schema = MkSchema (List String) Ty

  Show TyPath where
    show (MkTypedPath p _) = show p

  public export
  Show Ty where
    show (TyPoly r path ty) = (show path) ++ " " ++ show ty
    show (TySimple r name) = name
    show (TyVar r name) = name
    show (TyArrow r a b) = show a ++ " -> " ++ show b


%default total

data Wrap : Type -> Type where
  MkWrap : a -> Wrap a

unwrap : Wrap a -> a
unwrap (MkWrap v) = v

data F : Type where
  MkF : Wrap (Not F) -> F

yesF : Not F -> F
yesF = MkF . MkWrap

notF : Not F
notF (MkF f) = unwrap f (yesF $ unwrap f)

argh : Void
argh = notF (yesF notF)


module Control.Optics.Setter

import public Control.Optics.Types

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

export
mapped : Functor f => Setter (f a) (f b) a b
mapped = sets map

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

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

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

infixr 4 %~
export
(%~) : Setter s t a b -> (a -> b) -> s -> t
(%~) = over


%default total

data F : Type where
  MkFix : ((0 g : Type -> Type) -> g === Not -> g F) -> F

yesF : Not F -> F
yesF nf = MkFix (\ g, Refl => nf)

notF : Not F
notF (MkFix f) =
  let g = f Not Refl in
  g (yesF g)

argh : Void
argh = notF (yesF notF)


module Vektoren

import Data.Vect

data Vektor : (n:Nat) -> (a:Type) -> Type where
  Nil : Vektor 0 a
  (::) : a -> Vektor n a -> Vektor (S n) a

concat : Vektor n a -> Vektor m a -> Vektor (n+m) a
concat [] ys = ys
concat (x :: xs) ys = x :: concat xs ys

fourInts : Vect 4 Int
fourInts = [0, 1, 2, 3]

sixInts : Vect 6 Int
sixInts = [4, 5, 6, 7, 8, 9]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts


||| A heterogeneous list. This was introduced in
||| chapter *Functor and Friends* and is also used in
||| later chapters
module Data.HList

import Data.Fin

%default total

public export
data HList : (ts : List Type) -> Type where
  Nil  : HList Nil
  (::) : (v : t) -> (vs : HList ts) -> HList (t :: ts)

public export
head : HList (t :: ts) -> t
head (v :: _) = v

public export
tail : HList (t :: ts) -> HList ts
tail (_ :: t) = t

public export
(++) : HList xs -> HList ys -> HList (xs ++ ys)
[]        ++ ws = ws
(v :: vs) ++ ws = v :: (vs ++ ws)

public export
indexList : (as : List a) -> Fin (length as) -> a
indexList (x :: _)   FZ    = x
indexList (_ :: xs) (FS y) = indexList xs y
indexList []        x impossible

public export
index : (ix : Fin (length ts)) -> HList ts -> indexList ts ix
index FZ     (v :: _)  = v
index (FS x) (_ :: vs) = index x vs
index ix [] impossible


module Main
import Data.Vect as V
import Prelude.List as L
import Prelude.Basics as B
import Data.String as S
import Utils as U

%default total

data Player = X | O

other : Player -> Player
other X = O
other O = X

Show Player where
	show X = "X"
	show O = "O"

Eq Player where
	X == X = True
	O == O = True
	_ == _ = False

record Board where
	constructor MkBoard
	columns : Matrix 7 7 $ Maybe Player

rows : Board -> Matrix 7 7 $ Maybe Player
rows = transpose . columns

Show Board where
    show = unlines . map (concat . map (maybe "." show)) . L.toList . rows

diagonals1 : Board -> List $ List $ Maybe Player
diagonals1 board = map catMaybes
                 $ transpose
                 $ zipWith (++) (take 7 $ iterate (Nothing::) []) (map (map Just) $ U.toList $ columns board)

diagonals2 : Board -> List $ List $ Maybe Player
diagonals2 = diagonals1 . MkBoard . transpose . columns

draw : Board -> Bool
draw = all (all isJust) . rows

winner : Board -> Maybe Player
winner board = head'
             $ catMaybes
	         $ mapMaybe head' -- Is there a better way to handle the impossible case [] with a proof?
			 $ L.filter (\x => L.length x >= 4)
			 $ concatMap {t = List} {a = List $ Maybe Player} group
			 $ concatMap (\ f => f board) {t = List} {a = Board -> List $ List $ Maybe Player}
			 $ [U.toList . rows, U.toList . columns, diagonals1, diagonals2]

legalMove : (n : Nat) -> Board -> Maybe $ LTE n 6
legalMove n board with (natToFin' n 7)
	| Nothing = Nothing
	| Just (f, p) = map (\ _ => fromLteSucc p) (V.index f $ V.head $ rows board)

dropColumn : Player -> Vect 7 $ Maybe Player -> Vect 7 $ Maybe Player
dropColumn player column =
	let tmp = V.catMaybes $ (Just player) :: (tail column) in
	let n = fst tmp in
	let xs = snd tmp in
	let p1 = catMaybesLTE {xs = (Just player) :: (tail column)} in
	let p2 : ((minus 7 n) + n = 7) = rewrite plusCommutative (minus 7 n) n in plusMinusNeutral p1 in
	rewrite sym p2 in
	(replicate (minus 7 n) Nothing) ++ (map Just xs)

move : Player -> Nat -> Board -> Maybe Board
move player n board with (legalMove n board)
    | Nothing = Nothing
    | Just p = Just board' where
    	tmp : (Vect n $ Vect 7 $ Maybe Player, Vect 7 $ Maybe Player, Vect (minus 6 n) $ Vect 7 $ Maybe Player)
    	tmp = splitAt' n $ rewrite plusMinusNeutral p in columns board

    	board' = let (left, column, right) = tmp in
    		MkBoard $
    		replace {P = \n => Matrix n 7 $ Maybe Player} (plusMinusNeutral $ lteSuccRight p) $
			rewrite sym $ succMinus p in
	        left ++ [dropColumn player column] ++ right

record Game where
	constructor MkGame
	player : Player
	board : Board

partial gameloop : Game -> IO ()
gameloop game@(MkGame player board) = do
    putStr $ show player ++ "s turn: "
    line <- getLine
    case (parsePositive line) >>= (\n => move player n board) of
        Nothing => (print board) >>= (\_ => gameloop game)
        Just board' => do
            print board'
            if draw board
                then putStrLn "Draw!"
                else case winner board' of
                    Just player => putStrLn $ show player ++ " Won!"
                    Nothing => gameloop $ MkGame (other player) board'

partial main : IO ()
main = do
    let board = MkBoard (replicate 7 $ replicate 7 Nothing)
    print board
    gameloop $ MkGame X board


||| Provie `Day` level function.
module Data.Time.Calendar.Days

||| The Modified Julian Day is a standard count of days, with zero being the day 1858-11-17.
public export
data Day = MkModifiedJulianDay Integer

export
Eq Day where
  (MkModifiedJulianDay a) == (MkModifiedJulianDay b) = a == b

export
Ord Day where
  compare (MkModifiedJulianDay a) (MkModifiedJulianDay b) = compare a b

export
toInteger : Day -> Integer
toInteger (MkModifiedJulianDay x) = x

export
Enum Day where
  pred (MkModifiedJulianDay x) = MkModifiedJulianDay (pred x)
  toNat (MkModifiedJulianDay x) = toNat x
  fromNat x = MkModifiedJulianDay (fromNat x)

export
range: (Day, Day) -> List Day
range (MkModifiedJulianDay x, MkModifiedJulianDay y) = map (MkModifiedJulianDay) [x .. y]

export
index: (Day, Day) -> Nat -> Maybe Day
index (a, b) k =
  let (MkModifiedJulianDay a1) = a
      (MkModifiedJulianDay b1) = b
      range_a_b = range (a, b)
      inbounds = inBounds k range_a_b
  in
    case inbounds of
         Yes prf => Just (List.index k range_a_b)
         No  contra => Nothing

export
inRange: (Day, Day) -> Day -> Bool
inRange (a, b) k = elem k (range (a, b))

export
rangeSize: (Day, Day) -> Nat
rangeSize x = List.length (range x)

export
addDays: Integer -> Day -> Day
addDays x (MkModifiedJulianDay y) = MkModifiedJulianDay (x + y)

export
diffDays: Day -> Day -> Integer
diffDays (MkModifiedJulianDay x) (MkModifiedJulianDay y) = x - y


module Brainfeck.Type

import Data.Vect

%default total

public export
Label : Nat -> Type
Label = Fin

public export
data Token     : Type  where
  TLeft        : Token -- <
  TRight       : Token -- >
  TInc         : Token -- +
  TDec         : Token -- -
  TOut         : Token -- .
  TIn          : Token -- ,
  TJumpForward : Token -- [
  TJumpBack    : Token -- ]

public export
data Operation : Nat -> Type where
  OLeft        : Operation n -- <
  ORight       : Operation n -- >
  OInc         : Operation n -- +
  ODec         : Operation n -- -
  OOut         : Operation n -- .
  OIn          : Operation n -- ,
  OJumpZero    : Label f -> Operation f-- [
  OJumpNZero   : Label b -> Operation b -- ]

export
tokenToS : Token -> String
tokenToS TLeft = "<"
tokenToS TRight = ">"
tokenToS TInc = "+"
tokenToS TDec = "-"
tokenToS TOut = "."
tokenToS TIn = ","
tokenToS TJumpForward = "["
tokenToS TJumpBack = "]"

export
operationToS : Operation f -> String
operationToS OLeft          = "<"
operationToS ORight         = ">"
operationToS OInc           = "+"
operationToS ODec           = "-"
operationToS OOut           = "."
operationToS OIn            = ","
operationToS (OJumpZero  l) = "[ " ++ show (finToNat l)
operationToS (OJumpNZero l) = show (finToNat l) ++ " ]"

public export
data Location : Type where
  Loc : (line : Nat) -> (col : Nat) -> Location

export
locToS : Location -> String
locToS (Loc l c) = "Line: " ++ show l ++ " Column: " ++ show c

public export
Tokens   : Nat -> Type
Tokens n = Vect n (Location, Token)
%name Tokens tokens

-- TODO: Use a better datatype for this (Brainfeck.Instructions.Instructions?)
-- This hasn't been profiled, but it seems trivially true that doing "random" access indexing
-- with ineffecient Fin's is going to cause speed problems
-- Probably wait until its actually an issue first though
public export
Instructions   : Nat -> Type
Instructions n = Vect n (Operation n)
%name Instructions instructions


module Main

mutual
  evenT : Nat -> IO Bool
  evenT Z = pure True
  evenT (S k) = oddT k

  oddT : Nat -> IO Bool
  oddT Z = pure False
  oddT (S k) = evenT k

main : IO ()
main = evenT 99999 >>= printLn


module congruences

||| Congruence
public export
congruence : (ty1, ty2 : Type) -> (a : ty1) -> (b : ty1) -> (f : ty1 -> ty2) -> (a = b) -> ((f a) = (f b))
congruence ty1 ty2 a a f Refl = Refl


import Data.Vect

nums : List (Int, Int)
nums = [(1, 2), (3, 4), (5, 6)]

addToNums : List (Int, Int) -> List (Int, Int)
addToNums = map (\ (x, y) => (x + 1, y + 1))

vects : List (n ** Vect n Int)
vects = [(_ ** [1,2,3]),
         (_ ** [1,2,3,4]),
         (_ ** [1,2,3,4,5])]

lengths : List (n ** Vect n a) -> List Nat
lengths = map (\ (len ** xs) => length xs)


data X = A Int

(.la) : X -> Int
(.la) (A x) = x

f : X -> String
f x = show x.la

-- Projection does not define the usual function.
-- `g` does not typecheck without the `la` definition.
-- Moreover, they may have different implementations.

la : X -> Int
la $ A x = x + 1

g : X -> String
g x = show $ la x


module Syntax

%default total

showMaybe : {0 a : Type} -> (assumption : Show a) => Maybe a -> String
showMaybe x@ma = case map (id . id) ma of
    Nothing => "Nothing"
    Just a => "Just " ++ show a

nats : List Nat
nats =
  let n = 5
      m = 7
      xs = [id $ id 0]
      ys = [1, 2, m, n, 3] ++ xs
  in [n,id $ id m] ++ [1, 2, m, n, 3] ++ xs

record ANat where
  constructor MkANat
  aNat : Nat

doBlock : Maybe ANat
doBlock
  = do let a = 3
       let b = 5
       (c, _) <- Just (7, 9)
       let (d, e) = (c, c)
       f <- [| Nothing + Just d |]
       pure $ MkANat $ sum [a,b,c,d,e,f]

parameters (x, y, z : Nat)

  add3 : Nat
  add3 = x + y + z

parameters (x, y : Nat) (z, a : Nat)

  add4 : Nat
  add4 = x + y + z + a

anonLam : Maybe (m : Nat ** n ** m === n)
anonLam = map (\m => (m ** m ** Refl))
        $ map (uncurry $ \ m, n => m + n)
        $ map (\ (m, n) => (n, m))
        $ map (\ m => (m, m))
        $ map (\ m => S m.aNat)
        doBlock


module Main

import Data.Vect

-- foldr (::) [] converts to lists
foldToList : (Foldable t) => t a -> List a
foldToList = foldr (::) []

showTestLine : List Int -> Vect n Int -> IO ()
showTestLine xs ys =
  putStrLn $ "(" ++
    show xs ++ ", " ++
    show ys ++ ") " ++
    "-> (" ++
    show (foldToList xs) ++ ", " ++
    show (foldToList ys) ++ ")"

main : IO ()
main = do
  showTestLine [] []
  showTestLine [1] [1]
  showTestLine [1, 2, 3] [1, 2, 3]
  showTestLine [3, 2, 1] [3, 2, 1]


module Configuration

import Data.Vect
import Data.Fin

data State = UnOccupied
           | Occupied

data Square : Nat -> Type where
     Create : Vect n (Vect n State) -> Square n

times : (n : Nat) -> a -> Vect n a
times Z x = []
times (S k) x = x :: times k x

emptySquare : (n : Nat) -> Vect n (Vect n State)
emptySquare n = times n (times n UnOccupied)

empty : (n : Nat) -> Square n
empty n = Create (emptySquare n)

update : (Fin n, Fin n) -> State -> Vect n (Vect n State) -> Vect n (Vect n State)
update x y xs = xs

play : (Fin n, Fin n) -> Square n -> Square n
play (a, b) (Create xs) = let ys = update (a, b) Occupied xs in
     Create ys


-- examples in "Type-Driven Development with Idris"
-- chapter 14, section 1, Door part

-- check that all functions are total
%default total

data DoorResult = OK | Jammed

data DoorState = DoorClosed | DoorOpen

data DoorCmd : (ty : Type) ->
               DoorState ->
               (ty -> DoorState) ->
               Type where
  Open :                   DoorCmd DoorResult DoorClosed
                                              (\res => case res of
                                                        OK => DoorOpen
                                                        Jammed => DoorClosed)
  Close :                  DoorCmd ()         DoorOpen      (const DoorClosed)
  RingBell :               DoorCmd ()         DoorClosed    (const DoorClosed)
  Display :  String ->     DoorCmd ()         state         (const state)
  Pure :     (res : ty) -> DoorCmd ty         (state res)   state
  (>>=) :                  DoorCmd a          state1        state2 ->
             ((res : a) -> DoorCmd b          (state2 res)  state3) ->
                           DoorCmd b          state1        state3

doorProg : DoorCmd () DoorClosed (const DoorClosed)
doorProg = do RingBell
              OK <- Open | Jammed => Display "Door Jammed"
              Display "Door OK"
              Close

logOpen : DoorCmd DoorResult DoorClosed
                             (\res => case res of
                                        OK => DoorOpen
                                        Jammed => DoorClosed)
logOpen = do Display "Trying to open the door"
             OK <- Open | Jammed => do Display "Jammed"
                                       Pure Jammed
             Display "Success"
             Pure OK


module Heap

%default total
%access private

public export
interface Heap (h : Type -> Type) where
  empty : Ord a => h a
  isEmpty : Ord a => h a -> Bool

  insert : Ord a => a -> h a -> h a
  merge : Ord a => h a -> h a -> h a

  findMin : Ord a => h a -> a
  deleteMin : Ord a => h a -> h a


import Data.Either
import Data.List
import Data.Maybe
import Data.String

import System.File

data LowPoint = L Nat | N Nat

Show LowPoint where
  show (L k) = "L " ++ show k
  show (N k) = "N " ++ show k

get : LowPoint -> Nat
get (L k) = k
get (N k) = k

isLow : LowPoint -> Bool
isLow (L k) = True
isLow (N k) = False

parseLines : (String -> Maybe a) -> String -> List a
parseLines f s = catMaybes $ f <$> lines s

lowPointsRow : Nat -> List Nat -> List LowPoint
lowPointsRow n [] = []
lowPointsRow n (x :: []) = if x < n then [L x] else [N x]
lowPointsRow n (x :: (y :: xs)) = (if x < n && x < y then L x else N x) :: lowPointsRow x (y :: xs)

comp : Nat -> LowPoint -> LowPoint
comp p (L k) = if k < p then L k else N k
comp _ (N k) = N k

comp3 : Nat -> LowPoint -> Nat -> LowPoint
comp3 p (L k) n = if k < n && k < p then L k else N k
comp3 _ (N k) _ = N k

lowPointsCol : List Nat -> List (List LowPoint) -> List (List LowPoint)
lowPointsCol prev [] = []
lowPointsCol prev (row :: []) = [ (\(p, r) => comp p r) <$> zip prev row ]
lowPointsCol prev (row :: (next :: rows)) = ((\(p, r, n) => comp3 p r (get n)) <$> zip3 prev row next) :: lowPointsCol (get <$> row) (next :: rows)

run : String -> IO ()
run s = do let l = (\l => catMaybes $ parsePositive {a=Nat} . singleton <$> unpack l) <$> lines s
           let r = lowPointsCol (replicate 100 10) $ lowPointsRow 10 <$> l
           let s = sum $ S . get <$> (filter isLow $ (join r))
           putStrLn $ show $ s

main : IO ()
main = do Right s <- readFile "input.txt"
            | Left err => putStrLn $ show err
          run s


%default partial

onlyOne : Int -> Int
onlyOne 1 = 2

covered : Int -> Int
covered 1 = 2
covered 2 = 3
covered _ = 94

data IntNat : Integer -> Nat -> Type where
     IsZero : IntNat 0 Z
     IsSuc : IntNat 1 (S k)

-- Only identified as covering if 'x' has multiplicity 0 because then it
-- doesn't show up in the case tree!
matchInt : (0 x : Integer) -> (n : Nat) -> IntNat x n -> String
matchInt 0 Z IsZero = "Zero"
matchInt 1 (S k) IsSuc = "Non Zero"

-- Should be identified as covering but isn't yet since the checker requires
-- a catch all case. This does at least test that the declared 'impossible'
-- case really is impossible; we can update it when the checker improves!
matchInt' : (x : Integer) -> (n : Nat) -> IntNat x n -> String
matchInt' 0 Z IsZero = "Zero"
matchInt' 1 (S k) IsSuc = "Non Zero"
matchInt' 0 (S k) x impossible


module Main

%default total

-- Data type

data BF : Char -> Type where
  Next : BF '>'
  Prev : BF '<'
  Increment : BF '+'
  Decrement : BF '-'
  Output : BF '.'
  Accept : BF ','
  Forward : BF '['
  Backward : BF ']'

-- Interpreter

data Tape a = MkTape (Stream a) a (Stream a)

right : Tape a -> Tape a
right (MkTape ls c (r :: rs)) = MkTape (c :: ls) r rs

left : Tape a -> Tape a
left (MkTape (l :: ls) c rs) = MkTape ls l (c :: rs)

emptyTape : Tape Int
emptyTape = MkTape (repeat 0) 0 (repeat 0)

Instruction : Type
Instruction = Maybe (Sigma Char BF)

mutual
  partial
  nextInstruction : Tape Int -> Tape Instruction -> IO ()
  nextInstruction dat ins = bf' dat (right ins)

  partial
  runInstruction : Tape Int -> Tape Instruction -> BF c -> IO ()

  runInstruction dat ins Next =
    nextInstruction (right dat) ins

  runInstruction dat ins Prev =
    nextInstruction (left  dat) ins

  runInstruction (MkTape ls c rs) ins Increment =
    nextInstruction (MkTape ls (succ c) rs) ins

  runInstruction (MkTape ls c rs) ins Decrement =
    nextInstruction (MkTape ls (pred c) rs) ins

  runInstruction dat@(MkTape _ c _) ins Output = do
    putChar (chr c)
    nextInstruction dat ins

  runInstruction (MkTape ls _ rs) ins Access = do
    c <- getChar
    nextInstruction (MkTape ls (ord c) rs) ins

  runInstruction dat@(MkTape _ n _) ins Forward = do
    if n == 0
    then loopRight Z dat ins
    else nextInstruction dat ins

  runInstruction dat@(MkTape _ n _) ins Backward = do
    if n /= 0
    then loopLeft Z dat ins
    else nextInstruction dat ins

  runInstruction dat ins _ =
    nextInstruction dat ins

  partial
  loopRight' : Nat -> Tape Int -> Tape Instruction -> BF c -> IO ()
  loopRight' (S Z) dat ins Backward =
    nextInstruction dat ins
  loopRight' n dat ins Backward =
    loopRight (pred n) dat (right ins)
  loopRight' n dat ins Forward =
    loopRight (succ n) dat (right ins)
  loopRight' n dat ins _ =
    loopRight n dat (right ins)

  partial
  loopRight : Nat -> Tape Int -> Tape Instruction -> IO ()
  loopRight n dat ins@(MkTape _ (Just p) _) =
    loopRight' n dat ins (getProof p)
  loopRight n dat ins =
    loopRight n dat (right ins)

  partial
  loopLeft' : Nat -> Tape Int -> Tape Instruction -> BF c -> IO ()
  loopLeft' (S Z) dat ins Forward =
    nextInstruction dat ins
  loopLeft' n dat ins Forward =
    loopLeft (pred n) dat (left ins)
  loopLeft' n dat ins Backward =
    loopLeft (succ n) dat (left ins)
  loopLeft' n dat ins _ =
    loopLeft n dat (left ins)

  partial
  loopLeft : Nat -> Tape Int -> Tape Instruction -> IO ()
  loopLeft n dat ins@(MkTape _ (Just p) _) =
    loopLeft' n dat ins (getProof p)
  loopLeft n dat ins =
    loopLeft n dat (left ins)

  partial
  bf' : Tape Int -> Tape Instruction -> IO ()
  bf' _     (MkTape _ Nothing  _) = return ()
  bf' dat ins@(MkTape _ (Just p) _) = runInstruction dat ins (getProof p)

-- Literals

data Every : List a -> Type where

partial
bf : (s : String) -> { auto p : Every (unpack s) } -> IO ()

partial
main : IO ()
main = do
  bf"++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-."


%default partial

data Foo : Int -> Type where
     FZero : Foo 0
     FPlus : (x : Int) -> (y : Int) -> Foo (x + y)

tfoo : (x : Int) -> Foo x -> Int
tfoo 0 FZero = ?bar
tfoo (x + y) (FPlus x y) = ?baz

foo : (x : Int) -> Foo x

wfoo : (x : Int) -> Int
wfoo x with (foo x)
  wfoo 0 | FZero = ?wfoo_rhs_1
  wfoo (y + z) | (FPlus y z) = ?wfoo_rhs_2

wbar : (x : Int) -> Int
wbar x with (foo x)
  wbar 0 | FZero = ?wbar_rhs_1
  wbar (1 + z) | (FPlus 1 z) = ?wbar_rhs_2

wbar1 : (x : Int) -> Int
wbar1 x with (foo x)
  wbar1 0 | FZero = ?wbar1_rhs_1
  wbar1 (1 + z) | (FPlus 1 z) = ?wbar1_rhs_2
  wbar1 (y + z) | (FPlus y z) = ?wbar1_rhs_3


module Flexidisc.OrdList.SubWithKeys

import Flexidisc.OrdList.Label
import Flexidisc.OrdList.Sub
import Flexidisc.OrdList.Type

import Data.List

import public Data.List

%default total

||| Proof that an `OrdList` has some given `keys` and is a sublist of an other
public export
data SubWithKeys : (keys : List k) -> (xs, ys : OrdList k v o) -> Type where
  ||| The empty `Ordlist` is a sublist of the empty `OrdList`
  Empty : SubWithKeys [] [] []
  ||| Making the second list larger don't change the property
  Skip  : SubWithKeys keys xs ys -> SubWithKeys keys xs (y::ys)
  ||| To add an element to the first list, we need to add it to the second one
  Keep  : (loc : Elem k keys) -> SubWithKeys (dropElem keys loc) xs ys ->
          SubWithKeys keys ((k, ty)::xs) ((k, ty)::ys)

Uninhabited (SubWithKeys (x::xs) sub []) where
  uninhabited Empty impossible
  uninhabited (Skip _) impossible
  uninhabited (Keep _ _) impossible

%name SubWithKeys sub, issub, ss

export
toSub : SubWithKeys keys xs ys -> Sub xs ys
toSub Empty = Empty
toSub (Skip sub) = Skip (toSub sub)
toSub (Keep x sub) = Keep (toSub sub)


import Data.Vect

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

test2: Vect (2 + 2) Int
test2 = test1


module Euler_circuit

import Data.Fin
import Data.Vect as V

  -- data EulerG : Graph n -> Type where
  --   EulerEmpty : (g: Graph Z)   -> EulerG g
  --   EulerAddLoop   : (a: Fin k) -> (g: Graph1 k ** EulerG g) -> EulerG (AddEdge a a g)
  --

data Graph1 : (n : Nat) -> Type where
  WithoutEdge : Graph1 k
  AddEdge     : (a: Fin k) -> (b: Fin k) -> Graph1 k -> Graph1 k

data Graph2 : (n : Nat) -> Vect n (List (Fin n)) -> Vect n (List (Fin n)) -> Type where
  Graph2Empty     : {k: Nat} -> Graph2 k (replicate k Nil) (replicate k Nil)
  Graph2AddEdge   : (a : Fin k) -> (b : Fin k) -> (g: Graph2 k ies oes)
                  -> Graph2 k (updateAt b (a::) $ ies)
                              (updateAt a (b::) $ oes)

data EqLen : List a -> List a -> Type where
  EqLenZ : EqLen Nil Nil
  EqLenS : EqLen xs ys -> a -> b -> EqLen (a::xs) (b::ys)

data ZipPVect : (P : a -> b -> Type) -> Vect n a -> Vect n b -> Type where
  ZipPVectZ : {P: a -> b -> Type} -> ZipPVect P Nil Nil
  ZipPVectS : {P: a -> b -> Type} -> ZipPVect P xs ys -> (x: a) -> (y: b) -> P x y -> ZipPVect P (x::xs) (y::ys)

data Path : (head: Type) -> head -> Type where
  PathO : {a: Type} -> (x: a) -> (y: a) -> Path a y
  PathS : {a: Type} -> Path a x -> (y: a) -> Path a y

data ContainEdges : Path (Fin n) h -> (g: Graph2 n ies oes) -> Type where
  ContainEdgesO : (a: Fin n) -> (b: Fin n) -> ContainEdges (PathO a b) (Graph2AddEdge a b Graph2Empty)
  ContainEdgesS : (es: Path (Fin n) h) -> (g: Graph2 n ies oes) -> ContainEdges es g
               -> (a: Fin n) -> (b: Fin n) -> h = a -> ContainEdges (PathS es b) (Graph2AddEdge a b g)

data IsoGraph2 : (g1: Graph2 n1 ies1 oes1) -> (g2: Graph2 n2 ies2 oes2) -> Type where
  IsoGraph2eq : g1 = g2 -> IsoGraph2 g1 g2

delete_empty_node : (g: Graph2 (S k) (Nil::ies) (Nil::oes)) -> ZipPVect EqLen ies oes
                 -> (g': Graph2 k ies' oes' ** ZipPVect EqLen ies' oes')
delete_empty_node = ?q1

add_empty_node : (path: Path (Fin n) h) -> (g: Graph2 n ies oes) -> (contEd: ContainEdges path g') -> (isoG: IsoGraph2 g g')
              -> (path: Path (Fin n) h ** (ContainEdges path g'', IsoGraph2 g g''))
add_empty_node = ?q2

theorem : {n: Nat} -> (g: Graph2 n ies oes) -> ZipPVect EqLen ies oes
       -> Maybe (path: Path (Fin n) h ** (ContainEdges path g', IsoGraph2 g' g))
theorem Graph2Empty _ = Nothing
theorem g (ZipPVectS zipPVect [] [] (EqLenZ)) =
  let (g' ** zipPVect') = delete_empty_node g zipPVect
      (path' ** (contEd, isoG)) = case theorem g' zipPVect' of -- TODO: can't match `P path'` and `(A, B)`
         (Just x) => x
         Nothing  => absurd
  in Just $ ?add_empty_node path' g' contEd isoG

-- TODO: prove round trip add/delete empty node
{-
 g  ~  g'+1
 !      !
g-1  ~  g'
-}


module Synchronous

import Data.Vect

%access export
%default total

counterFrom : Num ty => ty -> Stream ty
counterFrom = iterate (+1)

simulate : (Stream a -> Stream b) -> Stream a -> Stream b
simulate f xs = f xs

public export
delay : a -> Stream a -> Stream a
delay a s = a :: s

mux : Stream Bool -> Stream a -> Stream a -> Stream a
mux = liftA3 (\e,a,b=>if e then a else b)

regEn : a -> Stream Bool -> Stream a -> Stream a
regEn a (False :: xs) (y :: ys) = a :: regEn a xs ys
regEn a (True  :: xs) (y :: ys) = a :: regEn y xs ys

regMaybe : a -> Stream (Maybe a) -> Stream a
regMaybe a (Nothing  :: xs) = a :: regMaybe a xs
regMaybe a ((Just x) :: xs) = a :: regMaybe x xs

public export
window : (n : Nat) -> a -> Stream a -> Stream (Vect n a)
window Z a xs     = pure []
window (S k) a xs = let dl = scanl (flip delay) xs (replicate (k) a)
                    in  sequence dl


module Calc

%default total

public export
addInts : Int -> Int -> Int
addInts x y = x + y

public export
subInts : Int -> Int -> Int
subInts x y = x - y

public export
mulInts : Int -> Int -> Int
mulInts x y = x * y

public export
divInts : Int -> Int -> Int
divInts x y = x `div` y


data InfIO: Type where
  Do: IO a -> (a -> Inf InfIO) -> InfIO

(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

forever: Fuel
forever = More forever

tank: Nat -> Fuel
tank Z = Dry
tank (S k) = More (tank k)

printLoop: String -> InfIO
printLoop msg =
  do
    putStrLn msg
    printLoop msg

run: InfIO -> IO()
run (Do action cont) =
  do
    res <- action
    run (cont res)

runFuel: Fuel -> InfIO -> IO()
runFuel Dry         y                = putStrLn "Out of fuel"
runFuel (More fuel) (Do action cont) =
  do
    res <- action
    runFuel fuel (cont res)


module Poker.Deck

import Control.ST
import Control.ST.Random
import Data.Fin
import Data.Vect

%access public export
%default total

elemSmallerThanBound : (n : Fin m) -> LT (finToNat n) m
elemSmallerThanBound FZ = LTESucc LTEZero
elemSmallerThanBound (FS x) = LTESucc (elemSmallerThanBound x)

data Suit = Spade | Heart | Diamond | Club

DecEq Suit where
  decEq Spade Spade = Yes Refl
  decEq Spade Heart = No $ \Refl impossible
  decEq Spade Diamond = No $ \Refl impossible
  decEq Spade Club = No $ \Refl impossible
  decEq Heart Spade = No $ \Refl impossible
  decEq Heart Heart = Yes Refl
  decEq Heart Diamond = No $ \Refl impossible
  decEq Heart Club = No $ \Refl impossible
  decEq Diamond Spade = No $ \Refl impossible
  decEq Diamond Heart = No $ \Refl impossible
  decEq Diamond Diamond = Yes Refl
  decEq Diamond Club = No $ \Refl impossible
  decEq Club Spade = No $ \Refl impossible
  decEq Club Heart = No $ \Refl impossible
  decEq Club Diamond = No $ \Refl impossible
  decEq Club Club = Yes Refl

Rank : Type
Rank = Fin 13

record Card where
  constructor MkCard
  suit : Suit
  rank : Rank

enumFinHelp : (b : Nat) -> Vect a (Fin a) -> Vect (b + a) (Fin (b + a))
enumFinHelp Z xs = xs
enumFinHelp {a} (S k) xs =
  let  xs' = last :: map weaken xs
  in rewrite plusSuccRightSucc k a in
  enumFinHelp k xs'

enumFin : (n : Nat) -> Vect n (Fin n)
enumFin n =
  rewrite sym (plusZeroRightNeutral n) in
  enumFinHelp n []

outerBy : (a -> b -> c) -> Vect m a -> Vect n b -> Vect (m * n) c
outerBy {m} {n} f xs ys =
  concat {m = m} {n = n} $ map (\x => map (f x) ys) xs

suits : Vect 4 Suit
suits = [Spade, Heart, Diamond, Club]

ranks : Vect 13 Rank
ranks = enumFin 13

ace : Rank
ace = the Rank last

newDeck : Vect 52 Card
newDeck =
  let ss = suits
      rs = ranks
  in outerBy MkCard ss rs

data Cut : (m : Nat) -> Vect o t -> Type where
  MkCut : (f : Vect m t) ->
          (c : t) ->
          (b : Vect n t) ->
          Cut m (f ++ c :: b)

plusOnePlusSucc : (m : Nat) -> (i' : Nat) -> plus (plus m 1) i' = S (plus m i')
plusOnePlusSucc m i' = rewrite plusCommutative m 1 in Refl

cutHelp : (f : Vect m t ) ->
          (b : Vect (S n) t ) ->
          (i : Nat) ->
          (lt : LT i (S n)) ->
          Cut (m + i) (f ++ b)
cutHelp {m = m} {n = n} f (c :: b) Z lt =
  rewrite plusZeroRightNeutral m in
  MkCut f c b
cutHelp {m = m} {n = Z} f (c :: b) (S i') (LTESucc lt') = absurd lt'
cutHelp {m = m} {n = (S n')} f (c :: b) (S i') (LTESucc lt') =
  let rec = cutHelp (f ++ [c]) b i' lt'
  in rewrite vectAppendAssociative f [c] b in
     rewrite sym $ plusSuccRightSucc m i' in
     rewrite sym $ plusOnePlusSucc m i' in
     rec

cut : (i : Nat) -> (xs : Vect n t) ->
      {auto smaller : LT i n} ->
      Cut i xs
cut {n = Z} i xs {smaller = smaller} = absurd smaller
cut {n = (S k)} i xs {smaller = smaller} = cutHelp [] xs i smaller

data Shuffle : Vect n t -> Type where
  EmptyShuffle : (xs : Vect Z t) -> Shuffle xs
  Deal : (c : t) -> Shuffle (f ++ b) -> Shuffle (f ++ c :: b)

mutual
  shuffleHelp : (rnd : Var) -> (xs : Vect n t) ->
                (i : Fin n) ->
                ST m (Shuffle xs) [rnd ::: Random]
  shuffleHelp {t} rnd xs i with (elemSmallerThanBound i)
    shuffleHelp {t} rnd xs i | lt with (finToNat i)
      shuffleHelp {t} rnd xs i | lt | i' with (cut i' xs)
        shuffleHelp {t} rnd (f ++ c :: b) i | lt | i' | (MkCut f c b) = do
          rest <- shuffle rnd $ assert_smaller (f ++ c :: b) (f ++ b)
          pure (Deal {t = t} {f = f} {b = b} c rest)

  shuffle : (rnd : Var) -> (xs : Vect n t) -> ST m (Shuffle xs) [rnd ::: Random]
  shuffle {n = Z} rnd [] = pure (EmptyShuffle [])
  shuffle {n = (S n')} rnd xs = do
    i <- rndFin rnd n'
    shuffleHelp rnd xs i

-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:


{-
True
0
False
False
4
42
42
True
False
[33, 42, 42, 42, 42]
[42, 42, 33, 42, 42]
[42, 42, 42, 42, 33]
[33, 42, 42, 42]
[42, 42, 33, 42]
[42, 42, 42, 33]
False
True
-}

import Data.Vector

main : IO ()
main = do
  let e = the (Vector Int) empty
  printLn (null e)
  printLn (length e)
  printLn (elem 42 e)
  let a = replicate 4 (the Int 42)
  printLn (null a)
  printLn (length a)
  printLn (a !! 0)
  printLn (a !! 3)
  printLn (elem 42 a)
  printLn (elem 33 a)
  printLn (unsafeInsertAt 0 33 a)
  printLn (unsafeInsertAt 2 33 a)
  printLn (unsafeInsertAt (length a) 33 a)
  printLn (unsafeReplaceAt 0 33 a)
  printLn (unsafeReplaceAt 2 33 a)
  printLn (maybe a (\index => unsafeReplaceAt index 33 a) (lastIndex a))
  printLn (elem 33 a)
  printLn (elem 33 (singleton 33))

-- Local Variables:
-- idris-load-packages: ("cil")
-- End:


module Quantities.Information

import Quantities.Core

%default total
%access public export

Information : Dimension
Information = MkDimension "Information"

Bit : ElemUnit Information
Bit = MkElemUnit "bit" 1

Byte : ElemUnit Information
Byte = < one "byte" equals 8 Bit >

-- Binary prefixes for multiples of bits/bytes
-- Based on http://en.wikipedia.org/wiki/Binary_prefix

twoToTheTen : String -> Nat -> ElemUnit q -> ElemUnit q
twoToTheTen pre power (MkElemUnit name f) =
  < one (pre ++ name) equals (pow 1024.0 power) (MkElemUnit name f) >

kibi : ElemUnit q -> ElemUnit q
kibi = twoToTheTen "kibi" 1
ki : ElemUnit q -> ElemUnit q
ki = kibi

mebi : ElemUnit q -> ElemUnit q
mebi = twoToTheTen "mebi" 2
mi : ElemUnit q -> ElemUnit q
mi = mebi

gibi : ElemUnit q -> ElemUnit q
gibi = twoToTheTen "gibi" 3
gi : ElemUnit q -> ElemUnit q
gi = gibi

tebi : ElemUnit q -> ElemUnit q
tebi = twoToTheTen "tebi" 4
ti : ElemUnit q -> ElemUnit q
ti = tebi

pebi : ElemUnit q -> ElemUnit q
pebi = twoToTheTen "pebi" 5
pi : ElemUnit q -> ElemUnit q
pi = pebi

exbi : ElemUnit q -> ElemUnit q
exbi = twoToTheTen "exbi" 6
ei : ElemUnit q -> ElemUnit q
ei = exbi

zebi : ElemUnit q -> ElemUnit q
zebi = twoToTheTen "zebi" 7
zi : ElemUnit q -> ElemUnit q
zi = zebi

yobi : ElemUnit q -> ElemUnit q
yobi = twoToTheTen "yobi" 8
yi : ElemUnit q -> ElemUnit q
yi = yobi

-- Please Note: kibi byte /= kilo byte


data Cont : (r : Type) -> (a : Type) -> Type where
     MkCont : ((k : a -> r) -> r) -> Cont r a

data ContT : (r : Type) -> (m : Type -> Type) -> (a : Type) -> Type where
     MkContT : ((k : a -> m r) -> m r) -> ContT r m a

cbind : Cont r a -> (a -> Cont r b) -> Cont r b

ctbind : ContT r m a -> (a -> ContT r m b) -> ContT r m b

callCC : ((a -> ContT r m b) -> ContT r m a) -> ContT r m a