module InsertionProof

import Data.Vect
import congruence
import Data.Fin
import Permutation
import PermCons
import Finite
import DecOrderNat
import LTE_Properties
import SortingWithProof
import InsertionSort
import InsertionHelpers
import PermConsProperties

%access public export
%default total

insertProof : (n : Nat) -> (a : Nat) -> (xs : (Vect n Nat)) ->
              (SortedVect n xs) -> (SortedVect (S n) (a :: xs))

insertProof Z a Nil sorted_Nil =
    ( [a] ** ((Idt (S Z) ** (Refl, (insertHelper8 a)))))

insertProof (S Z) a [x] sorted_x = case (decMin a x) of
    (Left pfLTE) => let
        pf = insertHelper8 x
        in
        ( [a, x] ** ((Idt 2) ** (Refl, (insertHelper1 Z a x Nil pfLTE pf))))
    (Right pfLTE) => let
        pf = insertHelper8 a
        in
        ( [x, a] ** ((Swap 2 FZ) ** (Refl, (insertHelper1 Z x a Nil pfLTE pf))))

insertProof (S (S n)) a xs sorted_xs = let
    {-
    (x :: u) = (fst sorted_xs)
    perm_xs = (fst (snd sorted_xs))
    pf_total_xs = (snd (snd sorted_xs))
    pf_perm_xs = fst pf_total_xs  -- perm_xs xs = (x :: u)
    pf_sorted_xs = snd pf_total_xs

    in

    case (decMin a (head (fst sorted_xs))) of

        (Left pfLTE) => let

            perm = includePerm (S (S n)) (fst (snd sorted_xs)) -- perm_xs as a permutation of a :: xs

            pf1_1 = PermC_prp_1 (S (S n)) a xs (fst (snd sorted_xs))
            -- ( (a :: (applyPerm n Nat perm xs)) = (applyPerm (S n) Nat (includePerm n perm) (a :: xs)))

            pf1_2 = congruence (Vect (S (S n)) Nat) (Vect (S (S (S n))) Nat)
                (fst sorted_xs) (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs)
                (\k => (a :: k)) (sym pf_perm_xs)
            -- a :: fst sorted_xs = a :: applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs

            pf1_3 = sym (trans pf1_2 pf1_1)
            -- applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs) = a :: fst sorted_xs

            pf1_5 = (\k => (insertHelper10 (S n) (fst sorted_xs) k (pf_sorted_xs k)))

            pf1_4 = insertHelper1 (S n) a (head (fst sorted_xs)) (tail (fst sorted_xs)) pfLTE pf1_5

            in
            ((a :: (fst sorted_xs)) ** (perm ** (pf1_3, ?rhs)))

        (Right pfLTE) => ?rhs2
      -}

    (x1 :: v1) = (fst sorted_xs)
    x = (head (fst sorted_xs))
    u = (tail (fst sorted_xs))
    perm_xs = (fst (snd sorted_xs))
    pf_total_xs = (snd (snd sorted_xs))
    pf_perm_xs = fst pf_total_xs  -- perm_xs xs = v
    pf_sorted_xs = snd pf_total_xs
    pf1_5 = (\k => (insertHelper10 (S n) (fst sorted_xs) k (pf_sorted_xs k)))

    -- IsSorted (S (S n)) (head (fst sorted_xs) :: tail (fst sorted_xs)) :=

    --  (k16 : Fin (S (S n))) ->
    --      LTE (index (Data.Fin.Fin (S n) implementation of Prelude.Enum, method pred k16)
    --          (head (fst sorted_xs) :: tail (fst sorted_xs)))
    --              (index k16 (head (fst sorted_xs) :: tail (fst sorted_xs)))

    in

    case (decMin a (head (fst sorted_xs))) of

        (Left pfLTE) =>
        let
            perm = includePerm (S (S n)) (fst (snd sorted_xs))

            pf1_1 = PermC_prp_1 (S (S n)) a xs (fst (snd sorted_xs))
            -- a :: applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs =
            --    applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)

            pf1_2 = congruence (Vect (S (S n)) Nat) (Vect (S (S (S n))) Nat)
                (fst sorted_xs) (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs)
                (\k => (a :: k)) (sym pf_perm_xs)
            -- a :: fst sorted_xs = a :: applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs

            pf1_3 = sym (trans pf1_2 pf1_1)
            -- applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs) = a :: fst sorted_xs

            pf1_4 = insertHelper1 (S n) a (head (fst sorted_xs)) (tail (fst sorted_xs)) pfLTE pf1_5 --pf_sorted_xs

            -- IsSorted (S (S (S n))) (a :: (head (fst sorted_xs) :: tail (fst sorted_xs))) :=

            --(k : Fin (S (S (S n)))) ->
            --    LTE (index (Data.Fin.Fin (S n) implementation of Prelude.Enum, method pred k)
            --        (a :: head (fst sorted_xs) :: tail (fst sorted_xs)))
            --            (index k (a :: head (fst sorted_xs) :: tail (fst sorted_xs)))

            pf1_7 = vect_prp1 (S n) (fst sorted_xs)
            -- fst sorted_xs = head (fst sorted_xs) :: tail (fst sorted_xs)

            pf1_8 = congruence (Vect (S (S n)) Nat) (Vect (S (S (S n))) Nat) (fst sorted_xs)
                ((head (fst sorted_xs)) :: (tail (fst sorted_xs))) (\k => (a :: k)) pf1_7
            -- a :: fst sorted_xs = a :: head (fst sorted_xs) :: tail (fst sorted_xs)

            pf1_6 = insertHelper11 (S (S n)) (a :: head (fst sorted_xs) :: tail (fst sorted_xs))
                (a :: (fst sorted_xs)) (sym pf1_8) pf1_4
            -- IsSorted (S (S (S n))) (a :: (fst sorted_xs)) :=

            --(k : Fin (S (S (S n)))) ->
            --    LTE (index (Data.Fin.Fin (S n) implementation of Prelude.Enum, method pred k) (a :: fst sorted_xs))
            --        (index k (a :: fst sorted_xs))

            in
            ( (a :: (fst sorted_xs)) ** (perm ** (pf1_3, pf1_6)))

        (Right pfLTE) =>

        let

            pf2_1 = insertHelper9 (S n) (head (fst sorted_xs)) (tail (fst sorted_xs)) pf1_5
            -- IsSorted (S n) (tail (fst sorted_xs))

            pf2_2 = PermC_prp_2 (S n) (tail (fst sorted_xs))
            -- applyPerm (S n) Nat (Idt (S n)) (tail (fst sorted_xs)) = tail (fst sorted_xs)

            -- (k : Fin (S n)) ->
            --     LTE (index (Data.Fin.Fin (S n) implementation of Prelude.Enum, method pred k) (tail (fst sorted_xs)))
            --         (index k (tail (fst sorted_xs)))

            sorted_a_xs = insertProof (S n) a (tail (fst sorted_xs))
                ((tail (fst sorted_xs)) ** ((Idt (S n)) ** (pf2_2, pf2_1)))

            perm_a_xs = (fst (snd (sorted_a_xs)))

            perm = CPerm (S (S (S n)))
                (CPerm (S (S (S n))) (includePerm (S (S n)) (fst (snd (sorted_a_xs)))) (Swap (S (S (S n))) FZ) )
                (includePerm (S (S n)) (fst (snd (sorted_xs))))

            pf2_3 = PermC_prp_1 (S (S n)) a xs (fst (snd sorted_xs))
            -- a :: applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs =
            --     applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)

            pf2_4 = congruence (Vect (S (S (S n))) Nat) Nat
                    (a :: (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs))
                    (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))
                     (\k => (index FZ k)) pf2_3
            -- a = index FZ (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))

            pf2_5 = PermC_prp_1 (S (S n))

                       (index (FS FZ) (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)))

                       ((index FZ (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))) ::
                        (tail (tail (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)))))

                        (fst (snd (insertProof (S n) a
                                                      (tail (fst sorted_xs))
                                                      (tail (fst sorted_xs) **
                                                      (Idt (S n)) **
                                                      ( (PermC_prp_2 (S n) (tail (fst sorted_xs))),
                                                        (insertHelper9 (S n) (head (fst sorted_xs)) (tail (fst sorted_xs)) pf1_5))))))

            -- now want to prove that x = (index (FS FZ) (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)))

            pf2_6 = congruence (Vect (S (S (S n))) Nat) Nat

                        (a :: applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs)

                        (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))

                        (\us => (index (FS FZ) us))

                        pf2_3

            -- index FZ (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs) =
            --     index (FS FZ) (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))

            pf2_7 = congruence (Vect (S (S n)) Nat) Nat

                    (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs)

                    (fst (sorted_xs))

                    (\us => ((index FZ) us))

                    pf_perm_xs

             -- index FZ (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs) = index FZ (fst sorted_xs)

            pf2_8 = trans (sym pf2_6) pf2_7

            -- index (FS FZ) (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)) =
            --    index FZ (fst sorted_xs)

            pf2_10 = insertHelper12 (S n) (fst sorted_xs)

            -- ((index FZ (fst (sorted_xs))) = (head (fst sorted_xs)))

            pf2_11 = trans pf2_8 pf2_10

            -- index (FS FZ) (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)) =
            -- head (fst sorted_xs)

            pf2_9 = congruence Nat (Vect (S (S (S n))) Nat)

                    (index (FS FZ) (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)))

                    (head (fst sorted_xs)) --(index FZ (fst sorted_xs))

                    (\z => (z :: (fst (insertProof (S n)
                          a
                         (tail (fst sorted_xs))
                         (tail (fst sorted_xs) **
                          Idt (S n) **
                          (PermC_prp_2 (S n) (tail (fst sorted_xs)), insertHelper9 (S n) (head (fst sorted_xs)) (tail (fst sorted_xs)) pf1_5))))))

                    pf2_11

            -- ||||||||||||   code is running but taking too long

            {-

            pf_sorted_a_xs_total = (snd (snd sorted_a_xs))

            pf_perm_a_xs = (fst pf_sorted_a_xs_total)

            pf2_12 = congruence Nat (Vect (S (S n)) Nat) a

                (index FZ (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)))

                (\s => (s :: (tail (fst sorted_xs))))

                pf2_4

            -- a :: tail (fst sorted_xs) =
            -- index FZ (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)) :: tail (fst sorted_xs)

            -- want to prove
            -- (index FZ (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)) ::
            --     tail (tail (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)))) =
            -- (a :: tail (fst sorted_xs))

            -- check pf2_4

            -- want to prove
            -- (tail (fst sorted_xs)) = (tail (tail (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))))

            pf2_13 = PermC_prp_1 (S (S n)) a xs (fst (snd sorted_xs))

            --  a :: applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs =
            -- applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs)

            pf2_14 = insertHelper13 (S (S n)) a (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs)

            pf2_15 = congruence (Vect (S (S (S n))) Nat) (Vect (S (S n)) Nat)
                (a :: (applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs))
                (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))
                (\v => (tail v))
                pf2_13

            -- applyPerm (S (S n)) Nat (fst (snd sorted_xs)) xs =
            -- tail (applyPerm (S (S (S n))) Nat (includePerm (S (S n)) (fst (snd sorted_xs))) (a :: xs))

            pf2_16 = trans (sym pf_perm_xs) pf2_15
            -}

            in
            (((head (fst sorted_xs)) :: (fst sorted_a_xs)) ** (perm ** ((trans (trans (sym pf2_5) ?rhs21) pf2_9), ?rhs22)))


module Main

id' : t -> t
id' x = x

-- type Dependent version of id
-- taking an explicit type as its first argument
the' : (t : Type) -> t -> t
the' t x = x

-- *hai> the' (Int)
-- the' Int : Int -> Int
-- *hai> the' (Int) 1
-- 1 : Int
-- *hai> id' 1
-- 1 : Integer

main : IO ()
main = putStrLn "Oh, hai"

StringOrIntType : Bool -> Type
StringOrIntType x = case x of
                  True => Int
                  False => String

stringOrIntVal : (x : Bool) -> StringOrIntType x
stringOrIntVal x = case x of
                      True => 7
                      False => "Seven"

valToString : (x : Bool) -> StringOrIntType x -> String
valToString x val = case x of
                        True => cast val
                        False => val

valToStringWithHole : (x : Bool) -> StringOrIntType x -> String
valToStringWithHole x val = case x of
                        True => ?xTrueType -- holes
                        False => ?xFalseType -- ctrl + alt + t

-- idris hai.idr
-- hai> valToString False "yaay"
-- "yaay" : String
-- *hai> valToString True 2
-- "2" : String


module Flexidisc.Header.Label

import Flexidisc.Header.Type
import Flexidisc.OrdList

%default total
%access public export

