data Vect : Nat -> Type -> Type where
     Nil : Vect Z a
     (::) : a -> Vect k a -> Vect (S k) a

record MyDPair a p where
  constructor MkMyDPair
  dfst : a
  dsnd : p dfst

cons : t -> MyDPair Nat (\n => Vect n t) -> MyDPair Nat (\n => Vect n t)
cons val xs
    = { dfst := S (dfst xs),
        dsnd := val :: dsnd xs } xs

cons' : t -> MyDPair Nat (\n => Vect n t) -> MyDPair Nat (\n => Vect n t)
cons' val
    = { dfst $= S,
        dsnd $= (val ::) }

record Stats where
  constructor MkStats
  height : Int
  weight : Int

record Person where
  constructor MkPerson
  name : String
  age, shoesize : Int
  more : Stats

testPair : MyDPair Nat (\n => Vect n Int)
testPair = MkMyDPair _ [1,2,3,4,5]

testPerson : Person
testPerson = MkPerson "Fred" 1337 10 (MkStats 10 10)

grow : Person -> Person
grow = { more.height $= (+1) }


module GridOps

import Data.Vect
import src.Tensor

%access public export

shiftLeft : a -> Vect n a -> Vect n a
shiftLeft e [] = []
shiftLeft {n = S n} e (x :: xs) = replace {P = (\x => Vect x a)} (plusCommutative n 1) (xs ++ [e])

shiftRight : a -> Vect n a -> Vect n a
shiftRight e xs = reverse $ shiftLeft e $ reverse xs

data Dir = Left | Right | Up | Down

shift : List Dir -> a -> Vect n (Vect m a) -> Vect n (Vect m a)
shift [] e xss = xss
shift (Left :: ds) e xss = shift ds e (map (shiftLeft e) xss)
shift (Right :: ds) e xss = shift ds e (map (shiftRight e) xss)
shift (Up :: ds) e xss = shift ds e (shiftLeft (replicate _ e) xss)
shift (Down :: ds) e xss = shift ds e (shiftRight (replicate _ e) xss)

data Pos = First | Last | Middle

toPos : Fin n -> Pos
toPos {n} fin with (finToNat fin)
 toPos {n} fin | Z = First
 toPos {n} fin | n' = if n == (S n') then Last else Middle

lookup : Fin n -> Fin m -> List Dir -> a -> Vect n (Vect m a) -> a
lookup n m ds x xss = index n m $ shift ds x xss


import Data.Vect

my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + length xs

my_reverse : List a -> List a
my_reverse [] = []
my_reverse (x :: xs) = my_reverse xs ++ [x]

my_map : (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: my_map f xs

my_vmap : (a -> b) -> Vect n a -> Vect n b
my_vmap f [] = []
my_vmap f (x :: xs) = f x :: my_vmap f xs


import Data.Vect

data StackCmd : Type -> Nat -> Nat -> Type where
  Push : Integer -> StackCmd () height (S height)
  Pop : StackCmd Integer (S height) height
  Top : StackCmd Integer (S height) (S height)

  GetStr : StackCmd String height height
  PutStr : String -> StackCmd () height height

  Pure : ty -> StackCmd ty height height
  (>>=) : StackCmd a height1 height2 ->
          (a -> StackCmd b height2 height3) ->
          StackCmd b height1 height3

data StackIO : Nat -> Type where
   Do : StackCmd a height1 height2 ->
        (a -> Inf (StackIO height2)) -> StackIO height1

namespace StackDo
  (>>=) : StackCmd a height1 height2 ->
         (a -> Inf (StackIO height2)) -> StackIO height1
  (>>=) = Do

runStack : (stk: Vect inHeight Integer) ->
            StackCmd ty inHeight outHeight ->
            IO (ty, Vect outHeight Integer)
runStack stk (Push val) = pure ((), val :: stk)
runStack (val :: stk) Pop = pure (val, stk)
runStack (val :: stk) Top = pure (val, val :: stk)
runStack stk GetStr = do x <- getLine
                         pure (x, stk)
runStack stk (PutStr x) = do putStr x
                             pure (() , stk)
runStack stk (Pure x) = pure (x, stk)
runStack stk (cmd >>= next)
  = do (cmdRes, newStk) <- runStack stk cmd
       runStack newStk (next cmdRes)

testAdd : StackCmd Integer 0 0
testAdd = do Push 10
             Push 20
             val1 <- Pop
             val2 <- Pop
             Pure (val1 + val2)

doAdd : StackCmd () (S (S height)) (S height)
doAdd = do val1 <- Pop
           val2 <- Pop
           Push (val1 + val2)

data Fuel = Dry | More (Lazy Fuel)

forever : Fuel
forever = More forever

run : Fuel -> Vect height Integer -> StackIO height -> IO ()
run Dry stk p = pure ()
run (More fuel) stk (Do c f) = do (res, newStk) <- runStack stk c
                                  run fuel newStk (f res)

data StkInput = Number Integer
              | Add

strToInput : String -> Maybe StkInput
strToInput "" = Nothing
strToInput "add" = Just Add
strToInput x = if all isDigit (unpack x)
                  then Just (Number (cast x))
                  else Nothing

mutual
  tryAdd : StackIO height
  tryAdd {height = S(S h)}= do doAdd
                               result <- Top
                               PutStr (show result ++ "\n")
                               stackCalc
  tryAdd = do PutStr "Fewer than two items on the stack \n"
              stackCalc

  stackCalc : StackIO height
  stackCalc = do PutStr "> "
                 input <- GetStr
                 case strToInput input of
                      Nothing => do PutStr "Invalid input\n"
                                    stackCalc
                      Just (Number x) => do Push x
                                            stackCalc
                      Just Add => tryAdd

main: IO ()
main = run forever [] stackCalc


module Data.Scientific

import Data.Precision

import Data.Fin
import Data.List
import Data.Vect

public export
data Sign = Positive
          | Negative

export
Eq Sign where
  Positive == Positive = True
  Negative == Negative = True
  _ == _ = False

export
Ord Sign where
  compare Positive Positive = EQ
  compare Positive Negative = GT
  compare Negative Positive = LT
  compare Negative Negative = EQ

public export
data Scientific : Type where
  SciZ : Scientific
  Sci : Sign -> Precision 10 n -> Scientific

export
Eq Scientific where
  SciZ == SciZ = True
  Sci sign prec == Sci sign' prec' = sign == sign' && eqPrecs prec prec'
  _ == _ = False

export
Ord Scientific where
  compare SciZ SciZ = EQ
  compare SciZ (Sci sign prec) =
    case sign of
         Positive => LT
         Negative => GT
  compare (Sci sign prec) SciZ =
    case sign of
         Positive => GT
         Negative => LT
  compare (Sci sign prec) (Sci sign' prec') =
    case compare sign sign' of
         LT => LT
         EQ => case sign of
                    Positive => comparePrecs prec prec'
                    Negative => comparePrecs prec' prec
         GT => GT

-- TODO: don't use Show?
export
Show Scientific where
  show SciZ = "0"
  show (Sci sign prec) = (++ show prec) $ case sign of
                                               Positive => ""
                                               Negative => "-"


-- --------------------------------------------------------------- [ Day06.idr ]
-- Module      : Data.Advent.Day06
-- Description : My solution to the Day 6 puzzle of the 2016 Advent of Code.
-- Copyright   : Copyright (c) 2016, Eric Bailey
-- License     : MIT
-- Link        : http://adventofcode.com/2016/day/6
-- --------------------------------------------------------------------- [ EOH ]
||| Day 6: Signals and Noise
module Data.Advent.Day06

import public Data.SortedMap

%access export

-- ----------------------------------------------------------- [ Generic Logic ]

main' : (String -> String) -> IO ()
main' f = either printLn (putStrLn . f) !(readFile "input/day06.txt")

decode' : (f : Nat -> Nat -> Bool) -> String -> String
decode' f = pack . map (fst . foldr1 go . frequencies') . transpose .
            map unpack . lines
  where
    go : (Char, Nat) -> (Char, Nat) -> (Char, Nat)
    go elem@(_,m) acc@(_,n) = if m `f` n then elem else acc
    frequencies' : Ord a => List a -> List (a, Nat)
    frequencies' = toList . foldr inc empty
      where
        inc : k -> SortedMap k Nat -> SortedMap k Nat
        inc k m = case lookup k m of
                       Nothing => insert k 1 m
                       Just v  => insert k (S v) $ delete k m

-- ---------------------------------------------------------------- [ Part One ]

namespace PartOne

    decode : String -> String
    decode = decode' (>)

    main : IO ()
    main = main' decode

-- ---------------------------------------------------------------- [ Part Two ]

namespace PartTwo

    decode : String -> String
    decode = decode' (<)

    main : IO ()
    main = main' PartTwo.decode

-- -------------------------------------------------------------------- [ Main ]

namespace Main

    main : IO ()
    main = putStr "Part One: " *> PartOne.main *>
           putStr "Part Two: " *> PartTwo.main

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


module GuardedRecursion

%default total

data Later : Type -> Type where
  next  : a -> Later a

compose : Later (a -> b) -> Later a -> Later b
compose (next t) (next u) = next (t u)

instance Functor Later where
  map f (next t) = next (f t)

instance Applicative Later where
  pure = next
  (next t) <$> (next u) = compose (next t) (next u)
{-
data Box : Type where
  Boxed   : Box
  Unboxed : Box

data GT : Box -> Type -> Type where
  Guard : (b : Box) -> a -> GT b a

instance Functor (GT b) where
  map f g = case g of
              Guard b a => Guard b (f a)
-}

partial
fix : (Later a -> a) -> a
fix f = f (next (fix f))

nextid : (u : Later a) -> ((next id) <$> u) = u
nextid (next x) = Refl

nextcompose : (s : Later (b -> c)) -> (t : Later (c -> b)) -> (u : Later c) -> ((next (.) <$> s) <$> t) <$> u = s <$> (t <$> u)
nextcompose (next s') (next t') (next u') = Refl

nextcompose' : (t : (a -> b)) -> (u : a) -> next t <$> next u = next (t u)
nextcompose' t' u' = Refl

nextright : (u : Later (a -> b)) -> (t : a) -> u <$> next t =  next(\g => g t) <$> u
nextright (next u') t = Refl

laterDist : Later (Later (a -> b)) -> Later (Later a -> Later b)
laterDist (next t) = next (t <$>)

nLater : Nat -> Type -> Type
nLater Z a = a
nLater (S n) a = Later (nLater n a)

nCompose : (n : Nat) -> nLater (S n) (a -> b) -> nLater (S n) a -> nLater (S n) b
nCompose Z t u = compose t u
nCompose (S n') (next t) (next u) = next (nCompose n' t u)

doubleCompose : Later (Later (a -> b)) -> Later (Later a) -> Later (Later b)
doubleCompose = nCompose 1

oneComposeIsCompose : (nCompose 0 t u) = compose t u
oneComposeIsCompose = Refl

twoComposeIsDoubleCompose : (nCompose 1 t u) = doubleCompose t u
twoComposeIsDoubleCompose = Refl

unsafeForce : Later a -> a
unsafeForce (next t) = t

app1 : Later (a -> b) -> a -> Later b
app1 f a = f <$> (next a)

app1' : nLater (S n) (a -> b) -> nLater n a -> nLater (S n) b
app1' {n} f a = nCompose n f (next a)

app1n : (n : Nat) -> nLater n (a -> b) -> a -> nLater n b
app1n (S Z) f a = f <$> (next a)
app1n (S n') (next f) a = next $ (app1n n' f a)

app1Eq : app1 f a = app1n 1 f a
app1Eq = Refl

app1Eq' : app1n 1 (next f) a = app1' {n = Z} (next f) a
app1Eq' = Refl

app2 : (a -> b) -> Later a -> Later b
app2 f (next a) = next (f a)

app2' : nLater n (a -> b) -> nLater (S n) a -> nLater (S n) b
app2' {n} f a = nCompose n (next f) a

app2n : (n : Nat) -> (a -> b) -> nLater n a -> nLater n b
app2n Z f a = f a
app2n (S Z) f (next a) = next (f a)
app2n (S n') f (next a) = next (app2n n' f a)

app2Eq : (eq : (next b) = a) -> app2 f a = app2n 1 f a
app2Eq = ?app2EqMeta

app2Eq' : (eq : (next b) = a) -> app2n 1 f a = app2' {n = Z} f a
app2Eq' = ?app2Eq'Meta

app3 : (a -> b) -> a -> Later b
app3 f a = next (f a)

app3' : nLater n (a -> b) -> nLater n a -> nLater (S n) b
app3' {n} f a = nCompose n (next f) (next a)

app3n : (n : Nat) -> (a -> b) -> a -> nLater n b
app3n Z f a = f a
app3n (S n') f a = next (app3n n' f a)

app4 : Later (a -> b) -> Later a -> Later b
app4 = nCompose 0

app4' : nLater (S n) (a -> b) -> nLater (S n) a -> nLater (S n) b
app4' {n} = nCompose n

app4n : (n : Nat) -> nLater (S n) (a -> b) -> nLater (S n) a -> nLater (S n) b
app4n n = app4' {n}

corecord Stream' : Type -> Type where
   hd : Stream' a -> a
   tl : Stream' a -> Later (Stream' a)
   constructor StreamCons

take' : (n : Nat) -> Stream' a -> Vect n a
take' Z _ = []
take' (S n) s = (hd s) :: (take' n (unsafeForce (tl s)))