||| Proof that a label is in an `Header'`
data Label : (l : k) -> (xs : Header' k a) -> Type where
  ||| A wrapper for an `OrdLabel`
  L : {xs : OrdList k o a} -> OrdLabel l xs -> Label l (H xs)

%name Label lbl, loc, prf, e, elem

||| Decide whether a label is in a list or not
decLabel : DecEq k => (l : k) -> (xs : Header' k a) -> Dec (Label l xs)
decLabel l (H xs) with (decLabel l xs)
  | (Yes prf) = Yes (L prf)
  | (No contra) = No (\(L p) => contra p)

||| Given a proof that a label is in the list, get the corresponding value back
atLabel : (xs : Header' l a) -> (loc : Label k xs) -> a
atLabel (H xs) (L loc) = atLabel xs loc

||| Given a proof that an element is in a vector, remove it
dropLabel : (xs : Header' k a) -> (loc : Label l xs) -> Header' k a
dropLabel (H xs) (L loc) = H (dropLabel xs loc)

||| Update a value in the `Header'` given it's location and a new value
changeType : (xs : Header' k a) -> (loc : Label l xs) -> (new : a) ->
             Header' k a
changeType (H xs) (L loc) = H . changeValue xs loc


import Data.List
import Data.List.Elem

%search_timeout 1000

||| A Place has an ID and a number of tokens
data Place : Type where
  MkPlace : (i : Nat) -> (nTokens : Nat) -> Place

||| A transition has a name
data Transition : Type where
  MkTransition : String -> Transition

||| An Input links a Place and a Transition...
data Input : Type where
  MkInput : (from : Place) -> (to : Transition) -> Input

-- Accessor functions for proof
0 inputFrom : Input -> Place
inputFrom (MkInput p t) = p

0 inputTo : Input -> Transition
inputTo (MkInput p t) = t

data SoundInputFrom : Input -> List Place -> Type where
  MkSoundInputFrom : (i : Input)
                     -> (ps : List Place)
                     -> (prf : Elem (inputFrom i) ps)
                     -> SoundInputFrom i ps

data SoundInputTo : Input -> List Transition -> Type where
  MkSoundInputTo : (i : Input)
                   -> (ts : List Transition)
                   -> (prf : Elem (inputTo i) ts)
                   -> SoundInputTo i ts

data SoundInput : Input -> List Place -> List Transition -> Type where
  MkSoundInput : (i : Input)
                 -> (ps : List Place)
                 -> (ts : List Transition)
                 -> (fromOK : SoundInputFrom i ps)
                 -> (toOK   : SoundInputTo   i ts)
                 -> SoundInput i ps ts

data AllInputsSound : List Input -> List Place -> List Transition -> Type where
  NilInputsIsSound : AllInputsSound [] _ _
  ConsIsSound : (headIsSound : SoundInput i ps ts)
                -> (tailIsSound : AllInputsSound is ps ts)
                -> AllInputsSound (i :: is) ps ts

-- Searching here finds the right answer immediately, but then if we don't
-- have a timeout, it takes ages to explore more non-solutions! So we cut off
-- after a second
tailIsNotSound : (contra : (AllInputsSound is ps ts -> Void))
                 -> AllInputsSound (i :: is) ps ts
                 -> Void


import Control.Indexed
import Control.Monad.Indexed.State

data State = One | Two | Three

data Transition : Type -> State -> State -> Type where
  Pure : (x : a) -> Transition a s s
  First : Transition () One Two
  Second : Transition () Two Three
  Third : Transition () Three One
  Bind : Transition a x y -> (a -> Transition b y z) -> Transition b x z

IndexedFunctor State State Transition where
  map f (Pure x)   = Pure (f x)
  map f First      = Bind First  (Pure . f)
  map f Second     = Bind Second (Pure . f)
  map f Third      = Bind Third  (Pure . f)
  map f (Bind x g) = Bind x (\x' => map f (g x'))

[n1] IndexedApplicative State Transition where
  pure = Pure
  ap (Pure f) x = map f x
  ap (Bind y f) x =
    Bind y $ \y' =>
      Bind (f y') $ \f' =>
        Bind x (\x' => Pure (f' x'))

IndexedMonad State Transition using n1 where
  bind = Bind

data Meta = Description String

||| A Transition plus some metadata
TransitionPlus : Type -> State -> State -> Type
TransitionPlus = IndexedStateT Meta State State Transition

main : TransitionPlus () One One
main = do
  put $ Description "meta text"
  lift $ do
    First
    Second
  x <- get
  lift $ do
    Indexed.ignore $ Pure x
    Third


module TypedContainers.LawfulOrd

%default total

public export
interface LawfulOrd a where
  compare : a -> a -> Ordering
  0 reflexivity : (x : a) -> (compare x x = EQ)
  0 reversion1 : (x : a) -> (y : a) -> (compare x y = LT) -> (compare y x = GT)
  0 reversion2 : (x : a) -> (y : a) -> (compare x y = GT) -> (compare y x = LT)
  0 reversion3 : (x : a) -> (y : a) -> (compare x y = EQ) -> (compare y x = EQ)
  0 transitivity : (x : a) -> (y : a) -> (z : a) -> (compare x y = LT) -> (compare y z = LT) -> (compare x z = LT)
  0 equality1 : (x : a) -> (y : a) -> (z : a) -> (compare x y = EQ) -> (compare x z = compare y z)
  0 equality2 : (x : a) -> (y : a) -> (z : a) -> (compare x y = EQ) -> (compare z x = compare z y)

public export
interface LawfulOrd a => LawfullerOrd a where
  -- `compare` needs to be unambigious here because the name is
  -- seemingly resolved where the instances are defined...
  0 realEquality : (x : a) -> (y : a) -> (TypedContainers.LawfulOrd.compare x y = EQ) -> (x = y)

public export
(==) : LawfulOrd a => a -> a -> Bool
x == y = case compare x y of { EQ => True; _ => False }

public export
(<) : LawfulOrd a => a -> a -> Bool
x < y = case compare x y of { LT => True; _ => False }

public export
(>) : LawfulOrd a => a -> a -> Bool
x > y = case compare x y of { GT => True; _ => False }

public export
convLT : LawfulOrd a => (x : a) -> (y : a) -> (x < y = True) -> (compare x y = LT)
convLT x y p with (compare x y)
  convLT x y Refl | GT impossible
  convLT x y Refl | EQ impossible
  convLT x y Refl | LT = Refl

public export
convGT : LawfulOrd a => (x : a) -> (y : a) -> (x > y = True) -> (compare x y = GT)
convGT x y p with (compare x y)
  convGT x y Refl | GT = Refl
  convGT x y Refl | EQ impossible
  convGT x y Refl | LT impossible

public export
convEQ : LawfulOrd a => (x : a) -> (y : a) -> (x == y = True) -> (compare x y = EQ)
convEQ x y p with (compare x y)
  convEQ x y Refl | GT impossible
  convEQ x y Refl | EQ = Refl
  convEQ x y Refl | LT impossible


module Prelude.Interfaces

import Builtin
import Prelude.Basics
import Prelude.EqOrd
import Prelude.Num
import Prelude.Ops

%default total

-------------
-- ALGEBRA --
-------------

||| Sets equipped with a single binary operation that is associative.  Must
||| satisfy the following laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
public export
interface Semigroup ty where
  constructor MkSemigroup
  (<+>) : ty -> ty -> ty

||| Sets equipped with a single binary operation that is associative, along with
||| a neutral element for that binary operation.  Must satisfy the following
||| laws:
|||
||| + Associativity of `<+>`:
|||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c
||| + Neutral for `<+>`:
|||     forall a, a <+> neutral == a
|||     forall a, neutral <+> a == a
public export
interface Semigroup ty => Monoid ty where
  constructor MkMonoid
  neutral : ty

public export
Semigroup () where
  _ <+> _ = ()

public export
Monoid () where
  neutral = ()

public export
Semigroup a => Semigroup b => Semigroup (a, b) where
  (x, y) <+> (v, w) = (x <+> v, y <+> w)

public export
Monoid a => Monoid b => Monoid (a, b) where
  neutral = (neutral, neutral)

public export
Semigroup Ordering where
  LT <+> _ = LT
  GT <+> _ = GT
  EQ <+> o =  o

public export
Monoid Ordering where
  neutral = EQ

public export
Semigroup b => Semigroup (a -> b) where
  (f <+> g) x = f x <+> g x

public export
Monoid b => Monoid (a -> b) where
  neutral _ = neutral

---------------------------------------------------------
-- FUNCTOR, BIFUNCTOR, APPLICATIVE, ALTERNATIVE, MONAD --
---------------------------------------------------------

||| Functors allow a uniform action over a parameterised type.
||| @ f a parameterised type
public export
interface Functor f where
  constructor MkFunctor
  ||| Apply a function across everything of type 'a' in a parameterised type
  ||| @ f the parameterised type
  ||| @ func the function to apply
  map : (func : a -> b) -> f a -> f b

||| An infix alias for `map`, applying a function across everything of type 'a'
||| in a parameterised type.
||| @ f the parameterised type
||| @ func the function to apply
public export
(<$>) : Functor f => (func : a -> b) -> f a -> f b
(<$>) func x = map func x

||| Flipped version of `<$>`, an infix alias for `map`, applying a function across
||| everything of type 'a' in a parameterised type.
||| @ f the parameterised type
||| @ func the function to apply
public export
(<&>) : Functor f => f a -> (func : a -> b) -> f b
(<&>) x func = map func x

||| Run something for effects, replacing the return value with a given parameter.
public export
(<$) : Functor f => b -> f a -> f b
(<$) b = map (const b)

||| Flipped version of `<$`.
public export
($>) : Functor f => f a -> b -> f b
($>) fa b = map (const b) fa

||| Run something for effects, throwing away the return value.
%inline
public export
ignore : Functor f => f a -> f ()
ignore = map (const ())

namespace Functor
  ||| Composition of functors is a functor.
  public export
  [Compose] (Functor f, Functor g) => Functor (f . g) where
    map = map . map

||| Bifunctors
||| @f The action of the Bifunctor on pairs of objects
public export
interface Bifunctor f where
  constructor MkBifunctor
  ||| The action of the Bifunctor on pairs of morphisms
  |||
  ||| ````idris example
  ||| bimap (\x => x + 1) reverse (1, "hello") == (2, "olleh")
  ||| ````
  |||
  bimap : (a -> c) -> (b -> d) -> f a b -> f c d
  bimap f g = mapFst f . mapSnd g

  ||| The action of the Bifunctor on morphisms pertaining to the first object
  |||
  ||| ````idris example
  ||| mapFst (\x => x + 1) (1, "hello") == (2, "hello")
  ||| ````
  |||
  mapFst : (a -> c) -> f a b -> f c b
  mapFst f = bimap f id

  ||| The action of the Bifunctor on morphisms pertaining to the second object
  |||
  ||| ````idris example
  ||| mapSnd reverse (1, "hello") == (1, "olleh")
  ||| ````
  |||
  mapSnd : (b -> d) -> f a b -> f a d
  mapSnd = bimap id

public export
mapHom : Bifunctor f => (a -> b) -> f a a -> f b b
mapHom f = bimap f f

public export
interface Functor f => Applicative f where
  constructor MkApplicative
  pure : a -> f a
  (<*>) : f (a -> b) -> f a -> f b

public export
(<*) : Applicative f => f a -> f b -> f a
a <* b = map const a <*> b

public export
(*>) : Applicative f => f a -> f b -> f b
a *> b = map (const id) a <*> b

%allow_overloads pure
%allow_overloads (<*)
%allow_overloads (*>)

namespace Applicative
  ||| Composition of applicative functors is an applicative functor.
  public export
  [Compose] (Applicative f, Applicative g) => Applicative (f . g)
    using Functor.Compose where
      pure = pure . pure
      fun <*> x = [| fun <*> x |]

public export
interface Applicative f => Alternative f where
  constructor MkAlternative
  empty : f a
  (<|>) : f a -> Lazy (f a) -> f a

public export
interface Applicative m => Monad m where
  constructor MkMonad
  ||| Also called `bind`.
  (>>=) : m a -> (a -> m b) -> m b

  ||| Also called `flatten` or mu.
  join : m (m a) -> m a

  -- default implementations
  (>>=) x f = join (f <$> x)
  join x = x >>= id

%allow_overloads (>>=)

||| Right-to-left monadic bind, flipped version of `>>=`.
public export
(=<<) : Monad m => (a -> m b) -> m a -> m b
(=<<) = flip (>>=)

||| Sequencing of effectful composition
public export
(>>) : Monad m => m () -> Lazy (m b) -> m b
a >> b = a >>= \_ => b

||| Left-to-right Kleisli composition of monads.
public export
(>=>) : Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
(>=>) f g = \x => f x >>= g

||| Right-to-left Kleisli composition of monads, flipped version of `>=>`.
public export
(<=<) : Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
(<=<) = flip (>=>)

||| `guard a` is `pure ()` if `a` is `True` and `empty` if `a` is `False`.
public export
guard : Alternative f => Bool -> f ()
guard x = if x then pure () else empty

||| Conditionally execute an applicative expression when the boolean is true.
public export
when : Applicative f => Bool -> Lazy (f ()) -> f ()
when True f = f
when False f = pure ()

||| Execute an applicative expression unless the boolean is true.
%inline public export
unless : Applicative f => Bool -> Lazy (f ()) -> f ()
unless = when . not

---------------------------
-- FOLDABLE, TRAVERSABLE --
---------------------------

||| The `Foldable` interface describes how you can iterate over the elements in
||| a parameterised type and combine the elements together, using a provided
||| function, into a single result.
||| @ t The type of the 'Foldable' parameterised type.
public export
interface Foldable t where
  constructor MkFoldable
  ||| Successively combine the elements in a parameterised type using the
  ||| provided function, starting with the element that is in the final position
  ||| i.e. the right-most position.
  ||| @ func  The function used to 'fold' an element into the accumulated result
  ||| @ init  The starting value the results are being combined into
  ||| @ input The parameterised type
  foldr : (func : elem -> acc -> acc) -> (init : acc) -> (input : t elem) -> acc

  ||| The same as `foldr` but begins the folding from the element at the initial
  ||| position in the data structure i.e. the left-most position.
  ||| @ func  The function used to 'fold' an element into the accumulated result
  ||| @ init  The starting value the results are being combined into
  ||| @ input The parameterised type
  foldl : (func : acc -> elem -> acc) -> (init : acc) -> (input : t elem) -> acc
  foldl f z t = foldr (flip (.) . flip f) id t z

  ||| Test whether the structure is empty.
  ||| @ acc The accumulator value which is specified to be lazy
  null : t elem -> Lazy Bool
  null = foldr {acc = Lazy Bool} (\ _,_ => False) True

  ||| Similar to `foldl`, but uses a function wrapping its result in a `Monad`.
  ||| Consequently, the final value is wrapped in the same `Monad`.
  foldlM : Monad m => (funcM : acc -> elem -> m acc) -> (init : acc) -> (input : t elem) -> m acc
  foldlM fm a0 = foldl (\ma, b => ma >>= flip fm b) (pure a0)

  ||| Produce a list of the elements contained in the parametrised type.
  toList : t elem -> List elem
  toList = foldr (::) []

  ||| Maps each element to a value and combine them.
  ||| For performance reasons, this should wherever
  ||| be implemented with tail recursion.
  ||| @ f The function to apply to each element.
  foldMap : Monoid m => (f : a -> m) -> t a -> m
  foldMap f = foldr ((<+>) . f) neutral

||| Combine each element of a structure into a monoid.
public export
concat : (Foldable t, Monoid a) => t a -> a
concat = foldMap id

||| Combine into a monoid the collective results of applying a function to each
||| element of a structure.
public export
concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m
concatMap = foldMap

namespace Bool.Lazy
  namespace Semigroup
    public export
    [Any] Semigroup (Lazy Bool) where
      x <+> y = force x || y

    public export
    [All] Semigroup (Lazy Bool) where
      x <+> y = force x && y

  namespace Monoid
    public export
    [Any] Monoid (Lazy Bool) using Semigroup.Any where
      neutral = delay False

    public export
    [All] Monoid (Lazy Bool) using Semigroup.All where
      neutral = delay True

||| The conjunction of all elements of a structure containing lazy boolean
||| values.  `and` short-circuits from left to right, evaluating until either an
||| element is `False` or no elements remain.
public export
and : Foldable t => t (Lazy Bool) -> Bool
and = force . concat @{(%search, All)}

||| The disjunction of all elements of a structure containing lazy boolean
||| values.  `or` short-circuits from left to right, evaluating either until an
||| element is `True` or no elements remain.
public export
or : Foldable t => t (Lazy Bool) -> Bool
or = force . concat @{(%search, Any)}

namespace Bool
  namespace Semigroup
    public export
    [Any] Semigroup Bool where
      x <+> y = x || delay y

    public export
    [All] Semigroup Bool where
      x <+> y = x && delay y

  namespace Monoid
    public export
    [Any] Monoid Bool using Bool.Semigroup.Any where
      neutral = False

    public export
    [All] Monoid Bool using Bool.Semigroup.All where
      neutral = True

||| The disjunction of the collective results of applying a predicate to all
||| elements of a structure.  `any` short-circuits from left to right.
public export
any : Foldable t => (a -> Bool) -> t a -> Bool
any = foldMap @{%search} @{Any}

||| The disjunction of the collective results of applying a predicate to all
||| elements of a structure.  `all` short-circuits from left to right.
public export
all : Foldable t => (a -> Bool) -> t a -> Bool
all = foldMap @{%search} @{All}
  where
    monoid : Monoid Bool
    monoid = MkMonoid @{MkSemigroup (\x, y => x && y)} True

namespace Num
  namespace Semigroup
    public export
    [Additive] Num a => Semigroup a where
      (<+>) = (+)

    public export
    [Multiplicative] Num a => Semigroup a where
      (<+>) = (*)

  namespace Monoid
    public export
    [Additive] Num a => Monoid a using Semigroup.Additive where
      neutral = 0

    public export
    [Multiplicative] Num a => Monoid a using Semigroup.Multiplicative where
      neutral = 1

||| Add together all the elements of a structure.
public export
sum : (Foldable t, Num a) => t a -> a
sum = concat @{(%search, Additive)}

||| Add together all the elements of a structure.
||| Same as `sum` but tail recursive.
export
sum' : (Foldable t, Num a) => t a -> a
sum' = sum

||| Multiply together all elements of a structure.
public export
product : (Foldable t, Num a) => t a -> a
product = concat @{(%search, Multiplicative)}

||| Multiply together all elements of a structure.
||| Same as `product` but tail recursive.
export
product' : (Foldable t, Num a) => t a -> a
product' = product

||| Map each element of a structure to a computation, evaluate those
||| computations and discard the results.
public export
traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()
traverse_ f = foldr ((*>) . f) (pure ())

||| Evaluate each computation in a structure and discard the results.
public export
sequence_ : (Foldable t, Applicative f) => t (f a) -> f ()
sequence_ = foldr (*>) (pure ())

||| Like `traverse_` but with the arguments flipped.
public export
for_ : (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()
for_ = flip traverse_

namespace Lazy
  public export
  [SemigroupAlternative] Alternative f => Semigroup (Lazy (f a)) where
    x <+> y = force x <|> y

  public export
  [MonoidAlternative] Alternative f => Monoid (Lazy (f a)) using Lazy.SemigroupAlternative where
    neutral = delay empty

public export
[SemigroupAlternative] Alternative f => Semigroup (f a) where
  x <+> y = x <|> delay y

public export
[MonoidAlternative] Alternative f => Monoid (f a) using Interfaces.SemigroupAlternative where
  neutral = empty

||| Fold using Alternative.
|||
||| If you have a left-biased alternative operator `<|>`, then `choice` performs
||| left-biased choice from a list of alternatives, which means that it
||| evaluates to the left-most non-`empty` alternative.
|||
||| If the list is empty, or all values in it are `empty`, then it evaluates to
||| `empty`.
|||
||| Example:
|||
||| ```
||| -- given a parser expression like:
||| expr = literal <|> keyword <|> funcall
|||
||| -- choice lets you write this as:
||| expr = choice [literal, keyword, funcall]
||| ```
|||
||| Note: In Haskell, `choice` is called `asum`.
public export
choice : (Foldable t, Alternative f) => t (Lazy (f a)) -> f a
choice = force . concat @{(%search, Lazy.MonoidAlternative)}

||| A fused version of `choice` and `map`.
public export
choiceMap : (Foldable t, Alternative f) => (a -> f b) -> t a -> f b
choiceMap = foldMap @{%search} @{MonoidAlternative}

namespace Foldable
  ||| Composition of foldables is foldable.
  public export
  [Compose] (Foldable t, Foldable f) => Foldable (t . f) where
    foldr = foldr . flip . foldr
    foldl = foldl . foldl
    null tf = null tf || all (force . null) tf
    foldMap = foldMap . foldMap

||| `Bifoldable` identifies foldable structures with two different varieties
||| of elements (as opposed to `Foldable`, which has one variety of element).
||| Common examples are `Either` and `Pair`.
public export
interface Bifoldable p where
  constructor MkBifoldable
  bifoldr : (a -> acc -> acc) -> (b -> acc -> acc) -> acc -> p a b -> acc

  bifoldl : (acc -> a -> acc) -> (acc -> b -> acc) -> acc -> p a b -> acc
  bifoldl f g z t = bifoldr (flip (.) . flip f) (flip (.) . flip g) id t z

  binull : p a b -> Lazy Bool
  binull = bifoldr {acc = Lazy Bool} (\ _,_ => False) (\ _,_ => False) True

public export
interface (Functor t, Foldable t) => Traversable t where
  constructor MkTraversable
  ||| Map each element of a structure to a computation, evaluate those
  ||| computations and combine the results.
  traverse : Applicative f => (a -> f b) -> t a -> f (t b)

||| Evaluate each computation in a structure and collect the results.
public export
sequence : (Traversable t, Applicative f) => t (f a) -> f (t a)
sequence = traverse id

||| Like `traverse` but with the arguments flipped.
public export
for : (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)
for = flip traverse

public export
interface (Bifunctor p, Bifoldable p) => Bitraversable p where
  constructor MkBitraversable
  ||| Map each element of a structure to a computation, evaluate those
  ||| computations and combine the results.
  bitraverse : Applicative f => (a -> f c) -> (b -> f d) -> p a b -> f (p c d)

||| Evaluate each computation in a structure and collect the results.
public export
bisequence : (Bitraversable p, Applicative f) => p (f a) (f b) -> f (p a b)
bisequence = bitraverse id id

||| Like `bitraverse` but with the arguments flipped.
public export
bifor :  (Bitraversable p, Applicative f)
      => p a b
      -> (a -> f c)
      -> (b -> f d)
      -> f (p c d)
bifor t f g = bitraverse f g t

namespace Traversable
  ||| Composition of traversables is traversable.
  public export
  [Compose] (Traversable t, Traversable f) => Traversable (t . f)
    using Foldable.Compose Functor.Compose where
      traverse = traverse . traverse

namespace Monad
  ||| Composition of a traversable monad and a monad is a monad.
  public export
  [Compose] (Monad m, Monad t, Traversable t) => Monad (m . t)
    using Applicative.Compose where
      a >>= f = a >>= map join . traverse f


||| The content of this module is based on the paper
||| Applications of Applicative Proof Search
||| by Liam O'Connor

module Search.HDecidable

import Data.List.Lazy
import Data.List.Lazy.Quantifiers
import Data.List.Quantifiers
import Data.So

import Search.Negation

%default total

------------------------------------------------------------------------
-- Type, basic functions, and interface

||| Half a decider: when the search succeeds we bother building the proof
public export
record HDec (a : Type) where
  constructor MkHDec
  isTrue   : Bool
  evidence : So isTrue -> a

||| Happy path: we have found a proof!
public export
yes : a -> HDec a
yes = MkHDec True . const

||| Giving up
public export
no : HDec a
no = MkHDec False absurd

public export
fromDec : Dec a -> HDec a
fromDec (Yes p) = yes p
fromDec (No _) = no

public export
fromMaybe : Maybe a -> HDec a
fromMaybe = maybe no yes

public export
toMaybe : HDec a -> Maybe a
toMaybe (MkHDec True p) = Just (p Oh)
toMaybe (MkHDec False _) = Nothing

||| A type constructor satisfying AnHdec is morally an HDec i.e. we can
||| turn values of this type constructor into half deciders
||| It may be more powerful (like Dec) or more basic (like Maybe).

public export
interface AnHDec (0 t : Type -> Type) where
  toHDec : t a -> HDec a

public export AnHDec Dec where toHDec = fromDec
public export AnHDec HDec where toHDec = id
public export AnHDec Maybe where toHDec = fromMaybe

------------------------------------------------------------------------
-- Implementations

public export
Functor HDec where
  map f (MkHDec b prf) = MkHDec b (f . prf)

public export
Applicative HDec where
  pure = yes
  MkHDec False prff <*> _ = MkHDec False absurd
  _ <*> MkHDec False _ = MkHDec False absurd
  MkHDec True prff <*> MkHDec True prfx
    = yes (prff Oh (prfx Oh))

||| Lazy in the second argument
public export
Alternative HDec where
  empty = no
  p@(MkHDec True _) <|> _ = p
  _ <|> q = q

public export
Monad HDec where
  MkHDec True x >>= f = f (x Oh)
  _ >>= _ = no

public export
Show f => Show (HDec f) where
  show (MkHDec True p) = "True: " ++ show (p Oh)
  show _ = "False"

------------------------------------------------------------------------
-- Combinators

||| Half deciders are closed under product
public export
(&&) : (AnHDec l, AnHDec r) => l a -> r b -> HDec (a, b)
p && q = [| (toHDec p, toHDec q) |]

||| Half deciders are closed under sum
public export
(||) : (AnHDec l, AnHDec r) => l a -> r b -> HDec (Either a b)
p || q = [| Left (toHDec p) |] <|> [| Right (toHDec q) |]

||| Half deciders are closed negation. Here we use the `Negates` interface
||| so that we end up looking for *positive* evidence of something which is
||| much easier to find than negative one.
public export
not : (AnHDec l, Negates na a) => l na -> HDec (Not a)
not p = [| toNegation (toHDec p) |]

infixr 3 ==>

||| Half deciders are closed under implication
public export
(==>) : (AnHDec l, AnHDec r, Negates na a) => l na -> r b -> HDec (a -> b)
p ==> q = [| contra (not p) |] <|> [| const (toHDec q) |] where
  contra : Not a -> a -> b
  contra na a = void (na a)

namespace List

  ||| Half deciders are closed under the list quantifier any
  public export
  any : AnHDec l => (xs : List a) -> ((x : a) -> l (p x)) -> HDec (Any p xs)
  any [] p = no
  any (x :: xs) p = [| Here (toHDec (p x)) |] <|> [| There (any xs p) |]

  ||| Half deciders are closed under the list quantifier all
  public export
  all : AnHDec l => (xs : List a) -> ((x : a) -> l (p x)) -> HDec (All p xs)
  all [] p = yes []
  all (x :: xs) p = [| toHDec (p x) :: all xs p |]

namespace LazyList

  ||| Half deciders are closed under the lazy list quantifier any
  public export
  any : AnHDec l => (xs : LazyList a) -> ((x : a) -> l (p x)) -> HDec (Any p xs)
  any [] p = no
  any (x :: xs) p = [| Here (toHDec (p x)) |] <|> [| There (any xs p) |]


module Main

import Data.Vect

-- let .. in defines local variables
-- where .. allows for local function definitions

-- Nat is a natural number type, non-negative integers.
-- ++ is for appending Strings or Lists to each other.
-- words : String -> List String -- splits on a space
average : (str : String) -> Double
average str =
  let
    numWords = wordCount str
    totalLength = sum (allLengths (words str)) in
    cast totalLength / cast numWords -- this line is the result.
  where
    wordCount : String -> Nat
    wordCount str = length (words str)

    allLengths : List String -> List Nat
    allLengths strs = map length strs

showAverage : String -> String
showAverage str =
  "Average word lenth: " ++
  show (average str) ++ "\n"

main : IO ()
main = repl "Enter a string: " showAverage
-- repl displays a prompt, reads a String from the console and displays the
-- result of running a function on that String, forever.

-- Where an expression can be one of several types, you can declare which
-- inline with the function 'the'
-- the Int 45 yields an Int with the value 45. This is not syntax sugar, 'the'
-- is an ordinary function.
-- the : (a: Type) -> a -> a
-- Given a type, a, and a value of that type, 'the' returns the value. The
-- implementation might look like the type = id -- identity

-- Can partially apply functions
add : Num a => a -> a -> a
add x y = x + y
--
add3 : Int -> Int
add3 = add 3

nine : Int
nine = add3 6

-- <T> T identity(T t) { return t; }
identity : ty -> ty
identity x = x

-- If we want to write a function that can add a number to itself, this won't
-- work:
-- bad_double : ty -> ty
-- bad_double x = x + x
-- "ty is not a numeric type"
-- => means we're setting a restriction on a
double : Num ty => ty -> ty
double x = x + x

-- Defining a function that executes a function twice over a value
twice : (a -> a) -> a -> a
twice f x = f (f x)

quadruple : Num a => a -> a
quadruple x = double (double x)

-- lambda is \arg => result
squared_twice : Integer
squared_twice = twice (\x => x * x) 2 -- 16

-- :t \x => x * x -- Integer -> Integer

-- :t \x : Int, y : Int => x + y -- Int -> Int

-- Tuples are nested pairs
tuples_are_nested_pairs : Bool
tuples_are_nested_pairs = (1, (2, (3, (4)))) == (1, 2, 3, 4)

-- Lists use []. Appending two lists:
one_to_seven : List Integer
one_to_seven = [1, 2, 3] ++ [4, 5, 6, 7]

-- Prepending (consing) to a list is (::)
zero_to_seven : List Integer
zero_to_seven = 0 :: one_to_seven

one_to_four : List Integer
one_to_four = 1 :: 2 :: 3 :: 4 :: []

one_to_a_hundred : List Integer
one_to_a_hundred = [1..100]

-- module Xyz at the top of the file, generally matches Xyz.idr in the filename
-- import Foo looks for Foo.idr in the same directory or elsewhere that Idris
-- can find.

{- Multiline
comment -}

||| Documentation comment for foo
foo : String
-- can be viewed with :doc foo or Ctrl-Alt-D in Atom

-- Exercises
-- 1. Types of
-- ("A", "B", "C") -- (String, String, String)
-- ["A", "B", "C"] -- List String
-- (("A", "B"), "C") -- ((String, String), String)

-- Given a natural number, min, and a String, str, convert str to lowercase and
-- return true if it's the same forwards as backwards, as long as it's over the
-- length 'min'.
palindrome : Nat -> String -> Bool
palindrome min str = if (length str > min) then
    (let lstr = toLower str in reverse lstr == lstr)
  else False

-- (x, y) is a tuple of an x and a y. (Nat, Nat) is a type, two natural numbers.
-- (length (words str), length str) is a value of that type.
counts : String -> (Nat, Nat)
counts str = (length (words str), length str)

-- Ord is an interface something like Java's Comparable.
-- <A extends Comparable<A>> List<A> topTen(List<A> list)
top_ten : Ord a => List a -> List a
top_ten list = take 10 (reverse (sort list))

over_length : Nat -> List String -> Nat
over_length len list = length (filter (\str => length str > len) list)


module Libraries.Data.List.Extra

import public Data.List
import Data.List1

%default total

export
minimum : Ord a => (xs : List a) -> {auto 0 _ : NonEmpty xs} -> a
minimum (x :: xs) = foldl min x xs

||| Fetches the element at a given position.
||| Returns `Nothing` if the position beyond the list's end.
public export
elemAt : List a -> Nat -> Maybe a
elemAt []        _     = Nothing
elemAt (l :: _)  Z     = Just l
elemAt (_ :: ls) (S n) = elemAt ls n

export
findBy : (a -> Maybe b) -> List a -> Maybe b
findBy p [] = Nothing
findBy p (x :: xs)
  = case p x of
      Nothing => findBy p xs
      Just win => pure win

export
breakAfter : (a -> Bool) -> List a -> (List a, List a)
breakAfter p [] = ([], [])
breakAfter p (x::xs)
    = if p x
         then ([x], xs)
         else let (ys, zs) = breakAfter p xs in (x::ys, zs)

export
splitAfter : (a -> Bool) -> List a -> List1 (List a)
splitAfter p xs
    = case breakAfter p xs of
           (chunk, []) => singleton chunk
           (chunk, rest@(_::_)) => cons chunk (splitAfter p (assert_smaller xs rest))

export
zipMaybe : List a -> List b -> Maybe (List (a, b))
zipMaybe [] [] = pure []
zipMaybe (a::as) (b::bs) = ((a, b) ::) <$> zipMaybe as bs
zipMaybe _ _ = Nothing

export
findBy' : (a -> Bool) -> List a -> (List a, Maybe a, List a)
findBy' f [] = ([], Nothing, [])
findBy' f (x :: xs) =
  case f x of
    True  => ([], Just x, xs)
    False =>
      let (pre, mb, post) = findBy' f xs in
      (x :: pre, mb, post)

||| Compute the difference of two lists by the given predicate.
||| Lists are treated as bags.
export
diffBy : (a -> a -> Bool)
      -> List a
      -> List a
      -> List a
diffBy f [] ys = []
diffBy f (x :: xs) ys =
  let whole@(pre, mb, post) = findBy' (f x) ys
      ys' = pre ++ post in
  case mb of
    Just _  =>      diffBy f xs ys'
    Nothing => x :: diffBy f xs ys'

||| Remove adjacent duplicates
export
dedup : Eq a => List a -> List a
dedup (a :: xs@(b :: _)) = if a == b then dedup xs else a :: dedup xs
dedup xs                = xs

||| O(n * log(n)). Sort a list and remove duplicates
export
sortedNub : Ord a => List a -> List a
sortedNub = dedup . sort

||| TODO: use the version in `Data.List1` in base after the next release.
export
groupBy : (a -> a -> Bool) -> List a -> List (List1 a)
groupBy _ [] = []
groupBy eq (h :: t) = let (ys,zs) = go h t
                       in ys :: zs

  where go : a -> List a -> (List1 a, List (List1 a))
        go v [] = (singleton v,[])
        go v (x :: xs) = let (ys,zs) = go x xs
                          in if eq v x
                                then (cons v ys, zs)
                                else (singleton v, ys :: zs)

||| TODO: use the version in `Data.List1` in base after the next release.
export
group : Eq a => List a -> List (List1 a)
group = Libraries.Data.List.Extra.groupBy (==)

||| TODO: use the version in `Data.List1` in base after the next release.
export
groupWith : Eq b => (a -> b) -> List a -> List (List1 a)
groupWith f = Libraries.Data.List.Extra.groupBy (\x,y => f x == f y)

||| TODO: use the version in `Data.List1` in base after the next release.
export
groupAllWith : Ord b => (a -> b) -> List a -> List (List1 a)
groupAllWith f = Libraries.Data.List.Extra.groupWith f . sortBy (comparing f)


import Data.Vect

vtake : (n : Nat) -> Vect (n+m) a -> Vect n a
vtake Z xs = []
vtake (S k) (x :: xs) = x :: vtake k xs

numbers : Vect 3 Int
numbers = [1,2,3]

main : IO ()
main = printLn ( vtake 3 numbers )


hours : List Nat
hours = [1..12]

nats : Stream Nat
nats = [0,1..]


module Main

import Data.So

total
lem1 : So x -> So (not x) -> Void
lem1 Oh Oh impossible

foo : Nat -> Int
foo z = 94
  where
    lem2 : So x -> So (not x) -> Void
    lem2 Oh Oh impossible


-- --------------------------------------------------------------- [ PList.idr ]
-- Module    : PList.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| A `list` construct to create lists with with values that satisfy
||| some predicate..
|||
||| The list quantifier `All` in idris is an external proof for a list
||| with type `List a`.  `PList` is a proof-carrying data structure
||| that only allows for lists to be constructed if they satisfy the
||| predicate.
module Data.PList

import public Data.List
import public Data.DList

%access export
%default total

public export
data PList : (aTy    : Type)
          -> (elemTy : aTy -> Type)
          -> (predTy : aTy -> Type)
          -> (as     : List aTy)
          -> (prf    : DList aTy predTy as)
          -> Type
  where
    ||| Create an empty List
    Nil  : PList aTy elemTy predTy Nil Nil

    ||| Cons
    |||
    ||| @elem The element to add and proof that the element's type satisfies a certain predicate.
    ||| @rest The list for `elem` to be added to.
    (::) : (elem : elemTy x)
        -> {prf : predTy x}
        -> (rest : PList aTy elemTy predTy xs prfs)
        -> PList aTy elemTy predTy (x :: xs) (prf :: prfs)

(++) : PList aTy eTy pTy as pAs
    -> PList aTy eTy pTy bs pBs
    -> PList aTy eTy pTy (as ++ bs) (pAs ++ pBs)
(++) [] ys = ys
(++) (elem :: rest) ys = elem :: rest ++ ys

empty : PList aTy eTy pTy Nil Nil
empty = Nil

add  : (elem : elemTy x)
    -> {auto prf : predTy x}
    -> (rest : PList aTy elemTy predTy xs prfs)
    -> PList aTy elemTy predTy (x :: xs) (prf :: prfs)
add x {prf} rest = x :: rest

-- -------------------------------------------------------------- [ Form Tests ]
isNil : PList aTy eTy p as prfs -> Bool
isNil [] = True
isNil (elem :: rest) = False

isCons : PList aTy eTy p as prfs -> Bool
isCons l = isNil l == False

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

length : PList aTy eTy p as prfs -> Nat
length Nil     = Z
length (x::xs) = (S Z) + length xs

Sized (PList aTy eTy pTy as prfs) where
  size = length

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

-- ---------------------------------------------- [ List-Based Transformations ]

toDList : PList aTy eTy p as prfs -> DList aTy eTy as
toDList Nil     = Nil
toDList (elem::xs) = elem :: toDList xs

toList : PList aTy eTy pTy as prfs -> List (a : aTy ** prf : pTy a ** eTy a)
toList [] = []
toList ((::) elem {x} {prf} rest) = (x ** prf ** elem) :: toList rest

fromDList : (xs   : DList aTy eTy as)
         -> (prfs : DList aTy pTy as)
         -> PList aTy eTy pTy as prfs
fromDList [] [] = []
fromDList (elem :: rest) (prf :: prfs) = elem :: fromDList rest prfs

fromList : (prf : predTy a)
        -> (xs  : List $ elemTy a)
        -> PList aTy elemTy predTy (replicate (length xs) a)
                                   (replicate (length xs) prf)
fromList prf [] = []
fromList prf (x :: xs) = x :: fromList prf xs

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

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

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

nonEmpty : (xs : PList aTy eTy pTy as prfs) -> Dec (NonEmpty xs)
nonEmpty [] = No absurd
nonEmpty (elem :: rest) = Yes IsNonEmpty

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

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

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

index : (idx : Nat)
     -> (xs : PList aTy eTy pTy as prfs)
     -> {auto ok   : InBounds idx xs}
     -> {auto ok'  : InBounds idx as}
     -> {auto ok'' : InBounds idx prfs}
     -> eTy (index idx as)
index Z (y :: rest) {ok = InFirst} = y
index (S k) (y :: rest) {ok = (InLater later)} {ok' = (InLater later')} {ok'' = (InLater later'')} = PList.index k rest

head : (xs : PList aTy eTy pTy (a::as) prfs)
    -> {auto ok   : NonEmpty xs}
    -> {auto ok'  : NonEmpty (a::as)}
    -> {auto ok'' : NonEmpty prfs}
    -> eTy a
head (elem :: rest) = elem

tail : (xs : PList aTy eTy pTy (a::as) (p::prfs))
    -> {auto ok   : NonEmpty xs}
    -> {auto ok'  : NonEmpty (a::as)}
    -> {auto ok'' : NonEmpty (p::prfs)}
    -> PList aTy eTy pTy as prfs
tail (elem :: rest) = rest

last : (xs : PList aTy eTy pTy as prfs)
    -> {auto ok   : NonEmpty xs}
    -> {auto ok'  : NonEmpty as}
    -> {auto ok'' : NonEmpty prfs}
    -> eTy (last as)
last [] {ok = IsNonEmpty} impossible
last (elem :: []) {ok = ok} {ok' = ok'} {ok'' = ok''} = elem
last (elem :: ((::) {prf} y rest)) {ok = ok} {ok' = ok'} {ok'' = ok''} = last $ (::) y rest {prf=prf}

init : (xs : PList aTy eTy pTy as prfs)
    -> {auto ok   : NonEmpty xs}
    -> {auto ok'  : NonEmpty as}
    -> {auto ok'' : NonEmpty prfs}
    -> PList aTy eTy pTy (init as) (init {ok=ok''} prfs)
init (y :: []) {ok = IsNonEmpty} {ok' = IsNonEmpty} {ok'' = IsNonEmpty} = []
init (y :: ((::) {prf} elem rest)) {ok = IsNonEmpty} {ok' = IsNonEmpty} {ok'' = IsNonEmpty} = y :: init (elem :: rest)

public export
data Elem : (aTy    : Type)
         -> (elemTy : aTy -> Type)
         -> (predTy : aTy -> Type)
         -> (a : aTy)
         -> (x : elemTy a)
         -> (prf : predTy a)
         -> (xs   : PList aTy elemTy predTy as prfs)
         -> (prfA : Elem a as)
         -> (prfP : DElem aTy predTy prf prfs prfA)
         -> Type
  where
    Hier  : PList.Elem aTy eTy pTy a x p (x::xs) Here Hier
    Er    : (rest : PList.Elem aTy eTy pTy a x p xs prfA prfP)
         -> PList.Elem aTy eTy pTy a x p (x'::xs) (There prfA) (DList.Er prfP)

Uninhabited (PList.Elem aTy eTy pTy a x prf Nil prfA prfP) where
  uninhabited Hier impossible
  uninhabited (Er _) impossible

dropElem : (as   : PList iTy elemTy predTy is prfs)
        -> (idxP : Elem iTy elemTy predTy i e prf as prfA prfP)
        -> PList iTy elemTy predTy (dropElem is prfA) (dropElem prfs prfP)
dropElem (e :: x) Hier = x
dropElem (x :: z) (Er rest) = x :: dropElem z rest

delete' : (x  : elemTy i)
       -> (xs : PList iTy elemTy predTy is prfs)
       -> (idxVal : Elem i is)
       -> (idxPrf : DElem iTy predTy prf prfs idxVal)
       -> PList iTy elemTy predTy (dropElem is idxVal) (dropElem prfs idxPrf)
delete' x (elem :: rest) Here Hier = rest
delete' x (elem :: rest) (There later) (Er komst) = elem :: delete' x rest later komst

delete : (x  : elemTy i)
      -> (xs : PList iTy elemTy predTy is prfs)
      -> {auto idxVal : Elem i is}
      -> {auto idxPrf : DElem iTy predTy prf prfs idxVal}
      -> PList iTy elemTy predTy (dropElem is idxVal) (dropElem prfs idxPrf)
delete x xs {idxVal} {idxPrf} = delete' x xs idxVal idxPrf

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

-- TODO append
-- TODO replicate

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

take : (n : Nat)
    -> (xs : PList aTy elemTy predTy as prfs)
    -> PList aTy elemTy predTy (take n as) (take n prfs)
take Z     xs             = Nil
take (S k) []             = Nil
take (S k) (elem :: rest) = elem :: take k rest

-- TODO takeWhile

-- TODO drop
drop : (n : Nat)
    -> (xs : PList aTy elemTy predTy as prfs)
    -> PList aTy elemTy predTy (drop n as) (drop n prfs)
drop Z     rest           = rest
drop (S k) []             = Nil
drop (S k) (elem :: rest) = drop k rest

-- TODO dropWhile

-- ---------------------------------------------------------------- [ Equality ]
-- TODO eqPList

-- ------------------------------------------------------------------- [ Order ]
-- TODO cmpPList

-- ----------------------------------------------------------------- [ Folding ]
-- TODO foldr and foldl
foldr : ({a : aTy} -> elemTy a -> p -> p)
     -> p
     -> PList aTy elemTy predTy as prfs
     -> p
foldr f init Nil     = init
foldr f init (x::xs) = f x (PList.foldr f init xs)

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

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

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

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

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

-- -------------------------------------------------------- [ Membership Tests ]
-- TODO make deceq tests
-- TODO any
-- TODO all
-- TODO elemBy
-- TODO elem
-- TODO hasAnyBy
-- TODO hasAny

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

-- TODO find

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

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

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

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

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

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

-- -------------------------------------------------------------------- [ Show ]

private
doPListShow : ({a : aTy} -> elemTy a -> String)
           -> PList aTy elemTy predTy as prfs
           -> List String
doPListShow _  Nil     = Nil
doPListShow f  (x::xs) = (f x) :: doPListShow f xs

showPList : (showFunc : {a : aTy} -> elemTy a -> String)
         -> (l : PList aTy elemTy predTy as prfs)
         -> String
showPList f xs = "[" ++ unwords (intersperse "," (doPListShow f xs)) ++ "]"

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


module Data.Time.Clock.AbsoluteTime

import Data.Fixed
import Data.Time.Calendar.Days
import Data.Time.Clock.DiffTime

import Generics.Derive

%default total
%language ElabReflection

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

export data AbsoluteTime = MkAbsoluteTime DiffTime
%runElab derive "AbsoluteTime" [Generic, Eq, Ord, DecEq]

||| The epoch of TAI, which is 1858-11-17 00:00:00 TAI.
export taiEpoch : AbsoluteTime
taiEpoch = MkAbsoluteTime 0

export taiNominalDayStart : Day -> AbsoluteTime
taiNominalDayStart day =
  MkAbsoluteTime $ SecondsToDiffTime $ cast $ day.modifiedJulianDay * 86400

||| addAbsoluteTime a b = a + b
export addAbsoluteTime : DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime t (MkAbsoluteTime a) = MkAbsoluteTime (a + t)

||| diffAbsoluteTime a b = a - b
export diffAbsoluteTime : AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime (MkAbsoluteTime a) (MkAbsoluteTime b) = a - b

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


module Main

import Oyster.Core

%default total

{-
  EBNF grammar:

  expr ::= term ( + expr | - expr | epsilon )
  term ::= factor ( * expr | / expr | epsilon )
  factor ::= ( expr ) | integer
  integer ::= ... -2 | -1 | 0 | 1 | 2 | ...
-}

mutual
  partial
  expr : Parser Int
  expr = do t <- term
            do symbol "+"
               e <- expr
               pure (t + e)
             <|> do symbol "-"
                    e <- expr
                    pure (t - e)
             <|> pure t

  partial
  term : Parser Int
  term = do f <- factor
            do symbol "*"
               t <- term
               pure (f * t)
             <|> do symbol "/"
                    t <- term
                    pure (f `div` t)
             <|> pure f

  partial
  factor : Parser Int
  factor = do symbol "("
              e <- expr
              symbol ")"
              pure e
            <|> integer

eval : String -> Maybe Int
eval inp = case parse expr inp of
                [(n, "")] => Just n
                _ => Nothing

main : IO ()
main = do expr <- getLine
          pure ()


import System
import Data.List.Views

data Palindrome : List a -> Type where
     PNil : Palindrome []
     POne : Palindrome [x]
     PRec : Palindrome xs -> Palindrome (x :: xs ++ [x])

total
palindrome : DecEq a => (xs : List a) -> Maybe (Palindrome xs)
palindrome xs with (vList xs)
  palindrome [] | VNil = Just PNil
  palindrome [x] | VOne = Just POne
  palindrome (x :: (ys ++ [y])) | (VCons z) with (decEq x y)
    palindrome (y :: (ys ++ [y])) | (VCons urec) | (Yes Refl)
       = case palindrome ys | urec of
              Nothing => Nothing
              Just x => Just (PRec x)
    palindrome (x :: (ys ++ [y])) | (VCons z) | (No contra)
       = Nothing

palinBool : DecEq a => List a -> Bool
palinBool xs = case palindrome xs of
                    Nothing => False
                    Just _ => True

main : IO ()
main = do getArgs >>= printLn
          [_, num] <- getArgs
          let list = replicate (cast num) 'a'
          printLn (palinBool list)


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


total twoPlusTwoNotFive: 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible


module Fractions

%default total

record Fraction : Type where
  F : (top : Nat) -> (bottom : Nat) -> Fraction

corecord Tree : Type -> Type where
  value : Tree a -> a
  left : Tree a -> Tree a
  right : Tree a -> Tree a
  constructor MkTree

fracSum : Fraction -> Nat
fracSum (F top bottom) = top + bottom

leftFrac : Fraction -> Fraction
leftFrac f = F (top f) (fracSum f)

rightFrac : Fraction -> Fraction
rightFrac f = F (fracSum f) (bottom f)

total causal flattenTree : Tree a -> Stream a
flattenTree t = ft []
  where
    total causal ft : List (Tree a) -> Stream a
    ft [] = (value t) :: (ft [left t, right t])
    ft (tree :: xs) = (value tree) :: (ft (xs ++ [left tree, right tree]))

total causal rationalTree : Tree Fraction
rationalTree = rt $ F (S Z) (S Z)
  where
    total causal rt : Fraction -> Tree Fraction
    rt f = MkTree f (rt $ leftFrac f) (rt $ rightFrac f)

--total causal rationals : Stream Fraction
--rationals = flattenTree $ rationalTree


import Data.List
import Data.Nat
import Data.SortedMap
import Control.Monad.State
import Control.Monad.State.State
import Control.Monad.State.Interface

record Player where
  constructor MkPlayer
  score : Nat
  pos : Nat

Eq Player where
  p1 == p2 = p1.score == p2.score && p1.pos == p2.pos

Ord Player where
  compare p1 p2 = compare (p1.score, p1.pos) (p2.score, p2.pos)

data Turn = P1 | P2

Eq Turn where
  P1 == P1 = True
  P2 == P2 = True
  _  == _  = False

Ord Turn where
  compare P1 P1 = EQ
  compare P1 P2 = LT
  compare P2 P1 = GT
  compare P2 P2 = EQ

next : Turn -> Turn
next P1 = P2
next P2 = P1

record Game where
  constructor MkGame
  player1, player2 : Player
  turn : Turn
  rolls : Nat

fromStart : Nat -> Nat -> Game
fromStart p1 p2 = MkGame (MkPlayer 0 p1) (MkPlayer 0 p2) P1 0

score : Game -> Nat
score (MkGame p1 p2 _ rolls) = (*) rolls $ max p1.score  p2.score

rollDet : State Game Nat
rollDet = do rolls <- gets (.rolls)
             modify { rolls $= S }
             pure $ 1 + (modNatNZ rolls 100 SIsNonZero)

movePlayer : Nat -> Player -> Player
movePlayer m (MkPlayer score pos) = let npos = (modNatNZ (pos + m) 10 SIsNonZero) in
                                         MkPlayer (score + npos + 1) npos

playDet : State Game ()
playDet = do rolls <- sequence $ replicate 3 rollDet
             let r = sum rolls
             turn <- gets (.turn)
             case turn of
                  P1 => modify { player1 $= movePlayer r }
                  P2 => modify { player2 $= movePlayer r }
             s1 <- gets (.player1.score)
             s2 <- gets (.player2.score)
             if s1 >= 1000 || s2 >= 1000
                then pure ()
                else modify { turn $= next } *> playDet

part1 : Game -> IO String
part1 a = do let g = execState a playDet
             pure $ show $ score g

Memoize : Type
Memoize = SortedMap (Player, Player, Turn) (Nat, Nat)

addPair : Num a => (a, a) -> (a, a) -> (a, a)
addPair (x, y) (z, w) = (x + z, y + w)

wins : Player -> Bool
wins (MkPlayer score pos) = score >= 21

playDirac : Nat -> Memoize -> Game -> ((Nat, Nat), Memoize)
playDirac _ m (MkGame p1 p2 turn 0) = case lookup (p1, p2, turn) m of
                                           (Just w) => (w, m)
                                           Nothing => let (w, m) = foldl (\(w, m) => \d => mapFst (addPair w) $ playDirac d m (MkGame p1 p2 turn 1)) ((0, 0), m) $ [1,2,3] in
                                                          (w, insert (p1, p2, turn) w m)
playDirac s m (MkGame p1 p2 P1 3) = let p1' = movePlayer s p1 in
                                        if wins p1'
                                           then ((1, 0), m)
                                           else playDirac 0 m (MkGame p1' p2 P2 0)
playDirac s m (MkGame p1 p2 P2 3) = let p2' = movePlayer s p2 in
                                        if wins p2'
                                           then ((0, 1), m)
                                           else playDirac 0 m (MkGame p1 p2' P1 0)
playDirac s m (MkGame p1 p2 turn r) = foldl (\(w, m) => \d => mapFst (addPair w) $ playDirac (s + d) m (MkGame p1 p2 turn (1 + r))) ((0, 0), m) $ [1,2,3]

part2 : Game -> IO String
part2 a = do let (wins, _) = playDirac 0 empty a
             pure $ show $ (uncurry max) wins

main : IO ()
main = do let g = fromStart 2 9
          part1 g >>= putStrLn
          part2 g >>= putStrLn


-- Idris implementation of a type-correct, stack-safe
-- compiler including exception handling.
--
-- Morten S. Knudsen, Jeppe Vinberg, Francisco M. Lasaca

import Data.List

%default total

data TyExp = NatTy | BoolTy

VariableId : Type
VariableId = String

mutual
  StackType : Type
  StackType = List Ty

  HeapType : Type
  HeapType = List (VariableId, TyExp)

  data Ty = Han StackType StackType HeapType HeapType | Val TyExp

data V : TyExp -> Type where
  VNat : Nat -> V NatTy
  VBool : Bool -> V BoolTy

data Exp : Bool -> TyExp -> List (VariableId, TyExp) -> Type where
  VarExp : (vId : VariableId) -> {auto p : Elem (vId, ty) env} -> Exp False ty env
  SingleExp : (v : V t) -> Exp False t env
  PlusExp : (x : Exp a NatTy env) -> (y : Exp b NatTy env) -> Exp (a || b) NatTy env
  IfExp : (cond : Exp a BoolTy env) -> (x : Exp b t env) -> (y : Exp c t env) -> Exp (a || b || c) t env
  ThrowExp : Exp True t env
  CatchExp : (x : Exp a t env) -> (h : Exp b t env) -> Exp (a && b) t env

data Program : List (VariableId, TyExp) -> List (VariableId, TyExp) -> Type where
  EmptyProgram : Program env env
  Declaration : (vId : VariableId) ->
                (exp : Exp b t env) ->
                {auto expExecutable : b = False} ->
                (continuing : Program ((vId, t) :: env) env') ->
                (Program env env')
  Assignment : (vId : VariableId) ->
               (exp : Exp b t env) ->
               {auto expExecutable : b = False} ->
               (continuing : Program ((vId, t) :: env) env') ->
               {auto prf' : Elem (vId, t) env} ->
               (Program env env')

data ValuesEnv : List (VariableId, TyExp) -> Type where
  EmptyValuesEnv : ValuesEnv []
  MoreValuesEnv : (vId: VariableId) -> V ty -> ValuesEnv envTy
                  -> ValuesEnv ((vId, ty) :: envTy)

mutual
  evalVarExp : (x : ValuesEnv tEnv) -> (p : Elem (vId, ty) tEnv)  -> V ty
  evalVarExp (MoreValuesEnv _ val _) Here = val
  evalVarExp (MoreValuesEnv _ _ valueEnv) (There later) = evalVarExp valueEnv later

  evalPlusExp : (x : Exp a NatTy tEnv) -> (y : Exp b NatTy tEnv) -> (valuesEnv : ValuesEnv tEnv) -> (prf : (a || (Delay b)) = False) -> V NatTy
  evalPlusExp x y valuesEnv prf {a = False} {b = False} =
    case eval x valuesEnv of
          (VNat x') => case eval y valuesEnv of
                             (VNat y') => VNat (x' + y')
  evalPlusExp _ _ _ Refl {a = False} {b = True} impossible
  evalPlusExp _ _ _ Refl {a = True} {b = _} impossible

  evalIfExp : (cond : Exp a BoolTy tEnv) -> (x : Exp b t tEnv) -> (y : Exp c t tEnv) -> (valuesEnv : ValuesEnv tEnv) -> (prf : (a || (Delay (b || (Delay c)))) = False) -> V t
  evalIfExp cond x y valuesEnv prf {a = False} {b = False} {c = False} =
    case eval cond valuesEnv of
          VBool True => eval x valuesEnv
          VBool False => eval y valuesEnv
  evalIfExp _ _ _ _ Refl {a = False} {b = False} {c = True} impossible
  evalIfExp _ _ _ _ Refl {a = False} {b = False} {c = True} impossible
  evalIfExp _ _ _ _ Refl {a = True} {b = _} {c = _} impossible

  evalCatchExp : (x : Exp a t tEnv) -> (h : Exp b t tEnv) -> (valuesEnv : ValuesEnv tEnv) ->(prf : (a && (Delay b)) = False) -> V t
  evalCatchExp x h valuesEnv prf {a = False} = eval x valuesEnv
  evalCatchExp x h valuesEnv prf {a = True} {b = False} = eval h valuesEnv
  evalCatchExp _ _ _ Refl {a = True} {b = True} impossible

  eval : (e : Exp b t tEnv) -> (valuesEnv : ValuesEnv tEnv) -> {auto prf : b = False} -> V t
  eval (VarExp vId {p}) valuesEnv = evalVarExp valuesEnv p
  eval (SingleExp v) valuesEnv = v
  eval (PlusExp x y) valuesEnv {prf} = evalPlusExp x y valuesEnv prf
  eval (IfExp cond x y) valuesEnv {prf} = evalIfExp cond x y valuesEnv prf
  eval ThrowExp _ {prf = Refl} impossible
  eval (CatchExp x h) valuesEnv {prf}= evalCatchExp x h valuesEnv prf

evPro : (p : Program env env') -> (valueEnv : ValuesEnv env) -> ValuesEnv env'
evPro EmptyProgram valueEnv = valueEnv
evPro (Declaration vId exp continuing) valueEnv =
  let evaluated = eval exp valueEnv in
  evPro continuing (MoreValuesEnv vId evaluated valueEnv)
evPro (Assignment vId exp continuing) valueEnv =
  let evaluated = eval exp valueEnv in
  evPro continuing (MoreValuesEnv vId evaluated valueEnv)
evalProgram : (p : Program [] env') -> ValuesEnv env'
evalProgram p = evPro p EmptyValuesEnv

mutual
  El : Ty -> Type
  El (Han t t' h h') = Code t t' h h'
  El (Val NatTy) = Nat
  El (Val BoolTy) = Bool

  data Code : (s : StackType) -> (s' : StackType) -> (h: HeapType) -> (h': HeapType) -> Type where
    STORE : (vId: VariableId) -> (c: Code s s' ((vId, ty)::h) h') -> Code ((Val ty)::s) s' h h'
    LOAD : (vId: VariableId) -> {auto prf: Elem (vId, ty) h} -> (c: Code ((Val ty)::s) s' h h') -> Code s s' h h'
    PUSH : V tyExp -> Code (Val tyExp :: s) s' h h' -> Code s s' h h'
    ADD : Code (Val NatTy :: s) s' h h' -> Code (Val NatTy :: Val NatTy :: s) s' h h'
    IF : (c1 : Code s s' h h') -> (c2 : Code s s' h h') -> Code (Val BoolTy :: s) s' h h'
    THROW : Code (s'' ++ (Han s s' h h') :: s) s' h h'
    MARK : (han : Code s s' h h') -> (c : Code ((Han s s' h h') :: s) s' h h') -> Code s s' h h'
    UNMARK : Code (t :: s) s' h h' -> Code (t :: (Han s s' h h') :: s) s' h h'
    HALT : Code s s h h

mutual
  compCatch : Exp b ty tenv -> Code (Val ty :: (s'' ++ (Han s s' tenv h') :: s)) s' tenv h' -> Code (s'' ++ (Han s s' tenv h') :: s) s' tenv h'
  compCatch (VarExp vId) c = LOAD vId c
  compCatch (SingleExp v) c = PUSH v c
  compCatch (PlusExp x y) c = compCatch x (compCatch {s'' = Val NatTy :: _} y (ADD c))
  compCatch {s} {s''} (IfExp cond x y) c = compCatch cond (IF (compCatch x c) (compCatch y c))
  compCatch ThrowExp c = THROW
  compCatch (CatchExp x h) c = MARK (compCatch h c) (compCatch {s'' = []} x (UNMARK c))

  compPlusExp : (p : (a || b) = False) -> (x : Exp a NatTy tenv) ->  (y : Exp b NatTy tenv) -> (c : Code ((Val NatTy) :: s) s' tenv h') -> Code s s' tenv h'
  compPlusExp {a = False} {b = False} Refl x y c = comp Refl x (comp Refl y (ADD c))
  compPlusExp {a = False} {b = True} Refl _ _ _ impossible
  compPlusExp {a = True} {b = _} Refl _ _ _ impossible

  compCatchExp : (p : (a && b) = False) -> (x : Exp a ty tenv) -> (handler : Exp b ty tenv) -> (c : Code ((Val ty) :: s) s' tenv h') -> Code s s' tenv h'
  compCatchExp {a = False} Refl x handler c = comp Refl x c
  compCatchExp {a = True} {b = False} p x handler c = MARK (comp Refl handler c) (compCatch {s'' = []} x (UNMARK c))
  compCatchExp {a = True} {b = True} Refl _ _ _ impossible

  compIfExp : (p : (a || b || c) = False) -> (cond : Exp a BoolTy tenv) ->(x : Exp b ty tenv) -> (y : Exp c ty tenv) -> (co : Code ((Val ty) :: s) s' tenv h') -> Code s s' tenv h'
  compIfExp {a = False} {b = False} {c = False} Refl cond x y co = comp Refl cond (IF (comp Refl x co) (comp Refl y co))
  compIfExp {a = False} {b = False} {c = True} Refl _ _ _ _ impossible
  compIfExp {a = False} {b = False} {c = True} Refl _ _ _ _ impossible
  compIfExp {a = True} Refl _ _ _ _ impossible

  comp : (b = False) -> Exp b ty tenv -> Code (Val ty :: s) s' tenv h' -> Code s s' tenv h'
  comp _ (VarExp {p} vId) {tenv} c = LOAD vId c
  comp p (SingleExp v) c = PUSH v c
  comp p (PlusExp x y) c = compPlusExp p x y c
  comp p (IfExp cond x y) co = compIfExp p cond x y co
  comp p (CatchExp x h) c = compCatchExp p x h c
  comp Refl ThrowExp _ impossible

  partial
  compile : (prog: Program tenv tenv') -> Code [] [] tenv tenv'
  compile (Declaration vId exp {expExecutable} continuing) =
    comp expExecutable exp (STORE vId (compile continuing))
  compile (Assignment vId exp {expExecutable} continuing) =
    comp expExecutable exp (STORE vId (compile continuing))
  compile EmptyProgram = HALT

data Stack : (s : StackType) -> Type where
  Nil : Stack []
  (::) : El t -> Stack s -> Stack (t :: s)

data Heap : (h : HeapType) -> Type where
  HeapNil : Heap []
  HeapCons : (vId: VariableId) -> V t -> Heap h -> Heap ((vId, t) :: h)

mutual

  lookup: Heap h -> (p: Elem (vId, ty) h) -> V ty
  lookup (HeapCons vId val tl) Here = val
  lookup (HeapCons _ _ tl) (There later) = lookup tl later

  partial
  exec : Code s s' h h' -> Stack s -> Heap h -> (Stack s', Heap h')
  exec (LOAD {prf} vId c) s h = case lookup h prf of
    (VNat v) => exec c (v :: s) h
    (VBool v) => exec c (v :: s) h
  exec (STORE vId c) {s=(Val NatTy)::_} (x :: tl) h = exec c tl (HeapCons vId (VNat x) h)
  exec (STORE vId c) {s=(Val BoolTy)::_} (x :: tl) h = exec c tl (HeapCons vId (VBool x) h)
  exec (PUSH (VNat x) c) s h = exec c (x :: s) h
  exec (PUSH (VBool x) c) s h = exec c (x :: s) h
  exec (ADD c) (m :: n :: s) h = exec c ((n + m) :: s) h
  exec (IF c1 c2) (True :: s) h = exec c1 s h
  exec (IF c1 c2) (False :: s) h = exec c2 s h
  exec THROW s h = fail s h
  exec (MARK handler c) s h = exec c (handler :: s) h
  exec (UNMARK c) (x :: handler :: s) h = exec c (x :: s) h
  exec HALT s h = (s, h)

  partial
  fail : Stack (s'' ++ Han s s' h h' :: s) -> Heap h -> (Stack s', Heap h')
  fail {s'' = []} (handler' :: s) h = exec handler' s h
  fail {s'' = (_ :: _)} (_ :: s) h = fail s h

-- Example of an entire program
-- `entireProgram`

-- x <- 3           -- []
-- x <- x + 1       -- [x <- 3]
-- y <- x + 2       -- [x <- 4]
-- emptyProgram     -- [y <- 6, x <- 4]

myEmpty : Program [("y", NatTy), ("x", NatTy), ("x", NatTy)] [("y", NatTy), ("x", NatTy), ("x", NatTy)]
myEmpty = EmptyProgram

yEqualsXPlusTwo : Program [("x", NatTy), ("x", NatTy)] [("y", NatTy), ("x", NatTy), ("x", NatTy)]
yEqualsXPlusTwo = Declaration "y" (PlusExp (VarExp "x") (SingleExp (VNat 2))) myEmpty

xEqualsXPlusOne : Program [("x", NatTy)] [("y", NatTy), ("x", NatTy), ("x", NatTy)]
xEqualsXPlusOne = Assignment "x" (PlusExp (VarExp "x") (SingleExp (VNat 1))) yEqualsXPlusTwo

entireProgram : Program [] [("y", NatTy), ("x", NatTy), ("x", NatTy)]
entireProgram = Declaration "x" (SingleExp (VNat 3)) xEqualsXPlusOne

evaluatedProgram : ValuesEnv [("y", NatTy), ("x", NatTy), ("x", NatTy)]
evaluatedProgram = evalProgram entireProgram

compiledProgram :  Code [] [] [] [("y", NatTy), ("x", NatTy), ("x", NatTy)]
compiledProgram = compile entireProgram

partial
executedProgram : (Stack [], Heap [("y", NatTy), ("x", NatTy), ("x", NatTy)])
executedProgram = exec (compiledProgram) [] HeapNil


module Props.Util

import public Data.List

%access public export

private
mkNo : {xs' : List a} ->
       ((x' = y') -> Void) ->
       (Elem x' xs' -> Void) ->
       Elem x' (y' :: xs') -> Void
mkNo f g Here = f Refl
mkNo f g (There x) = g x

-- Use this until https://github.com/idris-lang/Idris-dev/issues/4161
fastIsElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs)
fastIsElem x [] = No absurd
fastIsElem x (y :: xs) with (decEq x y)
  fastIsElem x (x :: xs) | (Yes Refl) = Yes Here
  fastIsElem x (y :: xs) | (No contra) with (fastIsElem x xs)
    fastIsElem x (y :: xs) | (No contra) | (Yes prf) = Yes (There prf)
    fastIsElem x (y :: xs) | (No contra) | (No f) = No (mkNo contra f)

using (a: Type, P : a -> Type, Q: a -> Type)

  data EitherK : { a : Type } -> ( P : a -> Type ) -> ( Q : a -> Type) -> a -> Type where
    LeftK : ( prf : P c ) -> EitherK P Q c
    RightK : ( prf : Q c ) -> EitherK P Q c

-- Add these to not depend on contrib
data Given : Dec x -> Type where
  Always : Given (Yes prf)

data Denied : Dec x -> Type where
  Never : Denied (No contra)


module Solutions.Predicates

import Data.Vect
import Decidable.Equality

%default total

--------------------------------------------------------------------------------
--          Preconditions
--------------------------------------------------------------------------------

data NonEmpty : (as : List a) -> Type where
  IsNonEmpty : NonEmpty (h :: t)

-- 1

tail : (as : List a) -> (0 _ : NonEmpty as) => List a
tail (_ :: xs) = xs
tail [] impossible

-- 2

concat1 : Semigroup a => (as : List a) -> (0 _ : NonEmpty as) => a
concat1 (h :: t) = foldl (<+>) h t

foldMap1 : Semigroup m => (a -> m) -> (as : List a) -> (0 _ : NonEmpty as) => m
foldMap1 f (h :: t) = foldl (\x,y => x <+> f y) (f h) t

-- 3

maximum : Ord a => (as : List a) -> (0 _ : NonEmpty as) => a
maximum (x :: xs) = foldl max x xs

minimum : Ord a => (as : List a) -> (0 _ : NonEmpty as) => a
minimum (x :: xs) = foldl min x xs

-- 4

data Positive : Nat -> Type where
  IsPositive : Positive (S n)

saveDiv : (m,n : Nat) -> (0 _ : Positive n) => Nat
saveDiv m (S k) = go 0 m k
  where go : (res, rem, sub : Nat) -> Nat
        go res 0       _     = res
        go res (S rem) 0     = go (res + 1) rem k
        go res (S rem) (S x) = go res rem x

-- 5

data IJust : Maybe a -> Type where
  ItIsJust : IJust (Just v)

Uninhabited (IJust Nothing) where
  uninhabited ItIsJust impossible

isJust : (m : Maybe a) -> Dec (IJust m)
isJust Nothing  = No uninhabited
isJust (Just x) = Yes ItIsJust

fromJust : (m : Maybe a) -> (0 _ : IJust m) => a
fromJust (Just x) = x
fromJust Nothing  impossible

-- 6

data IsLeft : Either e a -> Type where
  ItIsLeft : IsLeft (Left v)

Uninhabited (IsLeft $ Right w) where
  uninhabited ItIsLeft impossible

isLeft : (v : Either e a) -> Dec (IsLeft v)
isLeft (Right _) = No uninhabited
isLeft (Left x)  = Yes ItIsLeft

data IsRight : Either e a -> Type where
  ItIsRight : IsRight (Right v)

Uninhabited (IsRight $ Left w) where
  uninhabited ItIsRight impossible

isRight : (v : Either e a) -> Dec (IsRight v)
isRight (Left _)  = No uninhabited
isRight (Right x) = Yes ItIsRight

fromLeft : (v : Either e a) -> (0 _ : IsLeft v) => e
fromLeft (Left x) = x
fromLeft (Right x) impossible

fromRight : (v : Either e a) -> (0 _ : IsRight v) => a
fromRight (Right x) = x
fromRight (Left x) impossible

--------------------------------------------------------------------------------
--          Contracts between Values
--------------------------------------------------------------------------------

data ColType = I64 | Str | Boolean | Float

IdrisType : ColType -> Type
IdrisType I64     = Int64
IdrisType Str     = String
IdrisType Boolean = Bool
IdrisType Float   = Double

record Column where
  constructor MkColumn
  name : String
  type : ColType

infixr 8 :>

(:>) : String -> ColType -> Column
(:>) = MkColumn

Schema : Type
Schema = List Column

data Row : Schema -> Type where
  Nil  : Row []
  (::) :  {0 name : String}
       -> {0 type : ColType}
       -> (v : IdrisType type)
       -> Row ss
       -> Row (name :> type :: ss)

data InSchema :  (name    : String)
              -> (schema  : Schema)
              -> (colType : ColType)
              -> Type where
  [search name schema]
  IsHere  : InSchema n (n :> t :: ss) t
  IsThere : InSchema n ss t -> InSchema n (fld :: ss) t

getAt :  {0 ss   : Schema}
      -> (name : String)
      -> Row ss
      -> (prf : InSchema name ss c)
      => IdrisType c
getAt name (v :: vs) {prf = IsHere}    = v
getAt name (_ :: vs) {prf = IsThere p} = getAt name vs

-- 1

Uninhabited (InSchema n [] c) where
  uninhabited IsHere impossible
  uninhabited (IsThere _) impossible

inSchema : (ss : Schema) -> (n : String) -> Dec (c ** InSchema n ss c)
inSchema []                    _ = No $ \(_ ** prf) => uninhabited prf
inSchema (MkColumn cn t :: xs) n = case decEq cn n of
  Yes Refl   => Yes (t ** IsHere)
  No  contra => case inSchema xs n of
    Yes (t ** prf) => Yes (t ** IsThere prf)
    No  contra2    => No $ \case (_ ** IsHere)    => contra Refl
                                 (t ** IsThere p) => contra2 (t ** p)

-- 2

updateAt : (name : String)
         -> Row ss
         -> (prf : InSchema name ss c)
         => (f : IdrisType c -> IdrisType c)
         -> Row ss
updateAt name (v :: vs) {prf = IsHere}    f = f v :: vs
updateAt name (v :: vs) {prf = IsThere p} f = v :: updateAt name vs f

-- 3

public export
data Elems : (xs,ys : List a) -> Type where
  ENil   : Elems [] ys
  EHere  : Elems xs ys -> Elems (x :: xs) (x :: ys)
  EThere : Elems xs ys -> Elems xs (y :: ys)

extract :  (0 s1 : Schema)
        -> (row : Row s2)
        -> (prf : Elems s1 s2)
        => Row s1
extract []       _         {prf = ENil}     = []
extract (_ :: t) (v :: vs) {prf = EHere x}  = v :: extract t vs
extract s1       (v :: vs) {prf = EThere x} = extract s1 vs

-- 4

namespace AllInSchema
  public export
  data AllInSchema :  (names : List String)
                   -> (schema : Schema)
                   -> (result : Schema)
                   -> Type where
    [search names schema]
    Nil  :  AllInSchema [] s []
    (::) :  InSchema n s c
         -> AllInSchema ns s res
         -> AllInSchema (n :: ns) s (n :> c :: res)

getAll :  {0 ss  : Schema}
       -> (names : List String)
       -> Row ss
       -> (prf : AllInSchema names ss res)
       => Row res
getAll []        _   {prf = []}     = []
getAll (n :: ns) row {prf = _ :: _} = getAt n row :: getAll ns row

--------------------------------------------------------------------------------
--          Use Case: Flexible Error Handling
--------------------------------------------------------------------------------

data Has :  (v : a) -> (vs  : Vect n a) -> Type where
  Z : Has v (v :: vs)
  S : Has v vs -> Has v (w :: vs)

Uninhabited (Has v []) where
  uninhabited Z impossible
  uninhabited (S _) impossible

data Union : Vect n Type -> Type where
  U : {0 ts : _} -> (ix : Has t ts) -> (val : t) -> Union ts

Uninhabited (Union []) where
  uninhabited (U ix _) = absurd ix

0 Err : Vect n Type -> Type -> Type
Err ts t = Either (Union ts) t

-- 1

project : (0 t : Type) -> (prf : Has t ts) => Union ts -> Maybe t
project t {prf = Z}   (U Z val)     = Just val
project t {prf = S p} (U (S x) val) = project t (U x val)
project t {prf = Z}   (U (S x) val) = Nothing
project t {prf = S p} (U Z val)     = Nothing

project1 : Union [t] -> t
project1 (U Z val) = val
project1 (U (S x) val) impossible

safe : Err [] a -> a
safe (Right x) = x
safe (Left x)  = absurd x

-- 2

weakenHas : Has t ts -> Has t (ts ++ ss)
weakenHas Z     = Z
weakenHas (S x) = S (weakenHas x)

weaken : Union ts -> Union (ts ++ ss)
weaken (U ix val) = U (weakenHas ix) val

extendHas : {m : _} -> {0 pre : Vect m a} -> Has t ts -> Has t (pre ++ ts)
extendHas {m = Z}   {pre = []}     x = x
extendHas {m = S p} {pre = _ :: _} x = S (extendHas x)

extend : {m : _} -> {0 pre : Vect m _} -> Union ts -> Union (pre ++ ts)
extend (U ix val) = U (extendHas ix) val

-- 3

0 Errs : Vect m Type -> Vect n Type -> Type
Errs []        _  = ()
Errs (x :: xs) ts = (Has x ts, Errs xs ts)

inject : Has t ts => (v : t) -> Union ts
inject v = U %search v

embed : (prf : Errs ts ss) => Union ts -> Union ss
embed (U Z val)     = inject val
embed (U (S x) val) = embed (U x val)

-- 4

data Rem : (v : a) -> (vs : Vect (S n) a) -> (rem : Vect n a) -> Type where
  [search v vs]
  RZ : Rem v (v :: rem) rem
  RS : Rem v vs rem -> Rem v (w :: vs) (w :: rem)

split : (prf : Rem t ts rem) => Union ts -> Either t (Union rem)
split {prf = RZ}   (U Z     val) = Left val
split {prf = RZ}   (U (S x) val) = Right (U x val)
split {prf = RS p} (U Z     val) = Right (U Z val)
split {prf = RS p} (U (S x) val) = case split {prf = p} (U x val) of
  Left vt        => Left vt
  Right (U ix y) => Right $ U (S ix) y

handle :  Applicative f
       => Rem t ts rem
       => (h : t -> f (Err rem a))
       -> Err ts a
       -> f (Err rem a)
handle h (Left x)  = case split x of
  Left v    => h v
  Right err => pure $ Left err
handle _ (Right x) = pure $ Right x

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

EmployeeSchema : Schema
EmployeeSchema = [ "firstName"  :> Str
                 , "lastName"   :> Str
                 , "email"      :> Str
                 , "age"        :> I64
                 , "salary"     :> Float
                 , "management" :> Boolean
                 ]

0 Employee : Type
Employee = Row EmployeeSchema

hock : Employee
hock = [ "Stefan", "Höck", "hock@foo.com", 46, 5443.2, False ]

shoeck : String
shoeck = getAt "firstName" hock ++ " " ++ getAt "lastName" hock

shoeck2 : String
shoeck2 = case getAll ["firstName", "lastName", "age"] hock of
  [fn,ln,a] => "\{fn} \{ln}: \{show a} years old."

embedTest :  Err [Nat,Bits8] a
          -> Err [String, Bits8, Int32, Nat] a
embedTest = mapFst embed


||| Reexporting `Data.Subset.Interfaces` and `Data.Subset.Predicates`
||| plus some utility functions.
module Data.Subset

import public Data.Subset.Interfaces
import public Data.Subset.Predicates
import public Data.Maybe

%default total

||| Compile time refinement of values
||| If this does not work, the predicate in question
||| might contain a negation. If that's the case, try `refine'`.
public export
refine : (v : t) -> {auto 0 prf : p v} -> Subset t p
refine v = Element v prf

||| Like `Data.Subset.refine` but goes via a propsition's `Predicate`
||| instance. This is necessary for instance for
||| compiletime verification of negations, for which
||| Idris2 is to able to come up with a value otherwise.
public export
refine' :  {0 t : Type} -> {0 p : t -> Type}
        -> Predicate t p
        => (v : t)
        -> {auto prf : IsJust (refineMay {p = p} v)}
        -> Subset t p
refine' v = fromJust (refineMay {p = p} v)

public export
fromInteger :  Num t
            => (v : Integer)
            -> {auto 0 prf : p (fromInteger v)}
            -> Subset t p
fromInteger v = refine (fromInteger v)

public export
fromString :  FromString t
           => (v : String)
           -> {auto 0 prf : p (fromString v)}
           -> Subset t p
fromString v = refine (fromString v)


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

> %name Vect xs, ys, zs

> append : Vect n a -> Vect m a -> Vect (n + m) a
> append xs ys
>     = case xs of
>            foo => ?bar

> data Foo a = MkFoo a | MkBar (a -> a)

> Functor Foo where
>   map f thing = ?baz


module Wheres

import Stuff

reverse : List a -> List a
reverse xs = rev' Nil xs
  where
    rev' : List a -> List a -> List a
    rev' acc Nil = acc
    rev' acc (x :: xs) = rev' (x :: acc) xs

foo : Int -> Int
foo x = case isLT of
            Yes => prim__mul_Int x 2
            No => prim__mul_Int x 4
  where
    data MyLT = Yes | No

    isLT : MyLT
    isLT = ifThenElse (intToBool (prim__lt_Int x 20)) Yes No


module UserApi

import Control.Monad.Freer
import Debug.Trace
import Control.Monad.Id

%access public export
%default total

data Tensor : Type where
  DoubleT : Double -> Tensor

implementation Show Tensor where
  show (DoubleT x) = show x

-- temporary
data Shape

data GraphData : Type -> Type where
  Mul : Tensor -> Tensor -> GraphData Tensor
  Placeholder : GraphData Tensor
  Constant : Double -> GraphData Tensor

FreeGraph : Type --type of computation graph ,freer graph
FreeGraph = Freer GraphData Tensor

implicit gt2fg : GraphData Tensor -> FreeGraph
gt2fg = liftF

newPlaceholder : FreeGraph
newPlaceholder = liftF Placeholder

exampleGraph : FreeGraph
exampleGraph = do
  t<-newPlaceholder
  a<-liftF Placeholder -- same
  b<-Placeholder -- same
  liftF (Mul t a)

const1 : GraphData Tensor
const1 = Constant 1

mulG : FreeGraph
mulG = do
  x<-liftF $ Constant 1
  y<-liftF $ Constant 3
  liftF $ Mul x y

numericGradId : {x : Type}->  GraphData Tensor->GraphData x -> Id x
numericGradId Placeholder (Mul x y) =  pure $ DoubleT  2.0
numericGradId (Constant z) (Mul (DoubleT x) (DoubleT y)) =
  let res : Double =(x*y + 0.1)/(z+0.1) in
  pure $ trace (show z ++ "," ++show x) $ DoubleT res
numericGradId (Mul x y) (Mul (DoubleT z) (DoubleT w)) = pure $ DoubleT 3.0
numericGradId _ (Constant x) = pure $ DoubleT 3.0
numericGradId _ Placeholder = pure $ DoubleT 4.0

mainGradId : Id String
mainGradId = do
  x <- (foldFreer ((trace "xxx" numericGradId) const1) mulG)
  --print x
  pure $ show x


-- Enumerated type example.
data Direction = North
               | East
               | South
               | West

turnClockwise : Direction -> Direction
turnClockwise North = East
turnClockwise East = South
turnClockwise South = West
turnClockwise West = North


module RLE

import Decidable.Equality

rep : Nat -> a -> List a

data RunLength : List a -> Type where
     Empty : RunLength []
     Run : (n : Nat) -> (x : a) -> (rest : RunLength more) ->
           RunLength (rep n x ++ more)

data Singleton : a -> Type where
     Val : (x : a) -> Singleton x

uncompress : RunLength xs -> Singleton xs

{-

rle : DecEq a => (xs : List a) -> RLE xs
rle [] = Empty
rle (x :: xs) with (rle xs)
  rle (x :: []) | Empty = Run 1 x Empty
  rle (x :: (rep n y ++ more)) | (Run n y comp) with (decEq x y)
    rle (y :: (rep n y ++ more)) | (Run n y comp) | (Yes Refl)
        = Run (S n) y comp
    rle (x :: (rep n y ++ more)) | (Run n y comp) | (No contra)
        = Run 1 x $ Run n y comp

data Singleton : a -> Type where
     Val : (x : a) -> Singleton x

uncompress : RLE xs -> Singleton xs

-- uncompress Empty = Val []
-- uncompress (Run n x comp)
--     = let Val rec = uncompress comp in
--           Val (rep n x ++ rec)

uncompressHelp : (x : a) -> RLE more -> (n : Nat) -> Singleton more -> Singleton (rep n x ++ more)
uncompressHelp x comp n (Val _) = Val (rep n x ++ more)

uncompress' : RLE xs -> Singleton xs
uncompress' Empty = Val []
uncompress' (Run n x comp)
    = let rec = uncompress' comp in
          uncompressHelp x comp n rec

{-
rle [] = Empty
rle (x :: xs) with (rle xs)
  rle (x :: []) | Empty = Run 1 x Empty
  rle (x :: (rep n y ++ more)) | (Run n y comp) with (decEq x y)
    rle (y :: (rep n y ++ more)) | (Run n y comp) | (Yes Refl)
        = Run (S n) y comp
    rle (x :: (rep n y ++ more)) | (Run n y comp) | (No contra)
        = Run 1 x $ Run n y comp

uncompress Empty = Val []
uncompress (Run n x comp)
   = let Val uncomp = uncompress comp in
         Val (rep n x ++ uncomp)
-}
-}


module Twist.Rotation

import Control.Algebra

import Twist.Cycle
import Twist.Face
import Twist.Util

%default total
%access export

data Rotation : (f : Type) -> (c : Type) -> (face : f) -> Type where
  Rot : (face : (Face (S k))) -> (c : Cycle (S j)) -> Rotation (Face (S k)) (Cycle (S j)) face

Eq c => Eq (Rotation f c face) where
  (Rot face cx) == (Rot face cy) = cx == cy

Show (Rotation f c face) where
  show (Rot face x) = show face ++ show x

cw : (Rotation f c face) -> (Rotation f c face)
cw (Rot face cx) = Rot face (next cx)

ccw : (Rotation f c face) -> (Rotation f c face)
ccw (Rot face cx) = Rot face (prev cx)

Semigroup (Rotation f c face) where
  (Rot face cx) <+> (Rot face cy) = Rot face (cx <+> cy)

rotateZ : (face : Face (S k)) -> Rotation (Face (S k)) (Cycle (S j)) face
rotateZ x = Rot x neutral

rotate : (face : Face (S k)) -> Rotation (Face (S k)) (Cycle (S j)) face
rotate x = Rot x (next neutral)

rotate' : (face : Face (S k)) -> Rotation (Face (S k)) (Cycle (S j)) face
rotate' x = Rot x (prev neutral)

Monoid (Rotation (Face (S k)) (Cycle (S j)) face) where
  neutral = Rot face neutral

Group (Rotation (Face (S k)) (Cycle (S j)) face) where
  inverse (Rot face cx) = Rot face (inverse cx)


--- Data declarations ---

infix 0 =%=

public export
data (=%=) : (a -> b) -> (a -> b) -> Type where
  ExtEq : {0 f, g : a -> b} -> ((x : a) -> f x = g x) -> f =%= g

infix 0 %%

public export
data (%%) a b = Equs (a = b) (b = a)

--- Records ---

infix 0 =%%=

public export
record (=%%=) {a : Type} {b : Type} (f : a -> b) (g : a -> b) where
  constructor ExtEqR
  fa : (x : a) -> f x = g x

--- Interfaces ---

infix 0 =%%%=

public export
interface (=%%%=) (x : a) (y : a) (b : Type) (i : Type) where
  idx : a -> i -> b
  eq : (ix : i) -> idx x ix = idx y ix


module Syntax.PreorderReasoning.Generic

import Control.Relation
import Control.Order
infixl 0  ~~
infixl 0  <~
prefix 1  |~
infix  1  ...

public export
data Step : (leq : a -> a -> Type) -> a -> a -> Type where
  (...) : (y : a) -> x `leq` y -> Step leq x y

public export
data FastDerivation : (leq : a -> a -> Type) -> (x : a) -> (y : a) -> Type where
  (|~) : (x : a) -> FastDerivation leq x x
  (<~) : {x, y : a}
         -> FastDerivation leq x y -> {z : a} -> (step : Step leq y z)
         -> FastDerivation leq x z

public export
CalcWith : Preorder dom leq => {0 x : dom} -> {0 y : dom} -> FastDerivation leq x y -> x `leq` y
CalcWith (|~ x) = reflexive {rel = leq}
CalcWith ((<~) der (z ... step)) = transitive {rel = leq} (CalcWith der) step

public export
(~~) : {0 x : dom} -> {0 y : dom}
         -> FastDerivation leq x y -> {z : dom} -> (step : Step Equal y z)
         -> FastDerivation leq x z
(~~) der (z ... Refl) = der


module TypedNBE

-- Typed NBE, based on https://hal.inria.fr/hal-01397929/document

import Data.Vect

data Ty = Base String | Arrow Ty Ty

data Syn : Vect n Ty -> Ty -> Type where
  Var : Elem a ctx -> Syn ctx a
  Lam : Syn (a :: ctx) b -> Syn ctx (Arrow a b)
  App : Syn ctx (Arrow a b) -> Syn ctx a -> Syn ctx b

V : Ty -> Type

mutual
  data Nf : Ty -> Type where
    NLam : (V a -> Nf b) -> Nf (Arrow a b)
    NAt : At (Base a) -> Nf (Base a)

  data At : Ty -> Type where
    AApp : At (Arrow a b) -> Nf a -> At b
    AVar : V a -> At a

data Sem : Ty -> Type where
  Fun : (Sem a -> Sem b) -> Sem (Arrow a b)
  Base' : At (Base a) -> Sem (Base a)

data Env : Vect n Ty -> Type where
  Nil  : Env Nil
  (::) : Sem ty -> Env ctx -> Env (ty :: ctx)

lookup' : Elem ty ctx -> Env ctx -> Sem ty
lookup' Here (x :: _) = x
lookup' (There later) (x :: xs) = lookup' later xs

eval : Env ctx -> Syn ctx ty -> Sem ty
eval env (Var x) = lookup' x env
eval env (Lam body) = Fun (\x => eval (x :: env) body)
eval env (App f x) with (eval env f)
  eval env (App f x) | (Fun f') = f' (eval env x)

mutual
  reflect : At ty -> Sem ty
  reflect {ty = (Base _)} at = Base' at
  reflect {ty = (Arrow a b)} at = Fun (\x => reflect (AApp at (reify x)))

  reify : Sem ty -> Nf ty
  reify {ty = (Base _)} (Base' base) = NAt base
  reify {ty = (Arrow a b)} (Fun f) = NLam (\x => reify (f (reflect (AVar x))))

nbe : Syn [] ty -> Nf ty
nbe syn = reify (eval [] syn)

example : Syn [] (Arrow (Base "a") (Base "a"))
example = Lam (App (Lam (Var Here)) (Var Here))

test : Nf (Arrow (Base "a") (Base "a"))
test = nbe example


-- Small (and obsolete) prototype of a cost-based computational
-- eDLS. Each operation has a cost. Functions take a lifted type,
-- FndType, that includes a fund. The output type of each lifted
-- operation contains the remaining fund after the operation.  It is
-- planned to be replaced by function realization described in
-- https://blog.singularitynet.io/ai-dsl-toward-a-general-purpose-description-language-for-ai-agents-21459f691b9e
-- but is kept here for future references.

module FndType

-- Funded type
public export
data FndType : Nat -> Type -> Type where
  FT : {fund : Nat} -> (datum : a) -> (FndType fund a)

-- Overload show for FndType
export
show : (FndType fund Int) -> String
show (FT datum) = "FT " ++ (show fund) ++ " " ++ (show datum)

-- Fund accessor
export
getFund : (FndType fund a) -> Nat
getFund (FT datum) = fund

-- Datum accessor
export
getDatum : (FndType fund a) -> a
getDatum (FT datum) = datum

-- Uplift function as to use FndType, with cost of 1.
export
upliftFun : {fund : Nat} -> {cost : Nat} -> (a -> b) -> (FndType (cost + fund) a) -> (FndType fund b)
upliftFun f = (\x => (FT (f (getDatum x))))

-- Downlift function as to run over datum rather than FndType.
export
downliftFun : {infund : Nat} -> ((FndType infund a) -> (FndType outfund b)) -> a -> b
downliftFun f = (\x => (getDatum (f (FT x))))

-- Lifted composition. Takes 2 filted functions and compose them
export
compose : ((FndType fund_b b) -> (FndType fund_c c))
        -> ((FndType fund_a a) -> (FndType fund_b b))
        -> (FndType fund_a a) -> (FndType fund_c c)
compose f g = (\x => (f (g x)))