partial
take'' : (n : Nat) -> Stream' a -> List a
take'' = fix(\t,n,s => case n of
                         Z    => []
                         S n' => (hd s) :: (unsafeForce ( ( t <$> (next n') ) <$> (tl s))))

partial
zeros : Stream' Nat
zeros = fix (\f => StreamCons 0 f)

partial
moreZeros : Stream' Nat
moreZeros = fix (\f => StreamCons 0 (app1 (app3 StreamCons 0) f))

partial
prepend : List a -> Stream' a -> Stream' a
prepend = fix (\p => \l => \s => case l of
                                   [] => s
                                   (x :: xs) => StreamCons x ((p <$> (next xs)) <$> (next s)))

{-
partial
prepend'Z : Vect Z a -> Stream' a -> Stream' a
prepend'Z = fix (\p, [], s => s)

prepend'S : Vect (S n) a -> Stream' a -> Stream' a
prepend'S = fix (\p, (x :: xs), s => StreamCons x (p <$> (next xs) <$> (next s)))
-}
partial
hMerge : Stream' a -> Stream' a -> Stream' a
hMerge = fix (\m => \xs => \ys => StreamCons (hd xs) (next (StreamCons (hd ys) (m <$> (tl xs) <$> (tl ys)))))

partial
hMerge' : Stream' a -> Stream' a -> Stream' a
hMerge' = fix (\m => \xs => \ys => StreamCons (hd xs) ((next StreamCons <$> next (hd ys)) <$> next ((m <$> (tl xs)) <$> (tl ys))))

partial
mergef : (a -> a -> Later (Stream' a) -> Stream' a) -> Stream' a -> Stream' a -> Stream' a
mergef f = fix (\m => \xs => \ys => f (hd xs) (hd ys) ((m <$> (tl xs)) <$> (tl ys)))

partial
mergef' : (a -> a -> Later (Stream' a) -> Stream' a) -> Stream' a -> Stream' a -> Stream' a
mergef' = fix (\m => \f => \xs => \ys => f (hd xs) (hd ys) (((m <$> (next f)) <$> (tl xs)) <$> (tl ys)))
{-
unguard : (GT Boxed a) -> a
unguard (Guard _ a) = a

partial
gMap : (a -> b) -> (GT x (Stream' a)) -> (GT x (Stream' b))
gMap = fix (\m, f, s => Guard x (StreamCons (map (f . hd) s)  ))

partial
gEven : (GT Boxed (Stream' a)) -> (GT Boxed (Stream' a))
-}
partial
sMap : (a -> b) -> Stream' a -> Stream' b
sMap = fix (\m => \f => \s => StreamCons (f (hd s)) ((m <$> (next f)) <$> (tl s)))

partial
sMap' : (a -> b) -> Stream' a -> Stream' b
sMap' = fix (\m => \f => \s => StreamCons (f (hd s)) (app4 (app1 m f) (tl s)))

partial
sMerge : Ord a => Stream' a -> Stream' a -> Stream' a
sMerge = fix (\m => \s => \t => StreamCons
                                 (if (hd s) <= (hd t) then hd s else hd t)
                                 (if (hd s) <= (hd t) then
                                     (if (hd t <= hd s) then
                                        app4 (app4 m (tl s)) (tl t)
                                     else
                                        app1 (app4 m (tl s)) t)
                                 else
                                    app4 (app1 m s) (tl t)))

partial
hamming : Stream' Nat
hamming = fix (\h => StreamCons 1
		            (((next sMerge) <$> ((next (sMap (\x => 2 * x)) <$> h))) <$>
                                               (((next sMerge) <$> (next (sMap (\x => 3 * x)) <$> h)) <$>
                                                                   (next (sMap (\x => 5 * x)) <$> h))))

partial
zipWith' : (a -> b -> c) -> Stream' a -> Stream' b -> Stream' c
zipWith' f = fix(\g => \s => \t => StreamCons (f (hd s) (hd t)) (g <$> (tl s) <$> (tl t)))

partial
zipWithNat : (Nat -> Nat -> Nat) -> Stream' Nat -> Stream' Nat -> Stream' Nat
zipWithNat = zipWith' {a=Nat} {b=Nat} {c=Nat}

partial
fib : Stream' Nat
fib = fix (\f => StreamCons 0 (app4 (app3 StreamCons 1) (app4' (app1' {n=1} (app3n 2 zipWithNat (+)) f) (app2 tl f))))

partial
nats : Stream' Nat
nats = fix (\n => StreamCons 0 ((next sMap <$> next S) <$> n))

partial tailtail : Stream' a -> Later (Later (Stream' a))
tailtail = fix(\t, s => (next tl) <$> (tl s))

hat : nLater (S n) (a -> b) -> (Later (nLater n a -> nLater n b))
hat = ?h

partial nats2 : Stream' Nat
nats2 = fix(\n => StreamCons 0 (app4 (app3 StreamCons 1) (app4 (hat {n=1} (app3n 2 sMap S)) (app2 tl n))))

partial bad : (Stream' Nat)
bad = fix(\b => b)

corecord Foo : Type where
  bar : Foo -> Bool
  baz : (f : Foo) -> (if bar f then (Later Foo) else Nat)

partial
alpha : Foo
alpha = fix (\a => MkFoo True (next alpha))

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

GuardedRecursion.app2EqMeta = proof
  intros
  rewrite eq
  compute
  refine Refl

GuardedRecursion.app2Eq'Meta = proof
  intros
  rewrite eq
  compute
  refine Refl


import Data.Vect
import Control.Monad.State

-- Page 332

-- Exercise 1
update : (stateType -> stateType) -> State stateType ()
update f = do current <- get
              put (f current)

-- Exercise 2
data Tree a = Empty | Node (Tree a) a (Tree a)

testTree : Tree String
testTree = Node (Node (Node Empty "Jim" Empty) "Fred"
                     (Node Empty "Sheila" Empty)) "Alice"
               (Node Empty "Bob" (Node Empty "Eve" Empty))

countEmpty : Tree a -> State Nat ()
countEmpty Empty = do
  current <- get
  put (S current)

countEmpty (Node left val right) = do
  countEmpty left
  countEmpty right

-- Exercise 3
countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty = do
  (empties, nodes) <- get
  put (S empties, nodes)
countEmptyNode (Node left val right) = do
  countEmptyNode left
  (empties, nodes) <- get
  put (empties, S nodes)
  countEmptyNode right

-- Page 350
record Score where
       constructor MkScore
       correct : Nat
       attempted : Nat

record GameState where
       constructor MkGameState
       score : Score
       difficulty : Int

data Command : Type -> Type where
  PutStr : String -> Command ()
  GetLine : Command String

  GetRandom : Command Int
  GetGameState : Command GameState
  PutGameState : GameState -> Command ()

  Pure : ty -> Command ty
  Bind : Command a -> (a -> Command b) -> Command b

-- Exercise 1

-- Exercise 2
mutual
  Functor Command where
    map func x = Bind x (\a => Pure (func a))

  Applicative Command where
    pure = Pure
    (<*>) f x = do f' <- f
                   x' <- x
                   Pure (f' x')

  Monad Command where
    (>>=) = Bind

-- Exercise 3
record Votes where
      constructor MkVotes
      upvotes : Integer
      downvotes : Integer

record Article where
      constructor MkArticle
      title : String
      url : String
      score : Votes

initPage : (title : String) -> (url : String) -> Article
initPage title url = MkArticle title url (MkVotes 0 0)

getScore : Article -> Integer
getScore (MkArticle title url (MkVotes upvotes downvotes)) = upvotes - downvotes

badSite : Article
badSite = MkArticle "Bad Page" "http://example.com/bad" (MkVotes 5 47)
goodSite : Article
goodSite = MkArticle "Good Page" "http://example.com/good" (MkVotes 101 7)

-- Exercise 4
addUpvote : Article -> Article
addUpvote = record {score->upvotes $= (+1)}

addDownvote : Article -> Article
addDownvote = record {score -> downvotes $= (+1)}

-- Page 362

-- Exercise 1
namespace ex1
  data DoorState = DoorClosed | DoorOpen

  data DoorCmd : Type -> DoorState -> DoorState -> Type where
    Open : DoorCmd     () DoorClosed DoorOpen
    Close : DoorCmd    () DoorOpen   DoorClosed
    RingBell : DoorCmd () ds         ds

    -- Pure : ty -> DoorCmd ty state state
    (>>=) : DoorCmd a state1 state2
            -> (a -> DoorCmd b state2 state3)
            -> DoorCmd b state1 state3

  doorProg : DoorCmd () DoorClosed DoorClosed
  doorProg = do RingBell
                Open
                RingBell
                Close

-- Exercise 2
namespace ex2
  data GuessCmd : Type -> Nat -> Nat -> Type where
    Try : Integer -> GuessCmd Ordering (S k) k
    Pure : ty -> GuessCmd ty state state
    (>>=) : GuessCmd a state1 state2
            -> (a -> GuessCmd b state2 state3)
            -> GuessCmd b state1 state3

  threeGuesses: GuessCmd () 3 0
  threeGuesses = do Try 10
                    Try 20
                    Try 15
                    Pure ()

  -- This shouldn't compile
  -- noGuesses : GuessCmd () 0 0
  -- noGuesses = do Try 10
  --                Pure ()

-- Exercise 3
namespace ex3
  data Matter = Solid | Liquid | Gas

  data MatterCmd : Type -> Matter -> Matter -> Type where
    Melt :     MatterCmd () Solid  Liquid
    Boil :     MatterCmd () Liquid Gas
    Condense : MatterCmd () Gas    Liquid
    Freeze :   MatterCmd () Liquid Solid

    Pure : ty -> MatterCmd ty state state
    (>>=) : MatterCmd a m1 m2
            -> (a -> MatterCmd b m2 m3)
            -> MatterCmd b m1 m3

  iceSteam : MatterCmd () Solid Gas
  iceSteam = do Melt
                Boil
  steamIce : MatterCmd () Gas Solid
  steamIce = do Condense
                Freeze


import Data.Vect
import Data.Fin

Vect_ext : (v : Vect n a) -> (w : Vect n a) -> ((i : Fin n) -> index i v = index i w)
  -> v = w

Weird : (v: Vect n a) -> v = v
Weird v =  Vect_ext ?hole0 ?hole1 ?hole2

f : Bool -> Nat
f True = 0
f True = ?help
f False = 1


module Sub03Apply54x30

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(18x+10) --A[6,-4]->C[4,-4]--> 3(8x+3)
ac54x30To24x9 :
  (l:Nat) -> P (S (S (S (plus (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))
                         (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) 2
    -> P (S (S (S (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))))) 2
ac54x30To24x9 l prf =
  let prf2 = lvDown (S (S (S (plus (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))
                         (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) 2
                    prf in
    let prf3 = ac54x30To24x9' l prf2 in lvDown (S (S (S (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))))) 3 prf3

export
apply54x30 : P (S (S (S (plus (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))
                         (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (plus (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))
                            (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))))),
         P m 2))
apply54x30 {l} col = let col2 = ac54x30To24x9 l col in ((S (S (S (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))))) ** (lte54x30 l, col2)) where
  lte54x30 : (l:Nat) -> LTE (S (S (S (S (plus (plus (plus l l) (plus l l)) (plus (plus l l) (plus l l)))))))
                            (S (S (S (plus (plus (plus (plus (plus l l) l) (S (plus (plus l l) l))) (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l))))))
                                           (S (S (plus (plus (plus l l) l) (S (plus (plus l l) l)))))))))
  lte54x30 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte54x30 (S k) = let lemma = lte54x30 k in
    rewrite (sym (plusSuccRightSucc k k)) in
    rewrite (sym (plusSuccRightSucc (plus k k) (S (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) (plus k k))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (S (S (S (plus (plus k k) (plus k k))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (S (S (plus (plus k k) (plus k k)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (S (plus (plus k k) (plus k k))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) (plus k k)) (plus (plus k k) (plus k k)))) in
    rewrite (sym (plusSuccRightSucc (plus k k) k)) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (S (plus (plus k k) k)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (S (plus (plus k k) k))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus k k) k) (S (plus (plus k k) k)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))  (S (S (S (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))  (S (S (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))  (S (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))  (S (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))  (S (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus k k) k) (S (plus (plus k k) k))) (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))  (S (S (plus (plus (plus k k) k) (S (plus (plus k k) k))))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module Shape_abs

export
data Shape = Triangle Double Double
           | Rectangle Double Double
           | Circle Double

export
triangle : Double -> Double -> Shape
triangle = Triangle

export
rectangle : Double -> Double -> Shape
rectangle = Rectangle

export
circle : Double -> Shape
circle = Circle


import Data.Vect
import Data.Vect.Views

total
mergeSort : Ord a => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (ys ++ zs) | SplitRecPair ysrec zsrec
      = merge (mergeSort ys | ysrec)
              (mergeSort zs | zsrec)

testList : Int -> Int -> List Int -> List Int
testList 0 seed acc = acc
-- Need to explicitly mod since different back ends overflow differently
testList x seed acc = let seed' = (seed * 12345 + 768) `mod` 65536 in
                          testList (x - 1) seed'
                               ((seed' `mod` 100) :: acc)

myhead : List a -> a
myhead (x :: xs) = x

main : IO ()
main = do let list = fromList (testList 100 12345 [])
          putStrLn "Sorting list"
          let list' = mergeSort list
          printLn list'


module MonadLogic

-- Based on http://okmij.org/ftp/papers/LogicT.pdf
-- http://hackage.haskell.org/package/logict-0.7.0.1/docs/Control-Monad-Logic.html

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

interface Monad m => MonadPlus (m : Type -> Type) where
    mplus : m a -> m a -> m a
    mzero : m a

interface MonadPlus m => MonadLogic (m : Type -> Type) where
  msplit : m a -> m (Maybe (a, () -> m a))
  interleave : m a -> m a -> m a
  bind : m a -> (a -> m b) -> m b
  ifte : m a -> (a -> m b) -> m b -> m b
  once : m a -> m a

reflect : MonadLogic m => Maybe (a, () -> m a) -> m a
reflect Nothing = mzero
reflect (Just (a, fk)) = pure a `mplus` (fk ())

interleave' : MonadLogic m => m a -> m a -> m a
interleave' m1 m2 = do r <- msplit m1
                       case r of
                        Nothing => m2
                        Just (a, fk) => (pure a) `mplus` (interleave' m2 (fk ()))

bind' : MonadLogic m => m a -> (a -> m b) -> m b
bind' ma f = do r <- msplit ma
                case r of
                 Nothing => mzero
                 Just (a, fk) => interleave (f a) ((fk ()) `bind'` f)

ifte' : MonadLogic m => m a -> (a -> m b) -> m b -> m b
ifte' t th el = do r <- msplit t
                   case r of
                    Nothing => el
                    Just (a, fk) => (th a) `mplus` ((fk ()) >>= th)

once' : MonadLogic m => m a -> m a
once' m = do r <- msplit m
             case r of
               Nothing => mzero
               Just (a, _) => pure a

data LogicT : (m : Type -> Type) -> (a : Type) -> Type where
    LT : ({r : Type} -> (a -> (() -> m r) -> m r) -> (() -> m r) -> m r) -> LogicT m a

Functor (LogicT m) where
  map f (LT g) = LT $ \sk, fk => g (sk . f) fk

Applicative (LogicT m) where
  pure a = LT $ \sk, fk => sk a fk
  (LT f) <*> (LT g) = LT $ \sk, fk => f (\sk', fk' => g (sk . sk') fk') fk

Monad (LogicT m) where
  (LT g) >>= f = LT $ \sk, fk => g (\a, fk' => let (LT g') = f a in g' sk fk') fk

MonadPlus (LogicT m) where
  mzero = LT $ \sk, fk => fk ()
  mplus (LT f) (LT f') = LT $ \sk, fk => f sk (\() => f' sk fk)

MonadTrans LogicT where
  lift m = LT $ \sk, fk => m >>= \a => sk a fk

Monad m => MonadLogic (LogicT m) where
  msplit (LT f) = lift $ f (\a, fk => pure $ Just (a, \() => lift (fk ()) >>= reflect)) (\() => pure Nothing)
  interleave = interleave'
  bind = bind'
  ifte = ifte'
  once = once'

observe : Monad m => Nat -> LogicT m a -> m (List a)
observe Z _ = pure []
observe (S n) m = let (LT f) = msplit m in f sk (\() => pure [])
  where
    sk : {a : Type, m : Type -> Type} -> Monad m => Maybe (a, () -> LogicT m a) -> (() -> m (List a)) -> m (List a)
    sk Nothing fk = pure []
    sk (Just (a, fk')) fk = map (\xs => a :: xs) (observe n (fk' ()))

ones : MonadPlus m => Int -> m Int
ones n = if n <= 0 then mzero else (pure 1) `mplus` (ones (n - 1))

zeros : MonadPlus m => Int -> m Int
zeros n = if n <= 0 then mzero else (pure 0) `mplus` (zeros (n - 1))

test : List (List Int)
test = observe 10 (ones 5 `interleave` zeros 5)


module Linear

public export
data Usage = Once | Many

public export
data Lin : (Type -> Type) -> Usage -> Type -> Type where
     Pure : (1 x : a) -> Lin m usage a
     Lift : (1 x : m a) -> Lin m Many a
     BindOnce : (1 act : Lin m Once a) ->
                (1 k : (1 x : a) -> Lin m t b) -> Lin m t b
     BindMany : (1 act : Lin m Many a) ->
                (1 k : (x : a) -> Lin m t b) -> Lin m t b

public export
data Unrestricted : Type -> Type where
     MkUn : (x : a) -> Unrestricted a

export
pure : (1 x : a) -> Lin m usage a
pure = Pure

export
lift : (1 x : m a) -> Lin m Many a
lift = Lift

public export
contType : (Type -> Type) -> Usage -> Usage -> Type -> Type -> Type
contType m Once q a b = (1 x : a) -> Lin m q b
contType m Many q a b = (x : a) -> Lin m q b

public export
(>>=) : {p : _} ->
        (1 f : Lin m p a) -> (1 k : contType m p q a b) -> Lin m q b
(>>=) {p=Once} = BindOnce
(>>=) {p=Many} = BindMany

export
run : Monad m => Lin m usage t -> m t
run (Pure x) = pure x
run (Lift p) = p
run (BindOnce act k)
    = do act' <- run act
         run (k act')
run (BindMany act k)
    = do act' <- run act
         run (k act')

public export
One : (Type -> Type) -> Type -> Type
One m = Lin m Once

public export
Any : (Type -> Type) -> Type -> Type
Any m = Lin m Many

{-
data DoorState = Closed | Open

data Door : DoorState -> Type where
     MkDoor : (isOpen : Bool) -> Door (if isOpen then Open else Closed)

newDoor    : One m (Door Closed)
knock      : (1 d : Door t)      -> One m (Door t)
openDoor   : (1 d : Door Closed) -> One m (Res Bool (\ok => Door (if ok then Open else Closed)))
closeDoor  : (1 d : Door Open)   -> One m (Door Closed)
deleteDoor : (1 d : Door Closed) -> Any m ()

doorProg : Any m ()
doorProg
    = do d <- newDoor
         ok @@ d' <- openDoor d
         d'' <- knock d'
         if ok
            then ?doorOK
            else ?doorBad
            -}


module Main

import Data.Vect
import Data.Fin

test : DecEq a => a -> a -> Bool
test i1 i2 with (decEq i1 i2)
  test i1 i1 | Yes Refl = True
  test i1 i2 | No p = False

main : IO ()
main = do
-- Primitives
  putStrLn . show $ test (the Int 3) (the Int 3)
  putStrLn . show $ test (the Integer 3) (the Integer 4)
  putStrLn . show $ test "hello" "hello"
  putStrLn . show $ test "hello" "world"
  putStrLn . show $ test (the Char '\0') (the Char '\0')
  putStrLn . show $ test (the Char '\1') (the Char '\2')
  putStrLn . show $ test """""" ""
  putStrLn . show $ test """"hello"""" "\"hello\""
  putStrLn . show $ test """""hello""""" "\"\"hello\"\""
  putStrLn . show $ test """""""""" "\"\"\"\""
-- Non-primitives
  -- Vect
  putStrLn . show $
    test (the (Vect _ Int) [1,2,3]) (the (Vect _ Int) [1,2,3])
  putStrLn . show $
    test (the (Vect _ Int) [1,2,3]) (the (Vect _ Int) [1,2,4])
  -- List
  putStrLn . show $
    test (the (List Int) [1,2,3]) (the (List Int) [1,2,3])
  putStrLn . show $
    test (the (List Int) [1,2,3]) (the (List Int) [1,2])
  putStrLn . show $
    test (the (List Int) [1,2,3]) (the (List Int) [1,2,4])
  -- Tuple
  putStrLn . show $
    test (the (Int, Int) (1, 1)) (the (Int, Int) (1, 1))
  putStrLn . show $
    test (the (Int, Int) (1, 2)) (the (Int, Int) (1, 1))
  -- Unit
  putStrLn . show $ test () ()
  -- Booleans
  putStrLn . show $ test True True
  putStrLn . show $ test True False
  -- Maybe
  putStrLn . show $ test (Just "hello") (Just "hello")
  putStrLn . show $ test (Just "hello") (Just "world")
  putStrLn . show $ test (Just "hello") Nothing
  -- Either
  putStrLn . show $ test (the (Either String Bool) (Left "hello"))
                         (the (Either String Bool) (Left "hello"))
  putStrLn . show $ test (the (Either String Bool) (Left "hello"))
                         (the (Either String Bool) (Left "world"))
  putStrLn . show $ test (Left "hello") (Right "world")
  putStrLn . show $ test (Left "hello") (Right False)
  -- Fin
  putStrLn . show $ test (the (Fin (S (S (S (Z))))) (FS (FS (FZ))))
                         (the (Fin (S (S (S (Z))))) (FS (FS (FZ))))
  putStrLn . show $ test (the (Fin (S (S (S (Z))))) (FS (FS (FZ))))
                         (the (Fin (S (S (S (Z))))) (FS (FZ)))
  -- Nat
  putStrLn . show $ test (S (S (S Z))) (S (S (S Z)))
  putStrLn . show $ test (S (S (S Z))) (S (S Z))


module Cast

%default total

{-
  interface Cast from to where
    caset : (orig : from) -> to

-}

Cast (Maybe elem) (List elem) where
  cast Nothing = []
  cast (Just x) = [x]

foo : List Integer
foo = cast (Just 100)

bar : List Integer
bar = cast (the (Maybe Integer) Nothing)

Cast (List elem) (Maybe elem) where
  cast [] = Nothing
  cast (x :: xs) = Just x

baz : Maybe Int
baz = cast  (the (List Int) [99])

quux : Maybe Int
quux = cast (the (List Int) [])

-- there is nothing special about the Cast interface. We can define our own version

interface Mould from to where
  mould : (oig : from) -> to

Mould (Maybe elem) (List elem) where
  mould Nothing = []
  mould (Just x) = [x]

foofoo : List String
foofoo = mould (the (Maybe String) (Just "Hello"))

barbar : List String
barbar = mould (the (Maybe String) Nothing)

Mould (List elem) (Maybe elem) where
  mould [] = Nothing
  mould (x :: xs) = Just x

bazbaz : Maybe String
bazbaz = mould (the (List String) ["world"])

quuxquux : Maybe String
quuxquux = mould (the (List String) [])


import DataStore
import Shape

testStore : DataStore (SString .+. SInt)
testStore = addToStore ("First", 1) $
            addToStore ("Second", 2) $
            empty

getValues : DataStore (SString .+. valSchema) -> List (SchemaType valSchema)
getValues x with (storeView x)
  getValues x | SNil = []
  getValues (addToStore (key, value) store) | (SAdd rec) = value :: getValues store

area : Shape -> Double
area s with (shapeView s)
  area (triangle base height) | (STriangle base height) = 0.5 * base * height
  area (rectangle width height) | (SRectangle width height) = width * height
  area (circle radius) | (SCircle radius) = pi * radius * radius


module Calc.Sub

%default total

export
subtract : Int -> Int -> Int
subtract x y = x - y


import Data.Vect

Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)

TupleVect : (n : Nat) -> (ty : Type) -> Type
TupleVect Z ty = ()
TupleVect (S k) ty = (ty, TupleVect k ty)

test : TupleVect 4 Nat
test = (1, 2, 3, 4, ())


import Data.Binary
import Data.Binary.Digit
import Data.Fin
import Data.List
import Data.List1
import Data.Nat
import Data.Vect
import Data.String
import Data.String.Parser

import System.File

Show Digit where
  show I = "1"
  show O = "0"

Algorithm : Type
Algorithm = Vect 512 Bool

Image : Nat -> Type
Image n = Vect n (Vect n Bool)

showImg : Image n -> String
showImg n = fastAppend $ intersperse "\n" $ toList $ (\r => pack $ toList $ (\b => if b then '#' else '.') <$> r) <$> n

Input : Nat -> Type
Input n = (Algorithm, Image n)

pixelParser : Parser Bool
pixelParser = char '.' $> False <|> char '#' $> True

parser : Parser (n ** Input n)
parser = do alg <- ntimes 512 pixelParser
            spaces
            row <- some pixelParser <* char '\n'
            let n = length row
            Just v <- pure $ toVect n row
              | Nothing => fail "not length"
            Yes ItIsSucc <- pure $ isItSucc n
              | No _ => fail "Row is zero"
            vs <- ntimes (pred n) ((ntimes n pixelParser) <* char '\n')
            pure $ MkDPair n (alg, v :: vs)

grow : Bool -> (n : Nat) -> Image n -> Image (4 + n)
grow d n img = let gr = (flip snoc) d . (flip snoc) d . (::) d . (::) d <$> img
                   emptyrow = replicate (4 + n) d in
                   (flip snoc) emptyrow $ (flip snoc) emptyrow $ (::) emptyrow $ (::) emptyrow $ gr

shrink : {n : Nat} -> Image (4 + n) -> Image (2 + n)
shrink = map (init . tail) . init . tail

decFin : Fin n -> Fin (S n)
decFin FZ = FZ
decFin (FS x) = weaken $ weaken x

neighbours : Fin n -> Fin n -> List (Fin (S n), Fin (S n))
neighbours x y = let xs = [ decFin x, weaken x, shift 1 x ]
                     ys = [ decFin y, weaken y, shift 1 y ] in
                     join $ (\y => (,y) <$> xs) <$> ys

getNumber : Image n -> List (Fin n, Fin n) -> Nat
getNumber img l = toNat $ reverse $ (\b => if b then I else O) <$> (\(x, y) => index x $ index y img) <$> l

lookupAlg : Algorithm -> Nat -> Bool
lookupAlg alg n = case natToFin n 512 of
                       Nothing => False
                       (Just i) => index i alg

enhance : {n : Nat} -> Algorithm -> ((k : Nat) -> Image k -> Image (4 + k)) -> Image n -> Image (2 + n)
enhance alg g img = let img' = g n img
                        indices = map (shift 1) $ forget $ allFins (S n)
                        positions = join $ (\x => (x,) <$> indices) <$> indices
                        enhanced = foldl (\i => \(x, y) => let k = getNumber img' $ neighbours x y
                                                               b = lookupAlg alg k in
                                                               updateAt (weaken y) (replaceAt (weaken x) b) i) img' positions in
                        shrink enhanced

enhanceN : {n : Nat} -> Nat -> Algorithm -> (Bool -> (k : Nat) -> Image k -> Image (4 + k)) -> Image n -> (m ** Image m)
enhanceN 0 alg g img = MkDPair n img
enhanceN (S s) alg g img = let en = enhance alg (g ((modNatNZ (S s) 2 SIsNonZero) == 1)) img in enhanceN {n = (S (S n))} s alg g en

countLit : Image n -> Nat
countLit = sum . map (count id)

part1 : {n : Nat} -> Input n -> IO String
part1 (alg, img) = pure $ show $ countLit $ enhance alg (grow True) $ enhance alg (grow False) img

part2 : {n : Nat} -> Input n -> IO String
part2 (alg, img) = let MkDPair _ enn = enhanceN 50 alg grow img in
                       pure $ show $ countLit $ enn

main : IO ()
main = do Right input <- readFile "input.txt"
            | Left err => printLn err
          Right (MkDPair n a, _) <- pure $ parse parser input
            | Left err => printLn err
          part1 a >>= putStrLn
          part2 a >>= putStrLn


module Part2.Sec6_3b_datastore
import Data.Vect
import Util.MiniParser

%default total

infixr 5 .+.

||| ADT that represents parsed schema
data Schema = SString
            | SInt
            | (.+.) Schema Schema

||| Type level function that maps Schema to actual type, composite schema
||| is mapped to a tuple.
SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

{-
idris repl:
*src/Part2/Sec6_3_datastore> SchemaType (SInt .+. SString .+. SInt)
(Int, String, Int) : Type
-}

{- This needs schema type parameter to cary the schema information around -}
||| Type representing user commands (DSL)
data Command : Schema -> Type where
           -- works in context of old schema, polymorphic in the return type
           SetSchema : (newschema : Schema) -> Command schema
           Add : SchemaType schema -> Command schema
           Get : Integer -> Command schema
           Quit : Command schema

{- This is powerful. Some of this can be mimicked in Haskell, e.g.
`singletons` library could generate type family Schema :: DataStore -> Schema from
something like `data DataStore = DataStore{ schema :: Schema}`
but cross referencing between field values and field types is beyond what I can
do in Haskell, also record 'getters' are not automatically lifted by `DataKinds` -}
record DataStore where
       constructor MkData
       schema : Schema
       size : Nat
       items : Vect size (SchemaType schema)

{-
teststore = MkData (SInt .+. SString .+. SInt) 1 [(2, "Two", 42)]
-}

{- helper methods used with DataStore, note cool use of record getter at type level -}

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

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

{- Changed from the book version to emphasize type safe retrieval -}
retrieve : (pos : Integer) -> (store : DataStore) -> Maybe (SchemaType (schema store))
retrieve pos store =
      integerToFin pos (size store) >>= (\i => pure (index i (items store)))

getEntry : (pos : Integer) -> (store : DataStore) -> Maybe (String, DataStore)
getEntry pos store = case retrieve pos store of
             Nothing => Just ("Out of range\n", store)
             Just rec => Just ((display rec) ++ "\n", store)

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

{- Parsers -}
sstring : Parser Schema
sstring =  string "String" *> pure SString

sint : Parser Schema
sint = string "Int" *> pure SInt

scolumn : Parser Schema
scolumn = sstring <|> sint

covering
schemaBody : Parser Schema
schemaBody = do
     col  <- scolumn
     _    <- optional spaces
     rest <- optional schemaBody
     case rest of
        Nothing =>  pure col
        Just rest => pure (col .+. rest)

{- Note Idris has no problem with this name being overloaded -}
covering
schema : Parser Schema
schema = string "schema" *> spaces *> schemaBody

covering
schemaTypeBody : (sch : Schema) -> Parser (SchemaType sch)
schemaTypeBody SString = between (char '"') (char '"')
schemaTypeBody SInt = decimalInt
schemaTypeBody (schemal .+. schemar) = do
                parsed1 <- schemaTypeBody schemal
                _    <- spaces
                parsed2 <- schemaTypeBody schemar
                pure (parsed1, parsed2)

covering
schemaType : (sch : Schema) -> Parser (SchemaType sch)
schemaType sch = string "add" *> spaces *> schemaTypeBody sch

covering
command : (sc : Schema) -> Parser (Command sc)
command sc = (SetSchema <$> schema) <|>
             (string "quit" *> pure Quit) <|>
             (string "get") *> spaces *> (Get <$> decimalInteger) <|>
             (Add <$> schemaType sc)

{- End Parsers -}

||| replWith implementation method
covering
processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input
          = case parseAll (command (schema store)) input of
                 Left msg => Just ("Invalid command: " ++ msg ++ "\n", store)
                 Right (Add item) =>
                    Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
                 Right (Get pos) => getEntry pos store
                 Right (SetSchema schema') => case setSchema store schema' of
                        Nothing => Just ("Can't update schema\n", store)
                        Just store' => Just ("OK\n", store')
                 Right Quit => Nothing

initDs : DataStore
initDs = MkData SString _ []

testDs : DataStore
testDs = MkData (SInt .+. SString) _ []

{- To execute in repl, idrs repl from src folder, :l this file and use :exec sec6_3b -}
export
covering
sec6_3b : IO ()
sec6_3b = replWith initDs "Command: " processInput


module Main

import Effect.State

data Tree a = Leaf
            | Node (Tree a) a (Tree a)

flattenTree : Tree a -> List a
flattenTree Leaf = []
flattenTree (Node l x r) = flattenTree l ++ (x :: flattenTree r)

testTree : Tree String
testTree = Node (Node Leaf "One" (Node Leaf "Two" Leaf))
                "Three"
                (Node (Node Leaf "Four" Leaf) "Five" Leaf)

data Tag : Type where
data Leaves : Type where

label : Tree a -> { [Leaves ::: STATE Int, Tag ::: STATE Int] }
                  Eff m (Tree (Int, a))
label Leaf = do Leaves :- update (+1)
                return Leaf
label (Node l x r) = do l' <- label l
                        lbl <- Tag :- get
                        Tag :- put (lbl + 1)
                        r' <- label r
                        return (Node l' (lbl, x) r')

main : IO ()
main = do -- let ([Leaves := l, _], x)
          let x = runPureInit [default, Tag := 1] (label testTree)
          print (flattenTree x)

{-
label Leaf = return Leaf
label (Node l x r) = do l' <- label l
                        lbl <- get
                        put (lbl + 1)
                        r' <- label r
                        return (Node l' (lbl, x) r')
-}


||| Spec: https://webassembly.github.io/spec/core/syntax/values.html#integers
module WebAssembly.Structure.Values.Integers

-- Definition

-- This module only provides a rough over-approximation of WebAssembly's integer-data-types
-- Unsigned and uninterpreted integers are modelled by Idris' (unbounded) natural numbers
-- Signed integers are modelles by Idris' (unbounded) integers

||| Unsigned Integer 32 Bit
public export
U32 : Type
U32 = Nat

||| Signed Interer 32 Bit
public export
S32 : Type
S32 = Integer

||| Uninterpreted Integer 32 Bit
public export
I32 : Type
I32 = Nat

||| Unsigned Integer 32 Bit
public export
U64 : Type
U64 = Nat

||| Signed Interer 32 Bit
public export
S64 : Type
S64 = Integer

||| Uninterpreted Integer 32 Bit
public export
I64 : Type
I64 = Nat


module Depling.Pull

import Depling
import Data.Fin
import Data.Vect
import Utils

mutual
	total
	pull_ℙ : Fin (S n) -> DAST (a + (S n)) -> Maybe (DAST (a + n))
	pull_ℙ {a=Z} pv ast = pull pv ast
	pull_ℙ {a=S a} {n} pv ast =
		assert_total $
		replace {P=Maybe . DAST} (sym $ plusSuccRightSucc _ _) $
		pull_ℙ (FS pv) $
		replace (plusSuccRightSucc _ _) $
		ast

	total
	export
	pull : Fin (S n) -> DAST (S n) -> Maybe (DAST n)
	pull pv (ʌ v) = case fcompare v pv of
		FLT lt => Just $ ʌ $ finDown v {lt}
		FEQ eq => Nothing
		FGT gt => Just $ ʌ $ finD v {gt}
	pull pv (λ at b) = do
		at' <- pull pv at
		b' <- pull (FS pv) b
		pure $ λ at' b'
	pull pv (λT at rt) = do
		at' <- pull pv at
		rt' <- pull (FS pv) rt
		pure $ λT at' rt'
	pull pv (f =!= a) = do
		f' <- pull pv f
		a' <- pull pv a
		pure $ f' =!= a'
	pull pv 𝕋 = Just 𝕋
	pull pv (𝔽 at rt b) = do
		at' <- pull          pv  at
		rt' <- pull (FS$     pv) rt
		b'  <- pull (FS$ FS$ pv) b
		pure $ 𝔽 at' rt' b'
	pull pv (𝕌 n t) = do
		t' <- pull pv t
		pure $ 𝕌 n t'
	pull pv (ℂ cn as) = do
		as' <- sequence $ map (assert_total $ pull pv) as
		pure $ ℂ cn as'
	pull pv (ℙ v cn t f) = do
		v' <- pull pv v
		t' <- pull_ℙ pv t
		f' <- pull pv f
		pure $ ℙ v' cn t' f'
	pull pv (𝔹 t) = do
		t' <- pull pv t
		pure $ 𝔹 t'


module Derive.ShowTests

import Pruviloj
import Derive.Show

namespace TestDecls
  -- Can't derive Eq for this one!
  data SimpleFun a b = MkSimpleFun (a -> b)

  data MyNat = MyZ | MyS MyNat

  data MyList a = Nil | (::) a (MyList a)

  namespace V
    data MyVect : MyNat -> Type -> Type where
      Nil : MyVect MyZ a
      (::) : a -> MyVect n a -> MyVect (MyS n) a

  -- All elements of this should be Eq, because it's for runtime and the Nat is erased
  data CompileTimeNat : Type where
    MkCTN : .(n : Nat) -> CompileTimeNat

decl syntax derive Show for {n} = %runElab (deriveShow `{n})

derive Show for MyNat
derive Show for MyList
derive Show for MyVect
derive Show for CompileTimeNat

namespace Tests
  test1 : show (with V [1,2,3]) = "(::) 1 ((::) 2 ((::) 3 Nil))"
  test1 = Refl

  test2 : show (MyS (MyS MyZ)) = "MyS (MyS MyZ)"
  test2 = Refl

  test3 : show (the (MyVect _ Integer) [1,2,3]) = show (the (MyList Integer) [1,2,3])
  test3 = Refl

  test4 : show (MkCTN 45) = "MkCTN _"
  test4 = Refl


module Main

import Data.Vect

%default total

data CoNat
    = Co Nat
    | Infinity

S : CoNat -> CoNat
S (Co n)   = Co (S n)
S Infinity = Infinity

Sn_notzero : Main.S n = Co 0 -> Void
Sn_notzero = believe_me

S_Co_not_Inf : Main.S (Co n) = Infinity -> Void
S_Co_not_Inf = believe_me

S_inj : (n : CoNat) -> (m : CoNat) -> Main.S n = Main.S m -> n = m
S_inj (Co n)   (Co _)   Refl = Refl
S_inj (Co n)   Infinity p    = void (S_Co_not_Inf p)
S_inj Infinity (Co m)   p    = void (S_Co_not_Inf (sym p))
S_inj Infinity Infinity Refl = Refl

swap : {n : Nat} -> Vect n a -> Vect n a
swap Nil            = Nil
swap (x :: Nil)     = x :: Nil
swap (x :: y :: xs) = (y :: x :: (swap xs))

main : IO ()
main = printLn (swap [1,2,3,4,5])


||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#globals
module WebAssembly.Structure.Modules.Globals

import WebAssembly.Structure.Types
import WebAssembly.Structure.Instructions

import Decidable.Equality

-- Definition

public export
record Global where
  constructor MkGlobal
  type : GlobalType
  init : Expr

-- Equality

total public export
lemma_global__type_injective : ((t1 = t2) -> Void) -> (MkGlobal t1 i1 = MkGlobal t2 i2) -> Void
lemma_global__type_injective t1_not_t2 Refl = t1_not_t2 Refl

total public export
lemma_global__init_injective : ((i1 = i2) -> Void) -> (MkGlobal t1 i1 = MkGlobal t2 i2) -> Void
lemma_global__init_injective i1_not_i2 Refl = i1_not_i2 Refl

-- Decidable Equality

public export
implementation DecEq Global where
  decEq (MkGlobal t1 i1) (MkGlobal t2 i2) = case decEq t1 t2 of
    No t1_not_t2 => No $ lemma_global__type_injective t1_not_t2
    Yes Refl     => case decEq i1 i2 of
      No i1_not_i2 => No $ lemma_global__init_injective i1_not_i2
      Yes Refl     => Yes Refl


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

import System.File

data Bracket = P | S | B | L
Eq Bracket where
  P == P = True
  S == S = True
  B == B = True
  L == L = True
  _ == _ = False
data Chunk = Open Bracket | Close Bracket

findCorrupted : List Bracket -> List Chunk -> Maybe Bracket
findCorrupted s [] = Nothing
findCorrupted s ((Open x) :: xs) = findCorrupted (x :: s)  xs
findCorrupted [] ((Close x) :: xs) = Just x
findCorrupted (y :: ys) ((Close x) :: xs) = if x == y
                                       then findCorrupted ys xs
                                       else Just x

score : Bracket -> Nat
score P = 3
score S = 57
score B = 1197
score L = 25137

parseChunk : Char -> Maybe Chunk
parseChunk '(' = Just $ Open P
parseChunk ')' = Just $ Close P
parseChunk '[' = Just $ Open S
parseChunk ']' = Just $ Close S
parseChunk '{' = Just $ Open B
parseChunk '}' = Just $ Close B
parseChunk '<' = Just $ Open L
parseChunk '>' = Just $ Close L
parseChunk _ = Nothing
parseChunks : List Char -> List (Maybe Chunk)
parseChunks l = parseChunk <$> l

run : String -> IO ()
run s = do let l = findCorrupted [] . catMaybes . parseChunks . unpack <$> lines s
           let s = sum $ catMaybes $ (score <$>) <$> l
           putStrLn $ show s

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


module Prob
-- http://mlg.eng.cam.ac.uk/pub/pdf/SciGhaGor15.pdf
data Dist : Type -> Type where
  Return      : a -> Dist a
  Bind        : Dist b -> (b -> Dist a) -> Dist a
--  Primitive   : Sampleable d => d a -> Dist a
--  Conditional : (a -> Prob) -> Dist a -> Dist a

Functor Dist where
  map f (Return x) = Return (f x)
  map f (Bind x g) = Bind x (\b=>map f $ g b)

Applicative Dist where

  pure x = Return x
  (<*>) (Return x) (Return y) = Return (x y)
  (<*>) (Return x) (Bind y f) = Return (x ?Applicative_rhs_7)
  (<*>) (Bind x f) (Return y) = Return ?Applicative_rhs_2
  (<*>) (Bind x f) (Bind y g) = Return ?Applicative_rhs_6

Monad Dist where
  (>>=) = Bind
  join x = ?Monad_rhs_2


infixr 6 -*
(-*) : Type -> Type -> Type
(-*) a b = (1 _ : a) -> b

-- Test that the types of holes are not overly generalised wrt the
-- multiplicities in the function type

foo1 : (((1 _ : a) -> (1 _ : b) -> (1 _ : c) -> ()) -> ()) -> ()
foo1 f = f ?foo1h

foo2 : (((1 _ : a) -> (1 _ : b) -> (1 _ : c) -> ()) -> ()) -> ()
foo2 f = f (id ?foo2h)

foo3 : ((a -* b -* c -* ()) -> ()) -> ()
foo3 f = f (id ?foo3h)


module ErrorHandlingInterpreter

%default total

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 s = MkEval (\e => fetchVal e) where
  fetchVal : List (String, a) -> Maybe a
  fetchVal [] = Nothing
  fetchVal ((v, val) :: xs) = if v == s
                                 then (Just val)
                                 else (fetchVal xs)

Functor Eval where
  -- map : (a -> b) -> Eval a -> Eval b
  map f (MkEval g) = MkEval (\x => map f (g x))

Applicative Eval where
  -- pure : Eval a
  pure x = MkEval (\e => Just x)

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

{-
eval : Expr -> Eval Int
eval (Var x) = fetch x
eval (Val n) = pure n
eval (Add x y) = pure (+) <*> eval x <*> eval y
-}

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

runEval : List (String, Int) -> Expr -> Maybe Int
runEval env e = case eval e of
                     MkEval envFn => envFn env


%default total

||| View for traversing a list backwards
public export
data SnocList : List a -> Type where
     Empty : SnocList []
     Snoc : (x : a) -> (xs : List a) ->
            (rec : SnocList xs) -> SnocList (xs ++ [x])

empty : SnocList (x :: xs) -> a
empty Empty impossible

snoc : SnocList (x :: xs) -> a
snoc (Snoc _ _ _) impossible


a : Integer
a = 3+4

b : Integer
b = 7

some_proposition : Bool
some_proposition = 4+7==11

another_proposition : Bool
another_proposition = 3+8==11

complicated : Bool
complicated = 4+5*3-7==13-1

p : Bool
p = 8>5

q : Bool
q = "Hello" == "Goodbye"

r : Bool
r = True

j : Integer
j = 9001

u : Bool
u = ("Hello" == "Goodbye") || (3==3)

s : String
s = ifThenElse (3==3) "tick" "tock"


module Main

import Data.Strings
import Data.Vect

%default total

partial
readVectInt : HasIO io => io (n : Nat ** Vect n Int)
readVectInt = do x <- getLine
                 if x == ""
                    then pure $ (_ ** [])
                    else do (_ ** ns) <- readVectInt
                            pure $ (_ ** (cast x :: ns))

partial
addVectInts : HasIO io => io ()
addVectInts = do putStrLn "Enter the first vector (blank line to end)"
                 (len1 ** xs) <- readVectInt
                 putStrLn "Enter the second vector (blank line to end)"
                 (len2 ** ys) <- readVectInt
                 case exactLength len1 ys of
                      Nothing => putStrLn "Vectors are of unequal lengths"
                      Just ys' => printLn $ zipWith (+) xs ys'


module ListExt2

%default total
%access public export

smallerThanCons : (x : a) -> (xs : List a) -> Smaller xs (x :: xs)
smallerThanCons x [] = lteRefl
smallerThanCons x (y :: xs) = lteRefl

||| If Left True, never bother to call me back
eat : Eq a => (delim : List a) -> {auto prf : NonEmpty delim}
    -> (dish : List a)
    -> Either Bool (rem : List a ** Smaller rem dish)
eat (x :: xs) [] = Left True
eat (x :: xs) (y :: ys) =
  if x == y
  then
    case xs of
      [] => Right (ys ** smallerThanCons y ys)
      (z :: zs) =>
        case eat (z :: zs) ys of
          Left e => Left e
          Right (l ** prf) => Right (l ** lteSuccRight prf)
  else Left False

splitStep : Eq a => (xs : List a)
          -> ((ys : List a) -> Smaller ys xs -> List a
                            -> (List a, List (List a)))
          -> List a -> (List a, List (List a))
splitStep [] _ _ = ([], [])
splitStep xs@(_ :: _) _ [] = (xs, [])
splitStep (x :: xs) f delim@(_::_) =
  case eat delim (x :: xs) of
    Left True => (x :: xs, [])
    Left False =>
      let (l, ls) = f xs (smallerThanCons x xs) delim
      in (x :: l, ls)
    Right (rem ** prf) =>
      let (l, ls) = f rem prf delim
      in ([], l::ls)

splitWith : Eq a => List a -> List a -> List (List a)
splitWith delim splittee =
  let splitter = sizeRec splitStep splittee
  in uncurry (::) $ splitter delim

substitute : Eq a => List a -> List a -> List a -> List a
substitute needle replacement = intercalate replacement . splitWith needle

strReplace : String -> String -> String -> String
strReplace needle replacement =
  pack . substitute (unpack needle) (unpack replacement) . unpack


-- ---------------------------------------------- [ DependentStateMachines.idr ]
-- Module      : Chapter.DependentStateMachines
-- Description : Definitions from Chapter 14 of Edwin Brady's book,
--               "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Chapter.DependentStateMachines

import Data.Vect

-- ------------------------------------------ [ 14.1.1 Refining the Door Model ]

public export
data DoorResult = OK | Jammed

||| A door is either open or closed.
public export
data DoorState = ||| The door is closed.
                 DoorClosed
               | ||| The door is open.
                 DoorOpen

namespace Door

    public export
    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_fn res) state_fn
         (>>=) : DoorCmd a state1 state2_fn ->
               ((res : a) -> DoorCmd b (state2_fn res) state3_fn) ->
         DoorCmd b state1 state3_fn

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

-- -------------------------------------- [ 14.2.2 Defining a Type for the ATM ]

||| A PIN is exactly four characters.
PIN : Type
PIN = Vect 4 Char

||| The possible states of the ATM.
data ATMState = Ready | CardInserted | Session

||| The possible results of checking a PIN, valid or invalid.
data PINCheck = CorrectPIN | IncorrectPIN

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

namespace ATM

    data ATMCmd : (ty : Type) -> ATMState -> (ty -> ATMState) -> Type where
         InsertCard : ATMCmd ()   Ready        (const CardInserted)
         EjectCard  : {auto prf : HasCard state} ->
                      ATMCmd () state (const Ready)
         GetPIN     : ATMCmd PIN  CardInserted (const CardInserted)

         CheckPIN   : PIN -> ATMCmd PINCheck CardInserted
                               (\check => case check of
                                               CorrectPIN => Session
                                               IncorrectPIN => CardInserted)
         GetAmount : ATMCmd Nat state (const state)

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

         Message : String -> ATMCmd () state (const state)
         Pure  : (res : ty) -> ATMCmd ty (state_fn res) state_fn
         (>>=) : ATMCmd a state1 state2_fn ->
                 ((res : a) -> ATMCmd b (state2_fn res) state3_fn) ->
                 ATMCmd b state1 state3_fn

atm : ATMCmd () Ready (const Ready)
atm = do InsertCard
         Message "Checking Card"
         case !(CheckPIN !GetPIN) of
              CorrectPIN   => do Dispense !GetAmount
                                 EjectCard
                                 Message "Please remove your card and cash"
              IncorrectPIN => do Message "Incorrect PIN"
                                 EjectCard

testPIN : Vect 4 Char
testPIN = ['1', '2', '3', '4']

readVect : (n : Nat) -> IO (Vect n Char)
readVect Z = do discard <- getLine
                pure []
readVect (S k) = do ch <- getChar
                    chs <- readVect k
                    pure (ch :: chs)

runATM : ATMCmd res inState outState_fn -> IO res
runATM InsertCard = do putStrLn "Please insert your card (press enter)"
                       x <- getLine
                       pure ()
runATM EjectCard = putStrLn "Card ejected"
runATM GetPIN = do putStr "Enter PIN: "
                   readVect 4
runATM (CheckPIN pin) = if pin == testPIN
                           then pure CorrectPIN
                           else pure IncorrectPIN
runATM GetAmount = do putStr "How much would you like? "
                      pure (cast !getLine)
runATM (Dispense amount) = putStrLn ("Here is " ++ show amount)

runATM (Message msg) = putStrLn msg
runATM (Pure res) = pure res
runATM (x >>= f) = do x' <- runATM x
                      runATM (f x')

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


module Example.Qtt.Problems

-- This module typechecks only with Idris 2 @fe602caa2, not newer. --

A : Type
B : Type
C : Type

k : A -> (1 _ : B) -> C

-- Typecheks with newer Idris (without linearity subtyping)
--mapK : List A -> List $ (1 _ : B) -> C
--mapK = map k

zipWith : (a -> b -> c) -> List a -> List b -> List c

-- Should compile when there was a linearity subtyping.
zipWithK : List A -> List B -> List C
zipWithK = zipWith k

-- Contra --

namespace InterfaceEdition

  interface Con w where
    constructor MkCon
    con : Nat -> w

  -- Instance первого порядка
  mkCon : (a -> b) -> Con (a -> b)
  mkCon f = MkCon {con = \_ => f}

  -- Would typecheck when linearity subtyping.
  bang : (a -> b) -> (1 _ : a) -> b
  bang f = let cc = mkCon f in con 5

-- Contra (record edition) --

namespace RecordEdition

  record Con w where
    constructor MkCon
    con : Nat -> w       -- `w` в контравариантной позиции

  conn : Con w => Nat -> w
  conn @{x} = con x

  mkCon : (a -> b) -> Con (a -> b)
  mkCon f = MkCon {con = \_ => f}

  -- Would typecheck when linearity subtyping.
  bang : (a -> b) -> (1 _ : a) -> b
  bang f = let cc = mkCon f in conn 5


module Data.List.Predicates.Interleaving

import Data.List

%access public export
%default total

data Interleaving : (xs, ys, zs : List type) -> Type where
  Empty   : Interleaving Nil Nil Nil
  LeftAdd : (x : type)
         -> (rest : Interleaving xs ys zs)
         -> Interleaving (x::xs) ys (x::zs)
  RightAdd : (y : type)
          -> (rest : Interleaving xs ys zs)
          -> Interleaving xs (y::ys) (y::zs)

leftEmpty : (ys : List type) -> Interleaving Nil ys ys
leftEmpty [] = Empty
leftEmpty (x :: xs) = RightAdd x (leftEmpty xs)

leftEmptyCons : (x : type) -> (xs : List type) -> Interleaving Nil (x::xs) (x::xs)
leftEmptyCons x [] = RightAdd x Empty
leftEmptyCons x (y :: xs) with (leftEmptyCons y xs)
  leftEmptyCons x (y :: xs) | (RightAdd y rest) = RightAdd x (RightAdd y rest)

rightEmpty : (xs : List type) -> Interleaving xs Nil xs
rightEmpty [] = Empty
rightEmpty (x :: xs) = LeftAdd x (rightEmpty xs)


data MyNat
    = S (Inf MyNat)
    | Z

%builtin Natural MyNat


module RhoCalculus

{-
A Reflective Higher-order Calculus
L.G.Meredith MatthiasRadestock
Electronic Notes in Theoretical Computer Science
Volume 141, Issue 5, 22 December 2005, Pages 49-67
http://www.sciencedirect.com/science/article/pii/S1571066105051839
-}

%access export
%default total

mutual
  data Process: Type where
    Zero: Process
    Input: Action -> (P: Process) -> Process
    Lift: (x: Name) -> (P: Process) -> Process
    Drop: (x: Name) -> Process
    Par: (List Process) -> Process

  data Action: Type where
    Act: (x: Name) -> (y: Name) -> Action

  data Name: Type where
    Quote: (P: Process) -> Name

zero: Process
zero = Zero

guard: Name -> Name -> Action
guard nsubj nobj = Act nsubj nobj

input: Name -> Name -> Process -> Process
input nsubj nobj cont = Input (Act nsubj nobj) cont

prefix_: Action -> Process -> Process
prefix_ (Act (Quote proc1) (Quote proc2)) cont = Input (Act (Quote proc1) (Quote proc2)) cont

lift: Name -> Process -> Process
lift nsubj cont = Lift nsubj cont

drop: Name -> Process
drop n = Drop n

par: Process -> Process -> Process
par (Par proclist1) (Par proclist2) = Par (proclist1 ++ proclist2)
par (Par proclist) proc = Par (proclist ++ [proc])
par proc (Par proclist) = Par ([proc] ++ proclist)
par p1 p2 = Par [p1, p2]

parstar: List Process -> Process
parstar [] = Zero
parstar (proclisthd :: proclisttl) = foldl par proclisthd proclisttl

quote : Process -> Name
quote proc = Quote proc

mutual
  processQuoteDepth: Process -> Nat  -- TODO: prove totality
  processQuoteDepth Zero = 0
  processQuoteDepth (Input (Act nsubj nobj) cont) =
    maximum (nameQuoteDepth nsubj) (processQuoteDepth cont)
  processQuoteDepth (Lift nsubj cont) =
    maximum (nameQuoteDepth nsubj) (processQuoteDepth cont)
  processQuoteDepth (Drop n) = nameQuoteDepth n
  processQuoteDepth (Par procs) =
   assert_total $ foldl (\qD, proc => maximum qD (processQuoteDepth proc))
         0
         procs

  nameQuoteDepth: Name -> Nat
  nameQuoteDepth (Quote proc) = assert_total $ 1 + (processQuoteDepth proc)

syntax [x] "[" [y] "]" = output x y
output : Name -> Name -> Process
output x y = Lift x $ Drop y

exampleName: Name
exampleName = Quote Zero

twoNewProcesses: List Process
twoNewProcesses =
  [qz[qz],
   Input (Act qz qz) Zero]
 where
   qz = Quote Zero

moreNames: List Name
moreNames = map Quote twoNewProcesses


module Control.MonadRec

import public Control.WellFounded
import Control.Monad.Either
import Control.Monad.Identity
import Control.Monad.Maybe
import Control.Monad.Reader
import Control.Monad.RWS
import Control.Monad.State
import Control.Monad.Writer

import Data.List
import Data.SnocList
import public Data.Fuel
import public Data.Nat

%default total

--------------------------------------------------------------------------------
--          Sized Implementations
--------------------------------------------------------------------------------

public export
Sized Fuel where
  size Dry      = 0
  size (More f) = S $ size f

public export
Sized (SnocList a) where
  size = length

--------------------------------------------------------------------------------
--          Step
--------------------------------------------------------------------------------

||| Single step in a recursive computation.
|||
||| A `Step` is either `Done`, in which case we return the
||| final result, or `Cont`, in which case we continue
||| iterating. In case of a `Cont`, we get a new seed for
||| the next iteration plus an updated state. In addition
||| we proof that the sequence of seeds is related via `rel`.
||| If `rel` is well-founded, the recursion will provably
||| come to an end in a finite number of steps.
public export
data Step :  (rel   : a -> a -> Type)
          -> (seed  : a)
          -> (accum : Type)
          -> (res   : Type)
          -> Type where

  ||| Keep iterating with a new `seed2`, which is
  ||| related to the current `seed` via `rel`.
  ||| `vst` is the accumulated state of the iteration.
  Cont :  (seed2 : a)
       -> (0 prf : rel seed2 seed)
       -> (vst   : st)
       -> Step rel seed st res

  ||| Stop iterating and return the given result.
  Done : (vres : res) -> Step rel v st res

public export
Bifunctor (Step rel seed) where
  bimap f _ (Cont s2 prf st) = Cont s2 prf (f st)
  bimap _ g (Done res)       = Done (g res)

  mapFst f (Cont s2 prf st) = Cont s2 prf (f st)
  mapFst _ (Done res)       = Done res

  mapSnd _ (Cont s2 prf st) = Cont s2 prf st
  mapSnd g (Done res)       = Done (g res)

--------------------------------------------------------------------------------
--          MonadRec
--------------------------------------------------------------------------------

||| Interface for tail-call optimized monadic recursion.
public export
interface Monad m => MonadRec m where
  ||| Implementers mus make sure they implement this function
  ||| in a tail recursive manner.
  ||| The general idea is to loop using the given `step` function
  ||| until it returns a `Done`.
  |||
  ||| To convey to the totality checker that the sequence
  ||| of seeds generated during recursion must come to an
  ||| end after a finite number of steps, this function
  ||| requires an erased proof of accessibility.
  total
  tailRecM :  {0 rel : a -> a -> Type}
           -> (seed  : a)
           -> (ini   : st)
           -> (0 prf : Accessible rel seed)
           -> (step  : (seed2 : a) -> st -> m (Step rel seed2 st b))
           -> m b

public export %inline
||| Monadic tail recursion over a sized structure.
trSized :  MonadRec m
        => (0 _ : Sized a)
        => (seed : a)
        -> (ini  : st)
        -> (step : (v : a) -> st -> m (Step Smaller v st b))
        -> m b
trSized x ini = tailRecM x ini (sizeAccessible x)

--------------------------------------------------------------------------------
--          Base Implementations
--------------------------------------------------------------------------------

public export
MonadRec Identity where
  tailRecM seed st1 (Access rec) f = case f seed st1 of
    Id (Done b)         => Id b
    Id (Cont y prf st2) => tailRecM y st2 (rec y prf) f

public export
MonadRec Maybe where
  tailRecM seed st1 (Access rec) f = case f seed st1 of
    Nothing               => Nothing
    Just (Done b)         => Just b
    Just (Cont y prf st2) => tailRecM y st2 (rec y prf) f

public export
MonadRec (Either e) where
  tailRecM seed st1 (Access rec) f = case f seed st1 of
    Left e                 => Left e
    Right (Done b)         => Right b
    Right (Cont y prf st2) => tailRecM y st2 (rec y prf) f

trIO :  (x : a)
     -> (ini : st)
     -> (0 _ : Accessible rel x)
     -> (f : (v : a) -> st -> IO (Step rel v st b))
     -> IO b
trIO x ini acc f = fromPrim $ run x ini acc
  where run :  (y : a) -> (st1 : st)
            -> (0 _ : Accessible rel y)
            -> (1 w : %World)
            -> IORes b
        run y st1 (Access rec) w = case toPrim (f y st1) w of
          MkIORes (Done b) w2          => MkIORes b w2
          MkIORes (Cont y2 prf st2) w2 => run y2 st2 (rec y2 prf) w2

public export %inline
MonadRec IO where
  tailRecM = trIO

--------------------------------------------------------------------------------
--          Transformer Implementations
--------------------------------------------------------------------------------

---------------------------
-- StateT

%inline
convST :  Functor m
       => (f : (v : a) -> st -> StateT s m (Step rel v st b))
       -> (v : a)
       -> (st,s)
       -> m (Step rel v (st,s) (s,b))
convST f v (st1,s1) =   (\(s2,stp) => bimap (,s2) (s2,) stp)
                    <$> runStateT s1 (f v st1)

public export
MonadRec m => MonadRec (StateT s m) where
  tailRecM x ini acc f =
    ST $ \s1 => tailRecM x (ini,s1) acc (convST f)

---------------------------
-- EitherT

convE :  Functor m
      => (f : (v : a) -> st -> EitherT e m (Step rel v st b))
      -> (v : a)
      -> (ini : st)
      -> m (Step rel v st (Either e b))
convE f v s1 = map conv $ runEitherT (f v s1)
  where conv : Either e (Step rel v st b) -> Step rel v st (Either e b)
        conv (Left err)                = Done (Left err)
        conv (Right $ Done b)          = Done (Right b)
        conv (Right $ Cont v2 prf st2) = Cont v2 prf st2

public export
MonadRec m => MonadRec (EitherT e m) where
  tailRecM x ini acc f =
    MkEitherT $ tailRecM x ini acc (convE f)

---------------------------
-- MaybeT

convM :  Functor m
      => (f : (v : a) -> st -> MaybeT m (Step rel v st b))
      -> (v : a)
      -> (ini : st)
      -> m (Step rel v st (Maybe b))
convM f v s1 = map conv $ runMaybeT (f v s1)
  where conv : Maybe (Step rel v st b) -> Step rel v st (Maybe b)
        conv Nothing                  = Done Nothing
        conv (Just $ Done b)          = Done (Just b)
        conv (Just $ Cont v2 prf st2) = Cont v2 prf st2

public export
MonadRec m => MonadRec (MaybeT m) where
  tailRecM x ini acc f =
    MkMaybeT $ tailRecM x ini acc (convM f)

---------------------------
-- ReaderT

convR :  (f : (v : a) -> st -> ReaderT e m (Step rel v st b))
      -> (env : e)
      -> (v : a)
      -> (ini : st)
      -> m (Step rel v st b)
convR f env v s1 = runReaderT env (f v s1)

public export
MonadRec m => MonadRec (ReaderT e m) where
  tailRecM x ini acc f =
    MkReaderT $ \env => tailRecM x ini acc (convR f env)

---------------------------
-- WriterT

convW :  Functor m
      => (f : (v : a) -> st -> WriterT w m (Step rel v st b))
      -> (v : a)
      -> (st,w)
      -> m (Step rel v (st,w) (b,w))
convW f v (s1,w1) =   (\(stp,w2) => bimap (,w2) (,w2) stp)
                  <$> unWriterT (f v s1) w1

public export
MonadRec m => MonadRec (WriterT w m) where
  tailRecM x ini acc f =
    MkWriterT $ \w1 => tailRecM x (ini,w1) acc (convW f)

---------------------------
-- RWST

convRWS :  Functor m
        => (f : (v : a) -> st -> RWST r w s m (Step rel v st b))
        -> (env : r)
        -> (v : a)
        -> (st,s,w)
        -> m (Step rel v (st,s,w) (b,s,w))
convRWS f env v (st1,s1,w1) =   (\(stp,s2,w2) => bimap (,s2,w2) (,s2,w2) stp)
                            <$> unRWST (f v st1) env s1 w1

public export
MonadRec m => MonadRec (RWST r w s m) where
  tailRecM x ini acc f =
    MkRWST $ \r1,s1,w1 => tailRecM x (ini,s1,w1) acc (convRWS f r1)


module VectMissing

using (x : a, xs : Vect n a)
  data IsElem : a -> Vect n a -> Type where
       First : IsElem x (x :: xs)
       Later : IsElem x xs -> IsElem x (y :: xs)

  instance Uninhabited (IsElem x []) where
    uninhabited First impossible
    uninhabited (Later p) impossible

  isElem : DecEq a => (x : a) -> (xs : Vect n a) -> Maybe (IsElem x xs)
  isElem x [] = Nothing
  isElem x (y :: xs) with (decEq x y)
    isElem x (x :: xs) | (Yes refl) = Just First
    isElem x (y :: xs) | (No f) = Just (Later !(isElem x xs))

  shrink : (xs : Vect (S n) a) -> IsElem x xs -> Vect n a
  shrink (x :: ys) First = ys
  shrink (y :: []) (Later p) = absurd p
  shrink (y :: (x :: xs)) (Later p) = y :: shrink (x :: xs) p


module Main

import Graphics.SDL2.SDL

import Control.Algebra
import Data.Matrix

import Graphics.Util.Transforms
import Graphics.Util.ObjLoader
import Graphics.Util.Mesh
import Graphics.Rendering.Gl
import Graphics.Rendering.Config

%include C "GL/glew.h"
%flag C "-Wno-pointer-sign"

||| contains the display / viewport dimension
record Display where
  constructor MkDisplay
  width : Int
  height : Int

||| returns the aspect ratio of a disply
aspectRatio : Display -> Double
aspectRatio (MkDisplay width height) = (cast width) / (cast height)

||| camera parameterers
||| the values in this data type will be used to calculate the view and perspective
||| projection matrices
record Camera where
  constructor MkCamera
  ||| the 3D position of the camera
  position : Vec3
  ||| field of view of the camera
  fov : Angle
  ||| near plane limit of the camera frustum
  nearPlane : Double
  ||| far plane limit of the camera frustum
  farPlane : Double
  ||| the direction of the camera as a vector
  direction : Vec3

record ShaderLocations where
  constructor Locs
  viewMatrixLocation : Int

record State where
  constructor MkState
  renderer: SDLRenderer
  window: SDLWindow
  display : Display
  camera  : Camera
  locations: ShaderLocations
  entities : List (Entity String)

updateCameraPosition : State -> (Vec3 -> Vec3) -> State
updateCameraPosition state f = record { camera->position = f (record {camera->position} state) } state

update: Event -> State -> State
update (KeyDown (KeyAny 'w'))  state = updateCameraPosition state (\p => p <-> [0,    0,    0.05])
update (KeyDown (KeyAny 's'))  state = updateCameraPosition state (\p => p <+> [0,    0,    0.05])
update (KeyDown (KeyAny 'a'))  state = updateCameraPosition state (\p => p <-> [0.05, 0,    0])
update (KeyDown (KeyAny 'd'))  state = updateCameraPosition state (\p => p <+> [0.05, 0,    0])
update (KeyDown KeyUpArrow)    state = updateCameraPosition state (\p => p <+> [0,    0.05, 0])
update (KeyDown KeyDownArrow)  state = updateCameraPosition state (\p => p <-> [0,    0.05, 0])
update (KeyDown _)             state = state
update (KeyUp x)               state = state
update (MouseMotion x y dx dy) state = state
update (MouseButtonDown x y z) state = state
update (MouseButtonUp x y z)   state = state
update (MouseWheel x)          state = state
update (Resize x y)            state = state
update AppQuit                 state = state
update WindowEvent             state = state

setViewMatrix : State -> Entity String -> String -> IO ()
setViewMatrix state (SimpleEntity _ _ entityPosition rotation location _) s = do
  let pos = entityPosition <-> (record { camera->position } state)
  let transform = (translate pos) <> (rotate rotation) <> (scaleAll 1)
  glUniformMatrix4fv location 1 0 (toList $ toGl transform)

draw : State -> IO ()
draw state = do
                glClearColor 0.2 0.2 0.2 1
                glClear GL_COLOR_BUFFER_BIT
                glClear GL_DEPTH_BUFFER_BIT

                let locView = record {locations->viewMatrixLocation} state
                let cameraDirection = record {camera->direction} state
                glUniformMatrix4fv locView 1 0 (toList $ toGl $ standardViewMatrix cameraDirection)

                traverse (\entity => render entity (setViewMatrix state entity)) (entities state)

                glSwapWindow $ window state

camera : Camera
camera = MkCamera [0.0, 0.0, 0.0] (Degree 45) 0.1 100.0 [0.0, 0.0, -1.0]

display : Display
display = MkDisplay 800 600

main : IO ()
main = do
          initSDL
          glSetAttribute SDL_GL_CONTEXT_PROFILE_MASK (toSDLInt SDL_GL_CONTEXT_PROFILE_CORE)
          glSetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 4
          glSetAttribute SDL_GL_CONTEXT_MINOR_VERSION 1
          glSetAttribute SDL_GL_ACCELERATED_VISUAL 1
          glSetAttribute SDL_GL_DOUBLEBUFFER  1
          glSetAttribute SDL_GL_DEPTH_SIZE 16

          (win,renderer) <- startSDL "Hello Idris" 800 600
          ctx <- createGLContext win
          glMakeCurrent win ctx

          glSetSwapInterval 1

          glewInit
          info <- glGetInfo
          putStrLn info
          glEnable GL_DEPTH_TEST
          glDepthFunc GL_LESS

          texture <- loadTexture "stone.png" 0
          plane <- loadObj "stone.obj"
          planeModel <- createModel plane [texture]

          shader <- createShaders [(GL_VERTEX_SHADER, "shader.vert"), (GL_FRAGMENT_SHADER, "shader.frag")]
          traverse printShaderLog  (shaders shader)
          glUseProgram $ program shader

          locView <- glGetUniformLocation (program shader) "viewMatrix"
          glUniformMatrix4fv locView 1 0 (toList $ toGl $ viewMatrix [0,0,-1] [0,0,0] [0,1,0])

          locProj <- glGetUniformLocation (program shader) "projectionMatrix"
          let projM = perspectiveProjection (fov camera) (aspectRatio display) ((nearPlane camera), (farPlane camera))
          glUniformMatrix4fv locProj 1 0 (toList $ toGl projM)

          loc <- glGetUniformLocation (program shader) "transformMatrix"

          let entity = SimpleEntity planeModel shader [0,-0.5,-3] [(Degree 0),(Degree 0),(Degree 0)] loc "Test"

          let initialState = MkState renderer win display camera (Locs locView) [entity]
          eventLoop initialState
          deleteModel planeModel
          deleteShaders shader
          deleteTextures [texture]
          --deleteGLContext ctx
          endSDL win renderer
          pure ()
       where
         eventLoop : State -> IO ()
         eventLoop state = do
                         e <- pollEvent
                         case e of
                           Just AppQuit => return ()
                           Just event   => do
                             draw state
                             --handle r event
                             --putStrLn $ "event" ++ (show event)
                             eventLoop $ update event state
                           _            => eventLoop state


module Main

import NonDTRealizedFunction

-- Realized incrementer
incrementer : Int -> Int
incrementer = (+1)
incrementer_attrs : NonDTRealizedAttributes
incrementer_attrs = MkNonDTRealizedAttributes (MkCosts 1 1 1) 1
rlz_incrementer : NonDTRealizedFunction (Int -> Int)
rlz_incrementer = MkNonDTRealizedFunction incrementer incrementer_attrs

-- Realized twicer
twicer : Int -> Int
twicer = (*2)
twicer_attrs : NonDTRealizedAttributes
twicer_attrs = MkNonDTRealizedAttributes (MkCosts 2 2 2) 0.9
rlz_twicer : NonDTRealizedFunction (Int -> Int)
rlz_twicer = MkNonDTRealizedFunction twicer twicer_attrs

-- Realized (twicer . incrementer)
rlz_composition : NonDTRealizedFunction (Int -> Int)
rlz_composition = compose rlz_twicer rlz_incrementer

-- Simple test, result should be (3+1)*2 = 8
rslt : Int
rslt = apply rlz_composition 3


module Map

import Data.List
import Data.Maybe
import Data.Nat

%default total

iff : (p, q : Type) -> Type
iff p q = (p -> q, q -> p)

iff_sym : iff p q -> iff q p
iff_sym (x, y) = (y, x)

functional_extensionality : ((x : a) -> f x = g x) -> f = g
functional_extensionality = believe_me

public export
data Reflect : (p: Type) -> (b: Bool) -> Type where
    ReflectT : p -> (b=True) -> Reflect p b
    ReflectF : (Not p) -> (b=False) -> Reflect p b

iff_reflect : (b : Bool) -> iff p (b = True) -> Reflect p b
iff_reflect False (x, y) = ReflectF (uninhabited . x) Refl
iff_reflect True (x, y) = ReflectT (y Refl) Refl

reflect_iff : (b : Bool) -> Reflect p b -> iff p (b = True)
reflect_iff False (ReflectT _ Refl) impossible
reflect_iff False (ReflectF f prf) = (\p => void (f p), \p => void (uninhabited p))
reflect_iff True (ReflectT x prf) = (\p => prf, \Refl => x)
reflect_iff True (ReflectF _ Refl) impossible

public export
beq_bool : (b : Bool) -> b == b = True
beq_bool False = Refl
beq_bool True = Refl

public export
eq_bool : (b1, b2 : Bool) -> b1 == b2 = True -> b1 = b2
eq_bool False False _ = Refl
eq_bool False True Refl impossible
eq_bool True False Refl impossible
eq_bool True True _ = Refl

public export
neq_bool : (b1, b2 : Bool) -> b1 == b2 = False -> Not (b1 = b2)
neq_bool False False prf = absurd $ prf
neq_bool False True prf = uninhabited
neq_bool True False prf = uninhabited
neq_bool True True prf = absurd $ prf

public export
inv_bool : (b1, b2 : Bool) -> b1 = (not b2) -> b2 = (not b1)
inv_bool False False Refl impossible
inv_bool False True _ = Refl
inv_bool True False _ = Refl
inv_bool True True Refl impossible

public export
and_split : (a : Bool) -> (b : Lazy Bool) -> a && b = True -> (a = True, b = True)
and_split False (Delay b) prf = absurd prf
and_split True (Delay b) prf = (Refl, prf)

public export
and_join : (a = True, b = True) -> a && b = True
and_join (x, y) = rewrite x in rewrite y in Refl

public export
and_join2 : a = False -> a && _ = False
and_join2 prf = rewrite prf in Refl

public export
tuple_eq : (a, b) = (c, d) -> Not (c = d) -> Not (a = b)
tuple_eq prf f prf1 =
    let
        ac = cong fst prf
        bd = cong snd prf
    in f (rewrite sym ac in rewrite sym bd in prf1)

-- Maybe utils
public export
it_is_just : (a : Maybe b) -> (a = Just c) -> IsJust a
it_is_just Nothing Refl impossible
it_is_just (Just x) prf = ItIsJust

public export
contra : IsJust a -> a = Nothing -> Void
contra ItIsJust Refl impossible

-- Nat utils
public export
beq_nat : (n : Nat) -> n == n = True
beq_nat 0 = Refl
beq_nat (S k) = beq_nat k

public export
eq_nat : (n1, n2 : Nat) -> n1 == n2 = True -> n1 = n2
eq_nat 0 0 prf = Refl
eq_nat 0 (S _) Refl impossible
eq_nat (S _) 0 Refl impossible
eq_nat (S k) (S j) prf =
    let ind = eq_nat k j prf in
        rewrite ind in Refl

public export
neq_nat : (n1, n2 : Nat) -> n1 == n2 = False -> Not (n1 = n2)
neq_nat 0 0 prf = absurd prf
neq_nat 0 (S k) Refl = uninhabited
neq_nat (S k) 0 Refl = uninhabited
neq_nat (S k) (S j) prf =
    let ind = neq_nat k j prf in
        \p => ind $ cong pred p

beq_natP : (n, m : Nat) -> Reflect (n = m) (n == m)
beq_natP n m with (n == m) proof h
    beq_natP n m | False = ReflectF (neq_nat n m h) Refl
    beq_natP n m | True = ReflectT (eq_nat n m h) Refl

-- String utils
public export
beq_str : (s : List Char) -> s == s = True
beq_str s = believe_me s

public export
eq_str : (s1, s2 : List Char) -> s1 == s2 = True -> s1 = s2
eq_str s1 s2 prf = believe_me prf

public export
neq_str : (s1, s2 : List Char) -> s1 == s2 = False -> Not (s1 = s2)
neq_str s1 s2 prf = believe_me prf

-- Key
public export
data Key : Type where
    MkKey : Nat -> Key

%name Key k, k1, k2

key_to_nat : Key -> Nat
key_to_nat (MkKey n) = n

public export
Eq Key where
    MkKey a == MkKey b = a == b

public export
Uninhabited (a = b) => Uninhabited (MkKey a = MkKey b) where
    uninhabited Refl @{ab} = uninhabited @{ab} Refl

public export
beq_key : (k: Key) -> k == k = True
beq_key (MkKey n) = beq_nat n

public export
bne_key : (k1, k2 : Key) -> k1 == k2 = False -> Not (k1 = k2)
bne_key (MkKey k) (MkKey j) prf prf1 =
    neq_nat k j prf (cong key_to_nat prf1)

public export
ne_key : (k1, k2 : Key) -> Not (k1 = k2) -> k1 == k2 = False
ne_key (MkKey k) (MkKey j) with (beq_natP k j)
    ne_key (MkKey k) (MkKey j) | (ReflectT x prf) = \a => void $ a $ cong MkKey x
    ne_key (MkKey k) (MkKey j) | (ReflectF f prf) = \a => prf

public export
beq_keyP : (n, m : Key) -> Reflect (n = m) (n == m)
beq_keyP (MkKey k) (MkKey j) with (beq_natP k j)
    beq_keyP (MkKey k) (MkKey j) | (ReflectT x prf) = ReflectT (cong MkKey x) prf
    beq_keyP (MkKey k) (MkKey j) | (ReflectF f prf) = ReflectF (\p => f (cong key_to_nat p)) prf

public export
data Map : Type -> Type where
    Empty : Map a
    Update : Key -> Maybe a -> Map a -> Map a

%name Map m, m1, m2

public export
Uninhabited (Empty = Update k v m) where
    uninhabited Refl impossible

public export
Uninhabited (Update k v m = Empty) where
    uninhabited Refl impossible

public export
empty : Map a
empty = Empty

public export
update : Key -> Maybe a -> Map a -> Map a
update k v m = Update k v m

public export
insert : Key -> a -> Map a -> Map a
insert k v m = update k (Just v) m

public export
remove : Key -> Map a -> Map a
remove k m = update k Nothing m

public export
get : Key -> Map a -> Maybe a
get k Empty = Nothing
get k (Update k' v' m') = if k == k' then v' else get k m'

public export
contains : Key -> Map a -> Bool
contains k m = isJust $ get k m

public export
half_eq : Eq a => Map a -> Map a -> Bool
half_eq Empty _ = True
half_eq (Update k v m') m2 = get k m2 == v

public export
Eq a => Eq (Map a) where
    x == y = half_eq x y && half_eq y x

public export
keys : Map a -> List Key
keys m = filter (\k => contains k m) (all_keys m) where
    all_keys : Map a  -> List Key
    all_keys Empty = []
    all_keys (Update k _ m) = k :: all_keys m

public export
contains_all : List Key -> Map a -> Bool
contains_all [] m = True
contains_all (x :: xs) m = contains x m && contains_all xs m

public export
half_keys_eq : Map a -> Map b -> Bool
half_keys_eq m1 m2 = contains_all (keys m1) m2

public export
keys_eq : Map a -> Map b -> Bool
keys_eq m1 m2 = half_keys_eq m1 m2 && half_keys_eq m2 m1

-- Contains theorems
public export
get_just_contains : get k m = Just _ -> contains k m = True
get_just_contains prf = rewrite prf in Refl

public export
get_nothing_contains : get k m = Nothing -> contains k m = False
get_nothing_contains prf = rewrite prf in Refl

-- Get theorems
public export
get_neq : Not (get a m = get b m) -> Not (a = b)
get_neq f prf = f (cong (\k => get k m) prf)

-- Update theorems
public export
map_extensionality : (m1, m2 : Map a) -> ((k : Key) -> get k m1 = get k m2) -> m1 = m2
map_extensionality = \m1, m2, f => believe_me (Refl {x = MkUnit})

public export
update_eq : (m : Map a) -> (k : Key) -> (v : Maybe a) -> get k (update k v m) = v
update_eq m k v = rewrite beq_key k in Refl

public export
update_neq : (m : Map a) -> (k1, k2 : Key) -> (v : Maybe a) -> Not (k1 = k2) -> (get k2 $ update k1 v m) = get k2 m
update_neq m k1 k2 v f with (beq_keyP k2 k1)
    update_neq m k1 k2 v f | (ReflectT x prf) = void $ f $ sym x
    update_neq m k1 k2 v f | (ReflectF g prf) = rewrite prf in Refl

public export
update_shadow : (m : Map a) -> (k : Key) -> (v1, v2 : Maybe a) -> (update k v2 $ update k v1 m) = update k v2 m
update_shadow m k v1 v2 = map_extensionality (update k v2 $ update k v1 m) (update k v2 m) $ \k' =>
    case beq_keyP k' k of
        ReflectT t prf => rewrite prf in Refl
        ReflectF f prf => rewrite prf in rewrite prf in Refl

public export
update_same : (m : Map a) -> (k : Key) -> (v : Maybe a) -> (get k m = v) -> update k v m = m
update_same m k v prf = map_extensionality (update k v m) m  $ \k' =>
    case beq_keyP k' k of
        ReflectT t prf1 => rewrite prf1 in rewrite t in rewrite prf in Refl
        ReflectF f prf1 => rewrite prf1 in Refl

public export
update_permute : (m : Map a) -> (k1, k2 : Key) -> (v1, v2 : Maybe a) -> Not (k1 = k2) ->
    (update k1 v1 $ update k2 v2 m) = (update k2 v2 $ update k1 v1 m)
update_permute m k1 k2 v1 v2 prf = map_extensionality
    (update k1 v1 $ update k2 v2 m) (update k2 v2 $ update k1 v1 m) $ \k' =>
    case (beq_keyP k' k1, beq_keyP k' k2) of
        (ReflectT x _, ReflectT y _) =>
                void $ prf $ rewrite sym x in rewrite sym y in Refl
        (ReflectT _ prf1, ReflectF _ prf2) =>
            rewrite prf1 in rewrite prf2 in rewrite prf1 in Refl
        (ReflectF _ prf1, ReflectT _ prf2) =>
            rewrite prf1 in rewrite prf2 in Refl
        (ReflectF _ prf1, ReflectF _ prf2) =>
            rewrite prf1 in rewrite prf2 in rewrite prf1 in Refl

-- Half keys equality theorems
InMap : (k : Key) -> (m : Map a) -> Type
InMap k Empty = Void
InMap k (Update k' v' m') = Either (k = k', IsJust v') (Not (k = k'), InMap k m')

containsP : (k : Key) -> (m : Map a) -> Reflect (InMap k m) (contains k m)
containsP k Empty = ReflectF id Refl
containsP k (Update k' v' m') with (beq_keyP k k')
    containsP k (Update k' Nothing m') | ReflectT keq prf =
        rewrite prf in ReflectF (\f => case f of
            Left (_, f) => absurd f
            Right (f, _) => f keq) Refl
    containsP k (Update k' (Just v) m') | ReflectT keq prf =
        rewrite prf in ReflectT (Left (keq, ItIsJust)) Refl
    containsP k (Update k' v' m') | ReflectF f prf with (containsP k m')
        containsP k (Update k' v' m') | ReflectF f prf | ReflectT t prf1 =
            rewrite prf in ReflectT (Right (f, t)) prf1
        containsP k (Update k' v' m') | ReflectF f prf | ReflectF f' prf1 =
            rewrite prf in ReflectF (\p => case p of
                Left (p, _) => f p
                Right (_, p) => f' p) prf1

insert_contains : (k : Key) -> (v : a) -> (m : Map a) -> contains k (insert k v m) = True
insert_contains k v m = rewrite beq_key k in Refl

remove_contains : (k : Key) -> (m : Map a) -> contains k (remove k m) = False
remove_contains k m = rewrite beq_key k in Refl

contains_all_insert : (ks : List Key) -> (m : Map a) -> (k : Key) -> (v : a) ->
    contains_all ks m = True -> contains_all ks (insert k v m) = True
contains_all_insert [] _ _ _ _ = Refl
contains_all_insert (k :: ks) m k' v prf with (k == k')
    contains_all_insert (k :: ks) m k' v prf | False =
        let split = and_split (contains k m) (contains_all ks m) prf
            ind = contains_all_insert ks m k' v (snd split)
        in rewrite ind in rewrite fst split in Refl
    contains_all_insert (k :: ks) m k' v prf | True =
        let split = and_split (contains k m) (contains_all ks m) prf
            ind = contains_all_insert ks m k' v (snd split)
        in rewrite ind in Refl

contains_all_key : (ks : List Key) -> (m : Map a) -> (k : Key) -> contains k m = True ->
    contains_all ks m = True -> contains_all (k :: ks) m = True
contains_all_key ks m k prf prf1 = rewrite prf in rewrite prf1 in Refl

contains_all_key_insert : (ks : List Key) -> (m : Map a) -> (k : Key) -> (v : a) ->
    contains_all ks m = True -> contains_all (k :: ks) (insert k v m) = True
contains_all_key_insert ks m k v prf =
    let p = contains_all_insert ks m k v prf
        p' = contains_all_key ks (insert k v m) k (insert_contains k v m) p
    in p'

-- actually not true
keys_insert : (ks : List Key) -> (m : Map a) -> (k : Key) -> (v : a) ->
    keys m = ks -> keys (insert k v m) = k :: ks

public export
half_keys_eq_insert : (am : Map a) -> (bm : Map b) ->
    (k : Key) -> (av : a) -> (bv : b) ->
    half_keys_eq am bm = True -> half_keys_eq (insert k av am) (insert k bv bm) = True
half_keys_eq_insert am bm k av bv prf =
    let ki = keys_insert (keys am) am k av Refl
        p = contains_all_key_insert (keys am) bm k bv prf
    in rewrite ki in p

{-half_keys_eq_remove_right : (am : Map a) -> (bm : Map b) -> (k : Key) ->
    NotInMap k am -> half_keys_eq am bm = True -> half_keys_eq am (remove k bm) = True

half_keys_eq_remove_left : (am : Map a) -> (bm : Map b) -> (k : Key) ->
    half_keys_eq am bm = True -> half_keys_eq (remove k am) bm = True-}

public export
half_keys_eq_remove : (am : Map a) -> (bm : Map b) -> (k : Key) ->
    half_keys_eq am bm = True -> half_keys_eq (remove k am) (remove k bm) = True
{-half_keys_eq_remove am bm k prf =
    let left = half_keys_eq_remove_left am bm k prf
        right = half_keys_eq_remove_right (remove k am) bm k (remove_contains k am) left
    in right-}

public export
not_half_keys_eq : (am : Map a) -> (bm : Map b) -> (k : Key) ->
    contains k am = True -> contains k bm = False -> half_keys_eq am bm = False


-- -------------------------------------------------------------- [ Lens.idr ]
-- Description : Idris port of Control.Lens
-- Copyright   : (c) Huw Campbell
-- --------------------------------------------------------------------- [ EOH ]
module Data.Curried

import Data.Morphisms

public export
data Curried : ( g : Type -> Type ) -> ( h : Type -> Type ) -> ( a : Type ) -> Type where
  MkCurried : (forall r. g (a -> r) -> h r) -> Curried g h a

public export
Functor g => Functor (Curried g h) where
  map f (MkCurried g) = MkCurried (g . map (. f))

public export
Functor g => Applicative (Curried g g) where
  pure a = MkCurried (map (\f => f a))
  (MkCurried mf) <*> (MkCurried ma) = MkCurried (ma . mf . map (.))

public export
liftCurried : Applicative f => f a -> Curried f f a
liftCurried fa = MkCurried (<*> fa)

public export
lowerCurried : Applicative f => Curried f g a -> g a
lowerCurried (MkCurried f) = f (pure id)


replicateTR : Nat -> a -> List a
replicateTR n v = go n Nil
  where go : Nat -> List a -> List a
        go 0     as = as
        go (S k) as = go k (v :: as)

main : IO ()
main =  printLn (length $ fastPack $ replicateTR 1000000 '0')
     >> putStrLn (fastConcat $ replicateTR 1000000 "")