||| Provides a data type for Monadic Stream Functions (MSFs)
||| together with associated interface implementations and
||| some core functionality.
|||
||| An MSF is an effectful computation from an input of type `i`
||| to an output of type `o`, that can be described using a rich
||| library of combinators and evaluated using function
||| `Data.MSF.Running.step`,
||| which not only produces an output for every input value
||| but also a new MSF to be used in the next evaluation step.
module Data.MSF.Core

import Data.MSF.Event
import Data.SOP

%default total

mutual
  ||| A heterogeneous list of MSFs. This is used both
  ||| for running several unrelated MSFs in parallel, in
  ||| which case it takes an n-ary product as input
  ||| and produces an n-ary product as output (see
  ||| function `par`), as well as for selecting a single
  ||| MSF to run based on an n-ary sum as input, in which
  ||| case a value of an n-ary sum is produced as output
  ||| (see function `choice` for this use case).
  public export
  data MSFList :  (m : Type -> Type)
               -> (is : List Type)
               -> (os : List Type)
               -> Type where
    Nil  : MSFList m [] []
    (::) :  (sf : MSF m i o)
         -> (sfs : MSFList m is os)
         -> MSFList m (i :: is) (o :: os)

  namespace FanList
    ||| A heterogeneous list of MSFs all of which
    ||| accept the same input type. This is used for
    ||| broadcasting a input value across several MSFs,
    ||| collecting the result as an n-ary product.
    ||| See also function `fan`.
    public export
    data FanList :  (m : Type -> Type)
                 -> (i : Type)
                 -> (os : List Type)
                 -> Type where
      Nil  : FanList m i Nil
      (::) :  (sf : MSF m i o)
           -> (sfs : FanList m i os)
           -> FanList m i (o :: os)

  namespace CollectList
    ||| A heterogeneous list of MSFs all of which
    ||| produce the same type of outup. This is used for
    ||| choosing a single MSF for producing a result based
    ||| on an n-ary sum as input. See also function `collect`.
    public export
    data CollectList :  (m  : Type -> Type)
                     -> (is : List Type)
                     -> (o  : Type)
                 -> Type where
      Nil  : CollectList m Nil o
      (::) :  (sf : MSF m i o)
           -> (sfs : CollectList m is o)
           -> CollectList m (i :: is) o

  ||| A monadic stream function (`MSF`) is used to
  ||| convert streams of input values of type `i` to
  ||| output values of type `o` in a monadic context `m`.
  |||
  ||| The [dunai](https://hackage.haskell.org/package/dunai)
  ||| library implements them as
  ||| `data MSF m i o = MSF (i -> m (o, MSF m i o))`
  ||| but this most general form does not go well with
  ||| the Idris totality checker.
  |||
  ||| It is therefore implemented as a set of primitive
  ||| constructors, some of which are truly primitives,
  ||| some of which are there for reasons of efficiency.
  ||| In later versions of this library, `MSF` might
  ||| no longer be publicly exported, so client code should
  ||| use the provided combinators instead of accessing the
  ||| data constructors directly.
  |||
  ||| `MSF` objects can be stepwise evaluated by invoking
  ||| function `Data.MSF.Running.step`.
  public export
  data MSF : (m : Type -> Type) -> (i : Type) -> (o : Type) -> Type where

    ||| The identity MSF
    Id        :  MSF m i i

    ||| The constant MSF
    Const     :  o -> MSF m i o

    ||| Lifts a pure function to an MSF
    Arr       :  (i -> o) -> MSF m i o

    ||| Lifts an effectful computation to an MSF
    Lifted    :  (i -> m o) -> MSF m i o

    ||| Sequencing of MSFs
    Seq       :  MSF m i x -> MSF m x o -> MSF m i o

    ||| Parallelising MSFs
    Par       :  MSFList m is os -> MSF m (NP I is) (NP I os)

    ||| Broadcasting a value to a list of MSFs
    ||| all taking the same input
    Fan       :  FanList m i os -> MSF m i (NP I os)

    ||| Choosing an MSF based on an n-ary sum as input
    Choice    :  MSFList m is os -> MSF m (NS I is) (NS I os)

    ||| Choosing an MSF (all of which produce the same output)
    ||| based on an n-ary sum as input
    Collect   :  CollectList m is o -> MSF m (NS I is) o

    ||| Feedback loops (stateful computations)
    Loop      :  s -> MSF m (NP I [s, i]) (NP I [s, o]) -> MSF m i o

    ||| Single time switching: Upon the first event,
    ||| the second stream function is calculated,
    ||| evaluated immediately and used henceforth.
    Switch    :  MSF m i (Either e o) -> (e -> MSF m i o) -> MSF m i o

--------------------------------------------------------------------------------
--          Lifting Primitives
--------------------------------------------------------------------------------

||| The identity MSF
export %inline
id : MSF m i i
id = Id

||| A constant MSF
export %inline
const : o -> MSF m i o
const = Const

||| Lifting a pure function to an MSF
export %inline
arr : (i -> o) -> MSF m i o
arr = Arr

||| Lifting an effectful computation to an MSF
export %inline
arrM : (i -> m o) -> MSF m i o
arrM = Lifted

||| Lifting a value in a context to an MSF
export %inline
constM : m o -> MSF m i o
constM = Lifted . const

--------------------------------------------------------------------------------
--          Sequencing MSFs
--------------------------------------------------------------------------------

infixr 1 >>>

||| Sequencing of MSFs
export %inline
(>>>) : MSF m i x -> MSF m x o -> MSF m i o
(>>>) = Seq

--------------------------------------------------------------------------------
--          Paralellising MSFs
--------------------------------------------------------------------------------

||| Runs a bundle of MSFs in parallel. This is
||| a generalization of `(***)` from `Control.Arrow`.
export %inline
par : MSFList m is os -> MSF m (NP I is) (NP I os)
par = Par

||| Broadcasts an input value across a list of MSFs,
||| all of which must accept the same type of input.
||| This is a generalization of `(&&&)` from `Control.Arrow`.
export %inline
fan : FanList m i os -> MSF m i (NP I os)
fan = Fan

||| Apply a binary function to the result of running
||| two MSFs in parallel.
export %inline
elementwise2 : (o1 -> o2 -> o3) -> MSF m i o1 -> MSF m i o2 -> MSF m i o3
elementwise2 f x y = fan [x,y] >>> arr (\[a,b] => f a b)

--------------------------------------------------------------------------------
--          Selecting MSFs
--------------------------------------------------------------------------------

||| Choose an MSF to run depending the input value
||| This is a generalization of `(+++)` from `Control.Arrow`.
export %inline
choice : MSFList m is os -> MSF m (NS I is) (NS I os)
choice = Choice

||| Choose an MSF all of which produce the same output.
||| This is a generalization of `(\|/)` from `Control.Arrow`.
export %inline
collect : CollectList m is o -> MSF m (NS I is) o
collect = Collect

--------------------------------------------------------------------------------
--          Loops and Stateful computations
--------------------------------------------------------------------------------

||| Feedback loops: Given an initial state value,
||| we can feedback the result of each evaluation
||| step and us it as the new state for the next step.
export %inline
feedback : s -> MSF m (NP I [s,i]) (NP I [s,o]) -> MSF m i o
feedback = Loop

--------------------------------------------------------------------------------
--          Interfaces
--------------------------------------------------------------------------------

export %inline
Functor (MSF m i) where
  map f = (>>> arr f)

export %inline
Applicative (MSF m i) where
  pure = Const
  (<*>) = elementwise2 apply

export %inline
Semigroup o => Semigroup (MSF m i o) where
  (<+>) = elementwise2 (<+>)

export %inline
Monoid o => Monoid (MSF m i o) where
  neutral = Const neutral

export %inline
Num o => Num (MSF m i o) where
  fromInteger = Const . fromInteger
  (+) = elementwise2 (+)
  (*) = elementwise2 (*)

export %inline
Neg o => Neg (MSF m i o) where
  (-)    = elementwise2 (-)
  negate = map negate

export %inline
Integral o => Integral (MSF m i o) where
  mod = elementwise2 mod
  div = elementwise2 div

export %inline
Fractional o => Fractional (MSF m i o) where
  (/)  = elementwise2 (/)

export %inline
FromString o => FromString (MSF m i o) where
  fromString = const . fromString


import Control.Monad.Identity
import System

fib : Integer -> Identity Integer
fib 0 = pure 0
fib 1 = pure 1
fib n = pure $ !(fib (n - 1)) + !(fib (n - 2))

main : IO ()
main = do
  value <- getLine
  printLn $ runIdentity (fib (cast value))


-- vim: set ft=idris sw=2 ts=2:
--
-- benchmark.idr
-- A set of (micro-) benchmarks for the Idris programming language
--

module Main

import System
import Fibonacci
import PerfectNumber

-- convert list to string
show_list : Show a => List a -> String
show_list [] = ""
show_list (x :: xs) = (show x) ++ ", " ++ show_list xs

-- main entry point
main : IO ()
main = do
  tic <- System.time
  putStrLn $ "fib_naive(35) = " ++ (show (fib_naive 35))
  toc <- System.time
  putStrLn $ "Elapsed " ++ (show (toc - tic)) ++ "s."

  tic <- System.time
  putStrLn $ "fib(35) = " ++ (show (Fibonacci.fib 35))
  toc <- System.time
  putStrLn $ "Elapsed " ++ (show (toc - tic)) ++ "s."

  tic <- System.time
  putStrLn $ "fib(1000) = " ++ (show (Fibonacci.fib 1000))
  toc <- System.time
  putStrLn $ "Elapsed " ++ (show (toc - tic)) ++ "s."

  tic <- System.time
  putStrLn $ "pn(1000) = " ++ (show (perfect_numbers 1000))
  toc <- System.time
  putStrLn $ "Elapsed " ++ (show (toc - tic)) ++ "s."


||| ported from https://github.com/pepijnkokke/FirstOrderUnificationInAgda
module Unification

import Data.Fin

%default total
%access public export

||| An identifier
data Name = MkName String

Eq Name where
  (MkName x) == (MkName y) = x == y

||| A term in an untyped lambda-calculus with variables indexed by `v`.
||| Either a variable, an identifier, or a function applied to an argument.
||| We keep track of the depth `d` to ensure terms are finite.
||| @ v the type `Var`s are indexed by
||| @ d the depth of the AST
data TermD : (v : Type) -> (d : Nat) -> Type where
  ||| A variable with index `i`
  Var : (i : v) -> TermD v Z
  ||| an identifier with name `n`
  Identifier : (n : Name) -> TermD v Z
  ||| function application, `f` applied to `x`
  App : (f : TermD v d1) -> (x : TermD v d2) -> TermD v (S (max d1 d2))

||| A TermD with `d` as a reified witness instead of a type param
data Term : (v : Type) -> Type where
  MkTerm : Exists (TermD v) -> Term v

namespace Term
  depth : Term v -> Nat
  depth (MkTerm t) = getWitness t

  {- implicit conversions to/from TermD -}
  implicit
  toTermD : (t : Term v) -> TermD v (depth t)
  toTermD (MkTerm t) = getProof t

  implicit
  fromTermD : TermD v d -> Term v
  fromTermD {d=d} t = MkTerm (Evidence d t)

  {- constructors for Term (making use of implicit conversions to/from TermD) -}
  var : v -> Term v
  var v = Var v

  identifier : {v : Type} -> Name -> Term v
  identifier c = Identifier c

  app : Term v -> Term v -> Term v
  app left right = App left right

  ||| The catamorphism for Term.
  ||| We unpack and use `d` to convince idris `fold'` is total,
  ||| so callers of `fold` can ignore `d` and not worry about totality.
  fold : (v -> r) -> (Name -> r) -> (r -> r -> r) -> Term v -> r
  fold v n f (MkTerm (Evidence d t)) = fold' v n f d t where
    fold' v n f d t = case t of
      Var i => v i
      Identifier c => n c
      App {d1=d1} {d2=d2} l r => f (fold' v n f d1 l) (fold' v n f d2 r)

Functor Term where
  map f t = fold (var . f) identifier app t

Applicative Term where
  pure = var
  mf <*> ma = fold (\f => map f ma) identifier app mf

Monad Term where
  t >>= f = fold f identifier app t

Foldable Term where
  foldr op z t = fold op (const id) (.) t z

Traversable Term where
  traverse f = fold
    (\y => [| var (f y) |])
    (\c => pure (identifier c))
    (\l, r => [| app l r |])

{- Now for some unification... -}

||| A substitution of a `Term (Fin n)` for a variable in `Fin (S n)`.
||| @ n the number of vars after applying the substitution.
data Subst : (n : Nat) -> Type where
  ||| Make a Subst
  ||| @ x the variable to replace
  ||| @ t the term (not mentioning `x`) to replace `x` with
  MkSubst : (x : Fin (S n)) -> (t : Term (Fin n)) -> Subst n

{-
  thick and thin help keep track of var indexes when vars are
  introduced or removed.
-}
||| `thick x` maps each `Fin (S n)` that is not `x` to a unique `Fin n`.
||| Useful when removing `x` from the set of vars (e.g. with a `Subst`).
||| y |-> Just y,        if y < x,
|||       Nothing,       if y = x,
|||       Just (pred y), if y > x
thick : (x, y : Fin (S n)) -> Maybe (Fin n)
thick {n=S k} FZ     (FS y) = Just y              -- y < x
thick {n=S k} (FS x) FZ     = Just FZ             -- y > x
thick {n=S k} (FS x) (FS y) = FS <$> thick x y    -- recurse
thick         _      _      = Nothing             -- y = x

||| `thin x` maps each `Fin n` to a unique `Fin (S n)` that is not `x`.
||| The inverse of `y |-> thick x y` for `y`s s.t. `y != x`.
||| Useful for undoing a `Subst`.
||| y |-> FS y, if y >= x,
|||       y,    if y < x
thin : (x : Fin (S n)) -> (y : Fin n) -> Fin (S n)
thin FZ     y      = FS y
thin x      FZ     = FZ
thin (FS x) (FS y) = FS (thin x y)

||| replaces any occurrance of a `Var y` in `t` with `r` if
||| `x == y` or `Var (thick x y)` otherwise.
||| @ s the substitution to make
||| @ t the term to search and replace in
subst : (s : Subst m) -> (t : Term (Fin (S m))) -> Term (Fin m)
subst (MkSubst x r) t = map (thick x) t >>= (maybe r var)

||| A list of substitutions, of the form
||| `[Subst m d, Subst m-1 d, Subst m-2 d, ...]`.
||| Substitutions are applied left to right.
||| Each `s` in a SubstList reduces the number of variables by one, so
||| successive substitutions operate on the reduced set of var idxs.
||| @ m the number of vars before applying the substitutions.
||| @ n the number of vars remaining after applying the substitutions.
data SubstList : (m : Nat) -> (n : Nat) -> Type where
  Nil : {n : Nat} -> SubstList n n  -- no op, number of vars is unchanged
  (::) : (s : Subst m) ->
         (tail : SubstList m n)
           -> SubstList (S m) n

||| Check that `x` doesn't appear in `t`.
||| If it does, return Nothing.
||| If it doesn't, return `t` but over a smaller set of vars.
check : (x : Fin (S n)) -> (t : Term (Fin (S n))) -> Maybe (Term (Fin n))
check x = traverse (thick x)

||| As long as the var x doesn't appear in t, we can unify x and t
||| by substituting t for x.
flexRigid : Fin n -> Term (Fin n) -> Maybe (Exists (SubstList n))
flexRigid {n=Z} _ _ = Nothing  -- impossible, Fin Z is uninhabited
flexRigid {n=S n'} x t = map (\t' => Evidence n' [MkSubst x t']) (check x t)

||| we can always unify two variables
flexFlex : (x, y : Fin n) -> Exists (SubstList n)
flexFlex {n=Z} _ _ = Evidence Z []  -- impossible, Fin Z is uninhabited
flexFlex {n=S n'} x y = case thick x y of
  Nothing => Evidence (S n') []                -- x = y, no subst needed
  Just y' => Evidence n' [MkSubst x (Var y')]  -- x != y, sub y' for x

||| helper function for unify
unify' : (t1 : TermD (Fin m) d1) ->
         (t2 : TermD (Fin m) d2) ->
         (acc : Exists (SubstList m))
           -> Maybe (Exists (SubstList m))
unify' t1 t2 (Evidence n (s :: tail)) =  -- non-empty `acc`
  map consS $ unify' (subst s t1) (subst s t2) (Evidence n tail) where
    consS (Evidence n' sl) = Evidence n' (s :: sl)
unify' (Var x1) (Var x2) _ = Just (flexFlex x1 x2)
unify' (Var x1) t2       _ = flexRigid x1 t2
unify' t1       (Var x2) _ = flexRigid x2 t1
unify' {m=m} (Identifier c1) (Identifier c2) acc =
  if c1 == c2 then Just acc else Nothing
unify' (App la ra) (App lb rb) acc =
  Just acc >>= unify' la lb >>= unify' ra rb
unify' _ _ _ = Nothing  -- can't unify identifier with function application
                        -- (in first-order unification, anyway)

||| Finds the most general substitutions of terms for variables that makes
||| the two terms equal.
unify : (t1 : Term (Fin m)) -> (t2 : Term (Fin m)) -> Maybe (Exists (SubstList m))
unify {m=m} t1 t2 = unify' t1 t2 (Evidence m [])


module And.A.Proof

import Yet.Another.Path as Val

%default total

equality : Val.val === 2+3
equality = Refl


module Decidable.Decidable

import Data.Rel
import Data.Fun

||| Interface for decidable n-ary Relations
public export
interface Decidable (ts : Vect k Type) (p : Rel ts) where
  total decide : liftRel ts p Dec

||| Given a `Decidable` n-ary relation, provides a decision procedure for
||| this relation.
decision : (ts : Vect k Type) -> (p : Rel ts) -> (Decidable ts p) => liftRel ts p Dec
decision ts p = decide {ts} {p}

using (a : Type, x : a)
  public export
  data Given : Dec a -> Type where
    Always : Given (Yes x)


module Data.Map

import Control.Monad.State

%access public
%default total

namespace immutable
  class Map (m : Type -> Type -> Type) where
    empty : m k v

    fromList : List (k,v) -> m k v
    toList : m k v -> List (k,v)
    listKeys : m k v -> List k
    listValues : m k v -> List v

    fromVect : Vect n (k,v) -> m k v
    toVect : m k v -> (n ** Vect n (k,v))
    vectKeys : m k v -> (n ** Vect n (k))
    vectValues : m k v -> (n ** Vect n (v))

    grub : Eq k => k -> m k v -> List v
    lookup : Eq k => k -> m k v -> Maybe v

    insert : (k, v) -> m k v -> m k v
    erase : Eq k => k -> m k v -> m k v
    eraseBy : ((k,v) -> Bool) -> m k v -> m k v

  infix 2 !!
  (!!) : (Eq k, Map m) => m k v -> k -> List v
  (!!) = flip grub

  infix 2 !
  (!) : (Eq k, Map m)  => m k v -> k -> Maybe v
  (!) = flip lookup

  insertBy : Map m => (v -> k) -> v -> m k v -> m k v
  insertBy f v x = insert (f v, v) x

namespace mutable
  class Map (m : (Type -> Type) -> Type -> Type -> Type) where
    empty : f (m f k v)

    fromList : List (k,v) -> f (m f k v)
    toList : m f k v -> f (List (k,v))
    listKeys : m f k v -> f (List k)
    listValues : m f k v -> f (List v)

    fromVect : Vect n (k,v) -> f (m f k v)
    toVect : m f k v -> f (n ** Vect n (k,v))
    vectKeys : m f k v -> f (n ** Vect n k)
    vectValues : m f k v -> f (n ** Vect n v)

    grub : k -> m f k v -> f (List v)
    lookup : k -> m f k v -> f (Maybe v)

    insert : (k, v) -> m f k v -> f ()
    erase : k -> m f k v -> f ()
    eraseBy : ((k,v) -> Bool) -> m f k v -> f ()
    wipe : m f k v -> f ()

  infix 2 !!
  (!!) : mutable.Map m => m f k v -> k -> f (List v)
  (!!) = flip grub

  infix 2 !
  (!) : mutable.Map m  => m f k v -> k -> f (Maybe v)
  (!) = flip lookup

  insertBy : (Monad f, mutable.Map m) => (v -> f k) -> v -> m f k v -> f ()
  insertBy f v x = do { k <- f v; insert (k, v) x }


-- $ chcp 65001
-- $ idris
-- > :l G1UpperProverNewyear
module G1UpperProverNewyear

import G4LowerFormalPSpring
import G3MiddleFunctionsWinter
import G2Postulate

%default total

gx1 : GNat
gx1 = 17

-- 46
data IsProvable : GNat -> Type where
  Yes : (p ** True = proves p x) -> IsProvable x

postulate p315 : (c, d : GNat) -> True = proves c (forall d (r d)) -> IsProvable (r c)

||| Double negation elimination
--DNE : Type -> Type
--DNE p = Not $ Not p -> p
-- 二重否定除去
postulate dne : ((a -> Void) -> Void) -> a
dne2 : a -> ((a -> Void) -> Void)
dne2 x f = f x

||| The converse of contraposition: (p -> q) -> Not q -> Not p
Transposition : Type -> Type -> Type
Transposition p q = (Not q -> Not p) -> p -> q

-- E1
fuga2 : Transposition ((Not . IsProvable) 17) ((t:GNat) -> False = proves t 17)
fuga2 prf p = let ans1 = flip prf p in let ans2 = dne ans1 in ans2
fuga4 : (((t : Nat) -> False = proves t 17) -> Void) -> IsProvable 17
fuga3 : (((t : Nat) -> False = proves t 17) -> Void) -> (IsProvable 17 -> Void) -> Void
fuga3 = dne2 . fuga4
fuga5 : (IsProvable 17 -> Void) -> (t : Nat) -> False = proves t 17
fuga5 = fuga2 fuga3

hoge : IsProvable (forall 17 (r 17)) -> GNat
hoge (Yes dep) -- = ?rhs1
  = let s = fst dep in let prf = snd dep in
    let d5 = p315 s gx1 prf in ?rhs1

namespace a
  -- 46_2
  data IsProvable2 : Bool -> GNat -> Type where
    Yes : (p ** True = proves p x) -> IsProvable2 True x
    No : ((t : GNat) -> False = proves t x) -> IsProvable2 False x

  huga : IsProvable2 True (forall 17 (r 17)) -> GNat
  huga (Yes dep) = 3


import Data.String

Interpolation Bool where
  interpolate True = "TT"
  interpolate False = "FF"

Interpolation Nat where
  interpolate Z = "0"
  interpolate (S n) = "S \{n}"

Interpolation Integer where
  interpolate = show

test : String
test = "\{2}\{True}: \{True}\{True}"


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

module Data.AVL.Test.Dict

import Test.Unit
import Test.Random.Values

import Data.AVL.Dict

%access export

kvlist1 : List (Integer, Integer)
kvlist1 = rndListIntKVU 123456789 (0,100) 20

-- ------------------------------------------------------------ [ Construction ]

testBuilding : IO Bool
testBuilding = genericTest
    (Just "List, Building" )
    (Dict.size $ Dict.fromList kvlist1)
    20
    (==)

-- ---------------------------------------------------------------- [ Updating ]
partial
testUpdate : IO Bool
testUpdate = genericTest
    (Just "Update")
    (Dict.toList $ Dict.update 2 (*2) $ Dict.fromList [(1,2), (2,3), (3,4), (5,3)])
    [(1,2), (2,6), (3,4), (5,3)]
    (==)

partial
testHas : IO Bool
testHas = genericTest
   (Just "Has value")
   (hasValue 6 $ Dict.fromList [(1,2), (2,6), (3,4)])
   (True)
   (==)

-- ----------------------------------------------------------------- [ Queries ]
partial
testLookup : IO Bool
testLookup = genericTest
    (Just "Lookup")
    (Dict.lookup 1 $ Dict.fromList [(1,2), (2,3), (3,4)])
    (Just 2)
    (==)

partial
testKVs : IO Bool
testKVs = genericTest
    (Just "KV Pair Extraction")
    (keys given, values given)
    ([1,2,3], [5,6,7])
    (==)
  where
    given : Dict Int Int
    given = Dict.fromList [(1,5), (2,6), (3,7)]

-- --------------------------------------------------------- [ Implementations ]

partial
testFunctorWorksOnValues : IO Bool
testFunctorWorksOnValues = genericTest
    (Just "Functor works on values")
    (Dict.toList $ (* 2) <$> Dict.fromList [("a", 1), ("b", 2)])
    [("a", 2), ("b", 4)]
    (==)

partial
testTraversableTraversesOnValues : IO Bool
testTraversableTraversesOnValues = genericTest
    (Just "Traversable works on values")
    (traverse Just $ Dict.fromList [("a", 1), ("b", 2)])
    (Just $ Dict.fromList [("a", 1), ("b", 2)])
    (==)

partial
runTest : IO ()
runTest = do
  putStrLn "Testing Dict"
  putStrLn infoLine
  NonReporting.runTests [
      testBuilding
    , testLookup
    , testUpdate
    , testHas
    , testKVs
    , testFunctorWorksOnValues
    , testTraversableTraversesOnValues
  ]

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


-- vim: ft=idris sw= ts=2 et

import Data.Vect

-- vector arithmetics
add : Vect n a -> Vect m a -> Vect (n + m) a
add Nil ys = ys
add (x :: xs) ys = x :: add xs ys


module FreeSelectiveDelivery

-- Based on https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf,
--          https://www.cs.ox.ac.uk/jeremy.gibbons/publications/delivery.pdf

interface Applicative f => Selective (f : Type -> Type) where
  select : f (Either a b) -> f (a -> b) -> f b

data Select : (Type -> Type) -> Type -> Type where
  Pure : a -> Select f a
  SelectC : Select f (Either a b) -> f (a -> b) -> Select f b

Functor f => Functor (Select f) where
  map f (Pure x) = Pure $ f x
  map f (SelectC fe ff) = SelectC (map (map f) fe) (map (f .) ff)

Functor f => Applicative (Select f) where
  pure x = Pure x

  (Pure f) <*> fa = map f fa
  (SelectC fe ff) <*> fa = SelectC (pure (\e, a => either (\x => Left (x, a)) (\f => Right (f a)) e) <*> fe <*> fa)
                                   (map uncurry ff)

Functor f => Selective (Select f) where
  select fe (Pure f) = map (either f id) fe
  select fe (SelectC fe' ff') = SelectC (select (map f fe) (map g fe')) (map uncurry ff')
    where
      f : {a, a', b : Type} -> Either a b -> Either a (Either (a', a) b)
      f e = map Right e
      g : {a, a', b : Type} -> Either a' (a -> b) -> a -> Either (a', a) b
      g e a = either (\a' => Left (a', a)) (\f => Right $ f a) e

runSelect : Selective g => ({x : Type} -> f x -> g x) -> Select f a -> g a
runSelect nat (Pure x) = pure x
runSelect nat (SelectC fe ff) = select (runSelect nat fe) (nat ff)

whenS : Selective f => f Bool -> f () -> f ()
whenS fb fu = select (selector fb) (effect fu)
  where
    selector : f Bool -> f (Either () ())
    selector fb = map (\x => if x then Left () else Right ()) fb
    effect : f () -> f (() -> ())
    effect fu = map const fu

Selective IO where
  select fb ff = fb >>= \e => case e of Left a => map (\f => f a) ff
                                        Right b => pure b

data Teletype : Type -> Type where
  GetLine : Teletype String
  PutStrLn : String -> Teletype ()

interface Serialize (f : Type -> Type) where
  serialize : f a -> (String, String)
interface Deserialize (f : Type -> Type) where
  deserialize : f a -> (String, String) -> Maybe (f a)

Serialize Teletype where
  serialize GetLine = ("GetLine", "")
  serialize (PutStrLn x) = ("PutStrLn", x)

Deserialize Teletype where
  deserialize GetLine ("GetLine", "") = Just $ GetLine
  deserialize (PutStrLn _) ("PutStrLn", s) = Just $ PutStrLn s
  deserialize _ _ = Nothing

data Action : (Type -> Type) -> Type -> Type where
  ActionC : f r -> (r -> a) -> Action f a

Functor (Action f) where
  map f (ActionC c k) = ActionC c (f . k)

Program : (Type -> Type) -> Type -> Type
Program f a = Select (Action f) a

serializeP : Serialize f => Program f a -> List (String, String)
serializeP (Pure _) = []
serializeP (SelectC fs (ActionC c _)) = serialize c :: serializeP fs

deserializeP : Deserialize f => Program f a -> List (String, String) -> Maybe (Program f a)
deserializeP (Pure x) [] = Just $ Pure x
deserializeP (SelectC ff (ActionC c k)) (s :: ss) with (deserialize c s)
  deserializeP (SelectC ff (ActionC c k)) (s :: ss) | Nothing = Nothing
  deserializeP (SelectC ff (ActionC c k)) (s :: ss) | (Just c') = deserializeP ff ss >>= (\ff' => pure $ SelectC ff' (ActionC c' k))
deserializeP _ _ = Nothing

effect : f r -> Program f r
effect c = SelectC (Pure (Left ())) (ActionC c const)

getLine : Program Teletype String
getLine = effect GetLine

putStrLn : String -> Program Teletype ()
putStrLn s = effect (PutStrLn s)

pingPongS : String -> Program Teletype ()
pingPongS s = whenS (map (== "ping") getLine) (putStrLn s)

toIO : Action Teletype a -> IO a
toIO (ActionC GetLine k) = getLine >>= (\x => pure $ k x)
toIO (ActionC (PutStrLn s) k) = putStrLn s >>= (\x => pure $ k x)

testIO : IO ()
testIO = runSelect toIO (pingPongS "pong")

testSerialize : List (String, String)
testSerialize = serializeP (pingPongS "ppong")

testDeserialize : IO ()
testDeserialize = case deserializeP (pingPongS "pong") testSerialize of
                      Nothing => pure ()
                      Just p => runSelect toIO p


-- Prototype of NonDTRealizedFunction as described in
-- https://blog.singularitynet.io/ai-dsl-toward-a-general-purpose-description-language-for-ai-agents-21459f691b9e

module NonDTRealizedFunction

import public NonDTRealizedAttributes

public export
record NonDTRealizedFunction a where
  constructor MkNonDTRealizedFunction
  function : a
  attributes : NonDTRealizedAttributes

-- Perform the composition between 2 realized functions.  The
-- resulting realized function is formed as follows:
--
-- 1. Composed lifted functions
-- 2. Costs are added
-- 3. Minimum quality is retained
--
-- For now only the IO types of the functions are dependent types, not
-- the attribtes.
public export
compose : (NonDTRealizedFunction (b -> c)) ->
          (NonDTRealizedFunction (a -> b)) ->
          (NonDTRealizedFunction (a -> c))
compose rlz_f rlz_g = MkNonDTRealizedFunction rlz_fg fg_attrs where
  rlz_fg : a -> c
  rlz_fg = rlz_f.function . rlz_g.function
  fg_attrs : NonDTRealizedAttributes
  fg_attrs = add_costs_min_quality rlz_f.attributes rlz_g.attributes

-- Perform function application over realized functions.  Maybe we'd
-- want to used some funded data, as defined in FndType.
public export
apply : NonDTRealizedFunction (a -> b) -> a -> b
apply rlz_f = rlz_f.function


module Extra.Alternative

import Data.List1
import public Extra.Applicative

infixl 2 <|>|

public export
interface Alternative f => LazyAlternative f where
  (<|>|) : f a -> Lazy (f a) -> f a

||| succeed multiple times until failure, and returns all the successful results
export
many : (LazyApplicative f, Alternative f) => f a -> f (List a)
many p = ((::) <$> p <*>| many p) <|> pure neutral

||| `many` but must succeed the first time
export
some : (LazyApplicative f, Alternative f) => f a -> f (List1 a)
some p = (:::) <$> p <*>| many p

export
sepBy : (LazyApplicative f, Alternative f) => f a -> f b -> f (List a)
sepBy parser seperator = (::) <$> parser <*>| ((seperator *>| sepBy parser seperator) <|> pure neutral)

||| `sepBy1` but must succeed the first time
export
sepBy1 : (LazyApplicative f, Alternative f) => f a -> f b -> f (List1 a)
sepBy1 parser seperator = (:::) <$> parser <*>| ((seperator *> sepBy parser seperator) <|> pure neutral)

export
manyTill : (LazyApplicative f, LazyAlternative f) => f a -> f b -> f (List a)
manyTill parser end = (end $> Nil) <|>| ((::) <$> parser <*>| manyTill parser end)

||| If the alternative fails, then defaults to a pure value
export
option : Alternative f => (defaultsTo : a) -> f a -> f a
option def f = f <|> pure def

||| If the alternative fails, return Nothing, otherwise return a Just
export
optional : Alternative f => f a -> f (Maybe a)
optional f = option Nothing (Just <$> f)


module Main

import Data.Vect

----------------------------------------------------------------------
-- Hilffunktion

remove : (x : a) -> (xs : Vect (S n) a) -> { auto prf : Elem x xs } -> Vect n a
remove {prf = Here} x (x :: ys) = ys
remove {prf = (There Here)} x (y :: (x :: xs)) = y :: xs
remove {prf = (There (There later))} x (y :: (z :: xs)) = y :: remove x (z::xs)

----------------------------------------------------------------------
-- Spiel-Zustand

data GameState : (guessesRemaining : Nat) -> (letters : Nat) -> Type where
  MkGameState : (word : String)
                -> (missing : Vect letters Char)
                -> GameState guessesRemaining letters

data Finished : Type where
  Lost : (game : GameState 0 (S letters)) -> Finished
  Won : (game : GameState (S guesses) 0) -> Finished

----------------------------------------------------------------------
-- Spielereingabe prüfen

data ValidInput : List Char -> Type where
  Letter : (c : Char) -> ValidInput [c]

toFew : ValidInput [] -> Void
toFew (Letter _) impossible

toMuch : ValidInput (c::c'::cs) -> Void
toMuch (Letter _) impossible

isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No toFew
isValidInput [c] = Yes (Letter c)
isValidInput (c::c'::cs) = No toMuch

isValidString : (s : String) -> Dec (ValidInput (unpack s))
isValidString s = isValidInput _

----------------------------------------------------------------------
-- Eingabe

readGuess : IO (c ** ValidInput c)
readGuess = do
  putStrLn "Buchstabe? "
  input <- getLine
  case isValidString (toUpper input) of
    Yes prf => pure (_ ** prf)
    No _ => do
      print "ungültige Eingabe"
      readGuess

----------------------------------------------------------------------
-- Verarbeitung

processGuess : (letter : Char) ->
               GameState (S guesses) (S letters) ->
               Either (GameState guesses (S letters))
                      (GameState (S guesses) letters)
processGuess letter (MkGameState word missing) =
  case isElem letter missing of
    Yes ind => Right (MkGameState word (remove letter missing))
    No _ => Left (MkGameState word missing)

----------------------------------------------------------------------
-- Spiel-Funktion

game : GameState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} gameState = do
  (_ ** Letter letter) <- readGuess
  case processGuess letter gameState of
    Left nope => do
      putStrLn "falsch geraten"
      case guesses of
        Z => pure (Lost nope)
        S k => game nope
    Right yeah => do
      putStrLn "richtig geraten"
      case letters of
        Z => pure (Won yeah)
        S k => game yeah

----------------------------------------------------------------------
-- Main

main : IO ()
main = do
  ergebnis <- game {guesses=5}
	(MkGameState "DevOpenSpace" ['D','E','V','O','P','N','S','A','C'])
  case ergebnis of
    Lost (MkGameState word _) =>
      putStrLn ("Verloren - das Wort war " ++ word)
    Won _ =>
      putStrLn "Gewonnen!"


module Shape

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

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

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

export
circle : Double -> Shape
circle = Circle

public export
data ShapeView : Shape -> Type where
  STriangle : ShapeView (triangle _ _)
  SRectangle : ShapeView (rectangle _ _)
  SCircle : ShapeView (circle _)

export
shapeView : (shape : Shape) -> ShapeView shape
shapeView (Triangle _ _)  = STriangle
shapeView (Rectangle _ _) = SRectangle
shapeView (Circle _)      = SCircle


Ty : Type
Ty = (Ty   : Type)
 ->  (nat  : Ty)
 ->  (top  : Ty)
 ->  (bot  : Ty)
 ->  (arr  : Ty -> Ty -> Ty)
 ->  (prod : Ty -> Ty -> Ty)
 ->  (sum  : Ty -> Ty -> Ty)
 ->  Ty

nat : Ty
nat = \ _, nat, _, _, _, _, _ => nat
top : Ty
top = \ _, _, top, _, _, _, _ => top
bot : Ty
bot = \ _, _, _, bot, _, _, _ => bot

arr : Ty-> Ty-> Ty
arr = \ a, b, ty, nat, top, bot, arr, prod, sum =>
     arr (a ty nat top bot arr prod sum) (b ty nat top bot arr prod sum)

prod : Ty-> Ty-> Ty
prod = \ a, b, ty, nat, top, bot, arr, prod, sum =>
     prod (a ty nat top bot arr prod sum) (b ty nat top bot arr prod sum)

sum : Ty-> Ty-> Ty
sum = \ a, b, ty, nat, top, bot, arr, prod, sum =>
     sum (a ty nat top bot arr prod sum) (b ty nat top bot arr prod sum)

Con : Type
Con = (Con : Type)
 -> (nil  : Con)
 -> (snoc : Con -> Ty-> Con)
 -> Con

nil : Con
nil = \ con, nil, snoc => nil

snoc : Con -> Ty-> Con
snoc = \ g, a, con, nil, snoc => snoc (g con nil snoc) a

Var : Con -> Ty-> Type
Var = \ g, a =>
    (Var : Con -> Ty-> Type)
 -> (vz  : {g:_}->{a:_} -> Var (snoc g a) a)
 -> (vs  : {g:_}->{b:_}->{a:_} -> Var g a -> Var (snoc g b) a)
 -> Var g a

vz : {g:_}->{a:_} -> Var (snoc g a) a
vz = \ var, vz, vs => vz

vs : {g:_}->{b:_}->{a:_} -> Var g a -> Var (snoc g b) a
vs = \ x, var, vz, vs => vs (x var vz vs)

Tm : Con -> Ty-> Type
Tm = \ g, a =>
    (Tm    : Con -> Ty-> Type)
 -> (var   : {g:_}->{a:_}-> Var g a -> Tm g a)
 -> (lam   : {g:_}->{a:_}->{b:_} -> Tm (snoc g a) b -> Tm g (arr a b))
 -> (app   : {g:_}->{a:_}->{b:_} -> Tm g (arr a b) -> Tm g a -> Tm g b)
 -> (tt    : {g:_}-> Tm g top)
 -> (pair  : {g:_}->{a:_}->{b:_} -> Tm g a -> Tm g b -> Tm g (prod a b))
 -> (fst   : {g:_}->{a:_}->{b:_} -> Tm g (prod a b) -> Tm g a)
 -> (snd   : {g:_}->{a:_}->{b:_} -> Tm g (prod a b) -> Tm g b)
 -> (left  : {g:_}->{a:_}->{b:_} -> Tm g a -> Tm g (sum a b))
 -> (right : {g:_}->{a:_}->{b:_} -> Tm g b -> Tm g (sum a b))
 -> (split : {g:_}->{a:_}->{b:_}-> {c:_} -> Tm g (sum a b) -> Tm g (arr a c) -> Tm g (arr b c) -> Tm g c)
 -> (zero  : {g:_}-> Tm g nat)
 -> (suc   : {g:_}-> Tm g nat -> Tm g nat)
 -> (rec   : {g:_}->{a:_} -> Tm g nat -> Tm g (arr nat (arr a a)) -> Tm g a -> Tm g a)
 -> Tm g a

var : {g:_}->{a:_} -> Var g a -> Tm g a
var = \ x, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec => var x

lam : {g:_}->{a:_}->{b:_}-> Tm (snoc g a) b -> Tm g (arr a b)
lam = \ t, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     lam (t tm var lam app tt pair fst snd left right split zero suc rec)

app : {g:_}->{a:_}->{b:_} -> Tm g (arr a b) -> Tm g a -> Tm g b
app = \ t, u, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     app (t tm var lam app tt pair fst snd left right split zero suc rec)
         (u tm var lam app tt pair fst snd left right split zero suc rec)

tt : {g:_} -> Tm g Main.top
tt = \ tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec => tt

pair : {g:_}->{a:_}->{b:_} -> Tm g a -> Tm g b -> Tm g (prod a b)
pair = \ t, u, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     pair (t tm var lam app tt pair fst snd left right split zero suc rec)
          (u tm var lam app tt pair fst snd left right split zero suc rec)

fst : {g:_}->{a:_}->{b:_}-> Tm g (prod a b) -> Tm g a
fst = \ t, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     fst (t tm var lam app tt pair fst snd left right split zero suc rec)

snd : {g:_}->{a:_}->{b:_} -> Tm g (prod a b) -> Tm g b
snd = \ t, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     snd (t tm var lam app tt pair fst snd left right split zero suc rec)

left : {g:_}->{a:_}->{b:_} -> Tm g a -> Tm g (sum a b)
left = \ t, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     left (t tm var lam app tt pair fst snd left right split zero suc rec)

right : {g:_}->{a:_}->{b:_} -> Tm g b -> Tm g (sum a b)
right = \ t, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     right (t tm var lam app tt pair fst snd left right split zero suc rec)

split : {g:_}->{a:_}->{b:_}->{c:_} -> Tm g (sum a b) -> Tm g (arr a c) -> Tm g (arr b c) -> Tm g c
split = \ t, u, v, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     split (t tm var lam app tt pair fst snd left right split zero suc rec)
          (u tm var lam app tt pair fst snd left right split zero suc rec)
          (v tm var lam app tt pair fst snd left right split zero suc rec)

zero : {g:_} -> Tm g Main.nat
zero = \ tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec => zero

suc : {g:_} -> Tm g Main.nat -> Tm g Main.nat
suc = \ t, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
   suc (t tm var lam app tt pair fst snd left right split zero suc rec)

rec : {g:_}->{a:_} -> Tm g Main.nat -> Tm g (arr Main.nat (arr a a)) -> Tm g a -> Tm g a
rec = \ t, u, v, tm, var, lam, app, tt, pair, fst, snd, left, right, split, zero, suc, rec =>
     rec (t tm var lam app tt pair fst snd left right split zero suc rec)
         (u tm var lam app tt pair fst snd left right split zero suc rec)
         (v tm var lam app tt pair fst snd left right split zero suc rec)

v0 : {g:_}->{a:_} -> Tm (snoc g a) a
v0 = var vz

v1 : {g:_}->{a:_}->{b:_} -> Tm (snoc (snoc g a) b) a
v1 = var (vs vz)

v2 : {g:_}->{a:_}->{b:_}->{c:_} -> Tm (snoc (snoc (snoc g a) b) c) a
v2 = var (vs (vs vz))

v3 : {g:_}->{a:_}->{b:_}->{c:_}->{d:_} -> Tm (snoc (snoc (snoc (snoc g a) b) c) d) a
v3 = var (vs (vs (vs vz)))

tbool : Ty
tbool = sum top top

ttrue : {g:_} -> Tm g Main.tbool
ttrue = left tt

tfalse : {g:_} -> Tm g Main.tbool
tfalse = right tt

ifthenelse : {g:_}->{a:_} -> Tm g (arr Main.tbool (arr a (arr a a)))
ifthenelse = lam (lam (lam (split v2 (lam v2) (lam v1))))

times4 : {g:_}->{a:_} -> Tm g (arr (arr a a) (arr a a))
times4  = lam (lam (app v1 (app v1 (app v1 (app v1 v0)))))

add : {g:_} -> Tm g (arr Main.nat (arr Main.nat Main.nat))
add = lam (rec v0
       (lam (lam (lam (suc (app v1 v0)))))
       (lam v0))

mul : {g:_} -> Tm g (arr Main.nat (arr Main.nat Main.nat))
mul = lam (rec v0
       (lam (lam (lam (app (app add (app v1 v0)) v0))))
       (lam zero))

fact : {g:_} -> Tm g (arr Main.nat Main.nat)
fact = lam (rec v0 (lam (lam (app (app mul (suc v1)) v0)))
                 (suc zero))


module Stochastic

import Simple
import Effects
import Effect.Random

%default total

data Rule : Type -> Type where
  MkRule : a -> List (Int, List a) -> Rule a

data StochasticLSystem : Type -> Type where
  MkStoch : List a -> List (Rule a) -> StochasticLSystem a

makeGenerator : Eq a => List (Rule a) -> Eff (a -> List a) [RND]
makeGenerator _ = pure $ \x => [x]
--todo: finish

translate : Eq a => StochasticLSystem a -> Eff (LSys a) [RND]
translate (MkStoch axiom rules) = do
  generator <- makeGenerator rules
  pure $ MkLSys axiom generator


module Control.Lens.Lens

import Control.Lens.Types
import Data.Curried
import Data.Yoneda
import Data.Morphisms

public export
lens : (s -> a) -> (s -> b -> t) -> {f : Type -> Type}
    -> Functor f => Morphism a (f b) -> Morphism s (f t)
lens sa sbt (Mor afb) = Mor (\s => sbt s <$> afb (sa s))

-- | Fuse a composition of lenses using 'Yoneda' to provide 'map' fusion.
--
-- In general, given a pair of lenses 'foo' and 'bar'
--
-- @
-- fusing (foo.bar) = foo.bar
-- @
--
-- however, @foo@ and @bar@ are either going to 'map' internally or they are trivial.
--
-- 'fusing' exploits the 'Yoneda' lemma to merge these separate uses into a single 'map'.
--
-- This is particularly effective when the choice of functor 'f' is unknown at compile
-- time or when the 'Lens' @foo.bar@ in the above description is recursive or complex
-- enough to prevent inlining.
--
-- @
-- 'fusing' :: 'Lens' s t a b -> 'Lens' s t a b
-- @
public export
fusing : { f : Type -> Type } -> Functor f => LensLike (Yoneda f) s t a b -> LensLike f s t a b
fusing t = \(Mor f) => Mor ( lowerYoneda . ( applyMor . t . Mor ) ( liftYoneda . f ) )

-- | "Fuse" a 'Traversal' by reassociating all of the '\<*\>' operations to the
-- left and fusing all of the 'fmap' calls into one. This is particularly
-- useful when constructing a 'Traversal' using operations from GHC.Generics.
--
-- Given a pair of 'Traversal's 'foo' and 'bar',
--
-- @
-- 'confusing' (foo.bar) = foo.bar
-- @
--
-- However, @foo@ and @bar@ are each going to use the 'Applicative' they are given.
--
-- 'confusing' exploits the 'Yoneda' lemma to merge their separate uses of 'fmap' into a single 'fmap'.
-- and it further exploits an interesting property of the right Kan lift (or 'Curried') to left associate
-- all of the uses of '(<*>)' to make it possible to fuse together more fmaps.
--
-- This is particularly effective when the choice of functor 'f' is unknown at compile
-- time or when the 'Traversal' @foo.bar@ in the above description is recursive or complex
-- enough to prevent inlining.
--
-- 'Control.Lens.Lens.fusing' is a version of this combinator suitable for fusing lenses.
--
-- @
-- 'confusing' :: 'Traversal' s t a b -> 'Traversal' s t a b
-- @
public export
confusing : {0 f : Type -> Type } -> Applicative f => LensLike (Curried (Yoneda f) (Yoneda f)) s t a b -> LensLike f s t a b
confusing t = \(Mor f) => Mor (lowerYoneda . lowerCurried . ( applyMor . t . Mor ) (liftCurriedYoneda . f))
  where

    yap : forall a, b. Yoneda f (a -> b) -> f a -> Yoneda f b
    yap (MkYoneda k) fa = MkYoneda (\ab_r => k (ab_r .) <*> fa)

    liftCurriedYoneda : forall a. Applicative f => f a -> Curried (Yoneda f) (Yoneda f) a
    liftCurriedYoneda fa = MkCurried (flip yap fa)


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

||| Trees with unbounded number of children
module Data.RoseTree

%default total
%access export

||| A RTree.
data RTree : Type -> Type where
  Empty : RTree a
  Node : (value : a) -> (children : List (RTree a)) -> RTree a

contains : Eq a => a -> RTree a -> Bool
contains x Empty       = False
contains x (Node y cs) =
    if x == y
      then True
      else doChildren x cs
  where
    doChildren : Eq a => a -> List (RTree a) -> Bool
    doChildren a Nil     = False
    doChildren a (Empty :: xs)    = doChildren a xs
    doChildren a (Node a' ys::xs) = a == a' || (doChildren a ys || doChildren a xs )

data HasValue : RTree a -> a -> Type where
  DoesHaveValue : HasValue (Node p cs) n

private
noValueEmpty : HasValue (Empty) x -> Void
noValueEmpty DoesHaveValue impossible

||| Insert into a Rose RTree
|||
||| //TODO Make total
partial
insert : Eq a => (value : a) -> (parent : Maybe a) -> (tree : RTree a) -> RTree a
insert x Nothing  (Empty)      = Node x Nil
insert x Nothing  (Node y xs)  = Node y (Node x Nil:: xs)
insert x (Just p) (Empty)      = Node p [Node x Nil]
insert x (Just p) (Node y cs)  =
    if p == y
      then Node y (Node x Nil :: cs)
      else Node y $ map (\y => insert x (Just p) y) cs


module Main

import Data.Vect
import Data.Fin

import Lightyear
import Lightyear.Char
import Lightyear.Strings

test : Show a => Parser a -> String -> IO ()
test p input = case parse p input of
  Left  e => putStrLn e
  Right x => printLn x

listOf : Parser a -> Parser (List a)
listOf p = string "[" *!> (p `sepBy` string ",") <* string "]"

listOf' : Parser a -> Parser (List a)
listOf' p = brackets (commaSep p)

nat : Parser Nat
nat = integer

main : IO ()
main = do
  test nat "123"
  test (listOf nat) "[1,2,3,99]"
  test (listOf nat) "foo"
  test (listOf nat <|> (string "[foo" *> pure List.Nil)) "[foo"  -- should commit and fail
  test (listOf $ listOf nat) "[[1,2],[],[3,4,5]]"

  test (listOf' nat) "[1,2,3,99]"
  test (listOf' $ listOf' nat) "[[1,2],[],[3,4,5]]"
  test (listOf' nat <|> (string "[foo" *> pure List.Nil)) "[foo"  -- should commit and fail


||| Date difference
|||
||| Copyright 2021. HIROKI, Hattori
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Time.Calendar.CalendarDiffDays

import Generics.Derive

%default total
%language ElabReflection

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

public export
record CalendarDiffDays where
  constructor MkCalendarDiffDays
  month : Integer
  day : Integer

%runElab derive "CalendarDiffDays" [Generic, Meta, Eq, DecEq]

public export
Show CalendarDiffDays where
  show x = "P" ++ show x.month ++ "M" ++ show x.day ++ "D"

public export
Semigroup CalendarDiffDays where
  x <+> y = MkCalendarDiffDays (x.month + y.month) (x.day + y.day)

public export
Monoid CalendarDiffDays where
  neutral = MkCalendarDiffDays 0 0

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

export calendarDay : CalendarDiffDays
calendarDay = MkCalendarDiffDays 0 1

export calendarWeek : CalendarDiffDays
calendarWeek = MkCalendarDiffDays 0 7

export calendarMonth : CalendarDiffDays
calendarMonth = MkCalendarDiffDays 1 0

export calendarYear : CalendarDiffDays
calendarYear = MkCalendarDiffDays 12 0

||| Scale by a factor. Note that @scaleCalendarDiffDays (-1)@ will not perfectly invert a duration, due to variable month lengths.
scaleCalendarDiffDays : Integer -> CalendarDiffDays -> CalendarDiffDays
scaleCalendarDiffDays k (MkCalendarDiffDays m d) =
  MkCalendarDiffDays (k * m) (k * d)

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


module Prelude.Basics

import Builtin

import Prelude.Ops

%default total

public export
Not : Type -> Type
Not x = x -> Void

-----------------------
-- UTILITY FUNCTIONS --
-----------------------

||| Manually assign a type to an expression.
||| @ a the type to assign
||| @ x the element to get the type
public export %inline
the : (0 a : Type) -> (x : a) -> a
the _ x = x

||| Identity function.
public export %inline
id : (x : a) -> a
id x = x

||| Function that duplicates its input
public export
dup : a -> (a, a)
dup x = (x, x)

||| Constant function.  Ignores its second argument.
public export %inline
const : a -> b -> a
const x = \value => x

||| Function composition.
public export %inline
(.) : (b -> c) -> (a -> b) -> a -> c
(.) f g = \x => f (g x)

||| Composition of a two-argument function with a single-argument one.
||| `(.:)` is like `(.)` but the second argument and the result are two-argument functions.
||| This operator is also known as "blackbird operator".
public export %inline
(.:) : (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)

||| `on b u x y` runs the binary function b on the results of applying
||| unary function u to two arguments x and y. From the opposite perspective,
||| it transforms two inputs and combines the outputs.
|||
||| ```idris example
||| ((+) `on` f) x y = f x + f y
||| ```
|||
||| Typical usage:
|||
||| ```idris example
||| sortBy (compare `on` fst).
||| ```
public export
on : (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g = \x, y => g x `f` g y

infixl 0 `on`

||| Takes in the first two arguments in reverse order.
||| @ f the function to flip
public export
flip : (f : a -> b -> c) -> b -> a -> c
flip f x y = f y x

||| Function application.
public export
apply : (a -> b) -> a -> b
apply f a = f a

public export
curry : ((a, b) -> c) -> a -> b -> c
curry f a b = f (a, b)

public export
uncurry : (a -> b -> c) -> (a, b) -> c
uncurry f (a, b) = f a b

-- $ is compiled specially to shortcut any tricky unification issues, but if
-- it did have a type this is what it would be, and it might be useful to
-- use directly sometimes (e.g. in higher order functions)
public export
($) : forall a, b . ((x : a) -> b x) -> (x : a) -> b x
($) f a = f a

-------------------
-- PROOF HELPERS --
-------------------

||| Equality is a congruence.
public export
cong : (0 f : t -> u) -> (p : a = b) -> f a = f b
cong f Refl = Refl

||| Two-holed congruence.
export
-- These are natural in equational reasoning.
cong2 : (0 f : t1 -> t2 -> u) -> (p1 : a = b) -> (p2 : c = d) -> f a c = f b d
cong2 f Refl Refl = Refl

||| Irrelevant equalities can always be made relevant
export
irrelevantEq : (0 _ : a === b) -> a === b
irrelevantEq Refl = Refl

--------------
-- BOOLEANS --
--------------

||| Boolean Data Type.
public export
data Bool = False | True

||| Boolean NOT.
%inline
public export
not : (b : Bool) -> Bool
not True = False
not False = True

||| Boolean AND only evaluates the second argument if the first is `True`.
%inline
public export
(&&) : (b : Bool) -> Lazy Bool -> Bool
(&&) True x = x
(&&) False x = False

||| Boolean OR only evaluates the second argument if the first is `False`.
%inline
public export
(||) : (b : Bool) -> Lazy Bool -> Bool
(||) True x = True
(||) False x = x

||| Non-dependent if-then-else
%inline
public export
ifThenElse : (b : Bool) -> Lazy a -> Lazy a -> a
ifThenElse True l r = l
ifThenElse False l r = r

%inline
public export
intToBool : Int -> Bool
intToBool 0 = False
intToBool x = True

--------------
-- LISTS    --
--------------

||| Generic lists.
public export
data List a =
  ||| Empty list
  Nil

  | ||| A non-empty list, consisting of a head element and the rest of the list.
  (::) a (List a)

%name List xs, ys, zs

||| Snoc lists.
public export
data SnocList a =
  ||| Empty snoc-list
  Lin

  | ||| A non-empty snoc-list, consisting of the rest of the snoc-list and the final element.
  (:<) (SnocList a) a

%name SnocList sx, sy, sz


module TaintExample

import Data.Tainted

data Expr =
  Number (Tainted Int)
  | Add Expr Expr

instance Show Expr where
  show (Number x) = "Number (" ++ show x ++ ")"
  show (Add e1 e2) = "Add " ++ show e1 ++ " " ++ show e2

pure1 : Expr
pure1 = Number (Clean 3)

pure2 : Expr
pure2 = Number (Clean 7)

impure1 : Expr
impure1 = Number (Dirty 5)

expr1 : Expr
expr1 = Add pure1 pure2

expr2 : Expr
expr2 = Add impure1 pure1

expr3 : Expr
expr3 = Add pure1 (Add impure1 pure2)

--Evaluate expression as much as Possible
evalExpr : Expr -> Expr
evalExpr (Number n) = Number n
evalExpr (Add e1 e2) =
    case (evalExpr e1, evalExpr e2) of
            (Number i, Number j) => Number $ liftA2 (+) i j
            (x, y) => Add x y

reducedExpr1 : Expr
reducedExpr1 = evalExpr expr1

reducedExpr2 : Expr
reducedExpr2 = evalExpr expr2

reducedExpr3 : Expr
reducedExpr3 = evalExpr expr3


module Data.AOC19.Day05

import Data.Fin
import Data.Vect
import Effects

total
slice : (i, n : Nat) -> Vect (i + (n + m)) a -> Vect n a
slice i n = take n . drop i

namespace IntCode
  data State : Type where
    Running : {n : Nat} -> (ptr : Fin n) -> (state : Vect n Int) -> State
    NotRunning : State

  data ParameterMode
    = PositionMode
    | ImmediateMode

  data OpCode
    = ADD
    | MUL
    | SET
    | PRN
    | END

  data Program : State -> Type where
    Halted : Program NotRunning
    MkP : (ptr : Fin n) -> (state : Vect n Int) -> Program (Running ptr state)

  data Instruction : Effect where
    Add : sig Instruction (Vect (S (S (S (S k)))) Int)
              (Program (Running ptr state))
              (\state' => Program (Running (shift 4 ptr) state'))

  Handler Instruction m where
    handle (MkP (ptr state {n=S (S (S (S j)))}) Add k =
      let dst = Vect.index (shift 3 ptr) state in
      ?rhs_1

-- program :: Parser (Vector Int)
-- program = fromList . map fromInteger <$> (natural `sepBy` comma)

-- runProgram :: Vector Int -> Vector Int
-- runProgram = go 0
--   where
--     go n state
--       | state ! n == 99 = state
--       | otherwise       = go (n + 4) $ step (toList (V.slice n 4 state))
--       where
--         step [1, x, y, dst] = modify (runOp (+) x y dst) state
--         step [2, x, y, dst] = modify (runOp (*) x y dst) state
--         step _              = state

--     runOp f x y dst v = write v dst =<< f <$> MV.read v x <*> MV.read v y

-- example1 :: Vector Int
-- example1 =
--     case parseString program mempty "1,9,10,3,2,3,11,0,99,30,40,50" of
--       Success prog   -> prog
--       Failure reason -> error (show reason)


module Hoare

import Assn
import Expr
import Imp
import Logic
import Maps

%access public export

%default total

HoareTriple : (p : Assertion) -> (c : Com) -> (q : Assertion) -> Type
HoareTriple p c q = (st, st' : State) -> (c / st \\ st') -> p st -> q st'

hoare_post_true : ((st : State) -> q st) -> HoareTriple p c q
hoare_post_true f _ st' _ _ = f st'

hoare_pre_false : ((st : State) -> Not (p st)) -> HoareTriple p c q
hoare_pre_false f = \st, st', rel, p_st => absurd $ f st p_st

hoare_assign : (q : Assertion) -> HoareTriple (AssignSub x a q) (x ::= a) q
hoare_assign q = \st, _, (E_Ass prf), q_st => rewrite sym prf in q_st

assn_sub_example : HoareTriple (AssignSub X (X + 1) (\st => LT (st X) 5))
                               (X ::= X + 1)
                               (\st => LT (st X) 5)
assn_sub_example = hoare_assign (\st => LT (st X) 5)

hoare_assign_fwd : (m : Nat) -> (a : AExp) -> (p : Assertion) ->
                   HoareTriple (\st => (p st, st X = m))
                               (X ::= a)
                               (\st => ( p (t_update X m st)
                                       , st X = aeval (t_update X m st) a ))
hoare_assign_fwd m a p st _ (E_Ass {n} prf1) (p_st, prf2) =
  rewrite sym prf2
  in rewrite trans (t_update_shadow {x=X} {v2=st X} {v1=n} {m=st})
                   (t_update_same {x=X} {m=st})
  in (p_st, sym prf1)

hoare_assign_fwd_exists : (a : AExp) -> (p : Assertion) ->
                          HoareTriple
                            (\st => p st)
                            (X ::= a)
                            (\st => (m ** ( p (t_update X m st)
                                          , st X = aeval (t_update X m st) a )))
hoare_assign_fwd_exists a p st st' rel p_st with (st X) proof prf2
  hoare_assign_fwd_exists a p st st' rel p_st | m =
    (m ** hoare_assign_fwd m a p st st' rel (p_st, sym prf2))

hoare_consequence_pre : (p, p', q : Assertion) -> HoareTriple p' c q ->
                        (p ->> p') -> HoareTriple p c q
hoare_consequence_pre p p' q ht imp = \st, st', rel, p_st =>
  ht st st' rel (imp st p_st)

hoare_consequence_post : (p, q, q' : Assertion) -> HoareTriple p c q' ->
                         (q' ->> q) -> HoareTriple p c q
hoare_consequence_post p q q' ht imp = \st, st', rel, p_st =>
  imp st' (ht st st' rel p_st)

hoare_assign_example_1 : HoareTriple (const ()) (X ::= 1) (\st => st X = 1)
hoare_assign_example_1 =
  hoare_consequence_post (const ())
                         (\st => st X = 1)
                         (\st => (m : Nat ** ((), st X = 1)))
                         (hoare_assign_fwd_exists 1 (const ()))
                         (\_, (_ ** (_, prf)) => prf)

hoare_assign_example_2 : HoareTriple (\st => LT (st X) 4)
                                     (X ::= X + 1)
                                     (\st => LT (st X) 5)
hoare_assign_example_2 =
  hoare_consequence_pre (\st => LT (st X) 4)
                        (\st => LT (st X + 1) 5)
                        (\st => LT (st X) 5)
                        (hoare_assign (\st => LT (st X) 5))
                        (\st, p_st => replace {P=\x => LT x 5}
                                              (sym (plusCommutative (st X) 1))
                                              (LTESucc p_st))

hoare_consequence : (p, p', q, q' : Assertion) -> HoareTriple p' c q' ->
                    p ->> p' -> q' ->> q -> HoareTriple p c q
hoare_consequence p p' q q' ht p_imp_p' q'_imp_q =
  let ht' = hoare_consequence_pre p p' q' ht p_imp_p'
  in hoare_consequence_post p q q' ht' q'_imp_q

hoare_assign_example_5 : HoareTriple (\st => LTE (st X + 1) 5)
                                     (X ::= X + 1)
                                     (\st => LTE (st X) 5)
hoare_assign_example_5 = hoare_assign (\st => LTE (st X) 5)

hoare_assign_example_6 : HoareTriple (\st => (LTE 0 3, LTE 3 5))
                                     (X ::= 3)
                                     (\st => (LTE 0 (st X), LTE (st X) 5))
hoare_assign_example_6 = hoare_assign (\st => (LTE 0 (st X), LTE (st X) 5))

hoare_skip : (p : Assertion) -> HoareTriple p SKIP p
hoare_skip _ _ _ E_Skip p_st = p_st

hoare_seq : (p, q, r : Assertion) -> HoareTriple q c2 r -> HoareTriple p c1 q ->
            HoareTriple p (do c1; c2) r
hoare_seq p q r ht2 ht1 = \st, st', (E_Seq {st2} cc1 cc2), p_st =>
  let q_st2 = ht1 st st2 cc1 p_st
  in ht2 st2 st' cc2 q_st2

hoare_assign_example_3 : (a : AExp) -> (n : Nat) ->
                         HoareTriple (\st => aeval st a = n)
                                     (do X ::= a; SKIP)
                                     (\st => st X = n)
hoare_assign_example_3 a n =
  let hta = hoare_assign_fwd_exists a (\st => aeval st a = n)
      hta' = hoare_consequence_post
               (\st => aeval st a = n)
               (\st => st X = n)
               (\st => (m : Nat ** ( aeval (t_update X m st) a = n
                                   , st X = aeval (t_update X m st) a )))
               hta
               (\_, (_ ** (aeval_eq_n, st_X_eq_aeval)) =>
                  trans st_X_eq_aeval aeval_eq_n)
      hts = hoare_skip (\st => st X = n)
  in hoare_seq (\st => aeval st a = n) (\st => st X = n) (\st => st X = n)
               hts hta'

hoare_assign_example_4 : HoareTriple (const ())
                                     (do X ::= 1; Y ::= 2)
                                     (\st => (st X = 1, st Y = 2))
hoare_assign_example_4 =
  let htx = hoare_consequence_post
              (const ())
              (\st => st X = 1)
              (\st => (m : Nat ** ((), st X = 1)))
              (hoare_assign_fwd_exists 1 (const ()))
              (\_, (_ ** (_, q_st)) => q_st)
      hty = hoare_consequence_pre
              (\st => st X = 1)
              (AssignSub Y 2 (\st => (st X = 1, st Y = 2)))
              (\st => (st X = 1, st Y = 2))
              (hoare_assign (\st => (st X = 1, st Y = 2)))
              (\_, p_st => (p_st, Refl))
  in hoare_seq (const ()) (\st => st X = 1) (\st => (st X = 1, st Y = 2))
               hty htx

swap_program : Com
swap_program = do Z ::= X
                  X ::= Y
                  Y ::= Z

swap_exercise : HoareTriple (\st => LTE (st X) (st Y))
                            Hoare.swap_program
                            (\st => LTE (st Y) (st X))
swap_exercise =
  let htz = hoare_consequence_pre
              (\st => LTE (st X) (st Y))
              (AssignSub Z X (\st => LTE (st Z) (st Y)))
              (\st => LTE (st Z) (st Y))
              (hoare_assign (\st => LTE (st Z) (st Y)))
              (\_, p_st => p_st)
      htx = hoare_consequence_pre (\st => LTE (st Z) (st Y))
                                  (AssignSub X Y (\st => LTE (st Z) (st X)))
                                  (\st => LTE (st Z) (st X))
                                  (hoare_assign (\st => LTE (st Z) (st X)))
                                  (\_, p_st => p_st)
      hty = hoare_consequence_pre (\st => LTE (st Z) (st X))
                                  (AssignSub Y Z (\st => LTE (st Y) (st X)))
                                  (\st => LTE (st Y) (st X))
                                  (hoare_assign (\st => LTE (st Y) (st X)))
                                  (\_, p_st => p_st)
      htxy = hoare_seq (\st => LTE (st Z) (st Y))
                       (\st => LTE (st Z) (st X))
                       (\st => LTE (st Y) (st X))
                       hty
                       htx
  in hoare_seq (\st => LTE (st X) (st Y))
               (\st => LTE (st Z) (st Y))
               (\st => LTE (st Y) (st X))
               htxy
               htz

hoare_if : (p, q : Assertion) ->
           HoareTriple (\st => (p st, BAssn b st)) c1 q ->
           HoareTriple (\st => (p st, Not (BAssn b st))) c2 q ->
           HoareTriple p (CIf b c1 c2) q
hoare_if p q ht1 ht2 = \st, st', rel, p_st => case rel of
  E_IfTrue prf cc1 => ht1 st st' cc1 (p_st, prf)
  E_IfFalse prf cc2 => ht2 st st' cc2 (p_st, bexp_eval_false prf)

if_example : HoareTriple (const ())
                         (CIf (X == 0) (Y ::= 2) (Y ::= X + 1))
                         (\st => LTE (st X) (st Y))
if_example =
  let htt = hoare_consequence
              (\st => ((), BAssn (X == 0) st))
              (AssignSub Y 2 (\st => (LTE (st X) (st Y), BAssn (X == 0) st)))
              (\st => LTE (st X) (st Y))
              (\st => (LTE (st X) (st Y), BAssn (X == 0) st))
              (hoare_assign (\st => (LTE (st X) (st Y), BAssn (X == 0) st)))
              (\st, (_, p_st) => ( replace {P=\x => LTE x 2}
                                           (sym (fst (nat_beq_iff (st X) 0)
                                                p_st))
                                           LTEZero
                                 , p_st ))
              (\_, (q_st, _) => q_st)
      htf = hoare_consequence
              (\st => ((), Not (BAssn (X == 0) st)))
              (AssignSub Y (X + 1) (\st => ( LTE (st X) (st Y)
                                           , Not (BAssn (X == 0) st) )))
              (\st => LTE (st X) (st Y))
              (\st => (LTE (st X) (st Y), Not (BAssn (X == 0) st)))
              (hoare_assign (\st => ( LTE (st X) (st Y)
                                      , Not (BAssn (X == 0) st) )))
              (\st, (_, p_st) => (lteAddRight (st X), p_st))
              (\_, (q_st, _) => q_st)
  in hoare_if (const ()) (\st => LTE (st X) (st Y)) htt htf

if_minus_plus : HoareTriple (const ())
                            (CIf (X <= Y) (Z ::= Y - X) (Y ::= X + Z))
                            (\st => st Y = st X + st Z)
if_minus_plus =
  let htt = hoare_consequence
              (\st => ((), BAssn (X <= Y) st))
              (AssignSub Z (Y - X) (\st => ( st Y = st X + st Z
                                           , BAssn (X <= Y) st )))
              (\st => st Y = st X + st Z)
              (\st => (st Y = st X + st Z, BAssn (X <= Y) st))
              (hoare_assign (\st => (st Y = st X + st Z, BAssn (X <= Y) st)))
              (\st, (_, p_st) =>
                 ( sym (lte_plus_minus (fst (lte_beq_iff (st X) (st Y)) p_st))
                 , p_st ))
              (\_, (q_st, _) => q_st)
      htf = hoare_consequence_pre
              (\st => ((), Not (BAssn (X <= Y) st)))
              (AssignSub Y (X + Z) (\st => st Y = st X + st Z))
              (\st => st Y = st X + st Z)
              (hoare_assign (\st => st Y = st X + st Z))
              (\_, _ => Refl)
  in hoare_if (const ()) (\st => st Y = st X + st Z) htt htf

hoare_while : {b : BExp} -> {c : Com} -> (p : Assertion) ->
              HoareTriple (\st => (p st, BAssn b st)) c p ->
              HoareTriple p (WHILE b c) (\st => (p st, Not (BAssn b st)))
hoare_while {b} {c} p ht st _ (E_WhileEnd prf) p_st =
  (p_st, snd not_true_iff_false prf)
hoare_while {b} {c} p ht st st' (E_WhileLoop {st1} prf cbody cnext) p_st =
  hoare_while p ht st1 st' cnext (ht st st1 cbody (p_st, prf))

while_example : HoareTriple (\st => LTE (st X) 3)
                            (CWhile (X <= 2) (X ::= X + 1))
                            (\st => st X = 3)
while_example st st' rel lte_prf =
  let htc =  hoare_assign (\st => LTE (st X) 3)
      htc' = hoare_consequence_pre
               (\st => (LTE (st X) 3, beval st (X <= 2) = True))
               (\st => LTE (st X + 1) 3)
               (\st => LTE (st X) 3)
               htc
               (\st, p_st => replace {P=\x => LTE x 3}
                                     (sym (plusCommutative (st X) 1))
                                     (LTESucc (fst (lte_beq_iff (st X) 2)
                                                   (snd p_st))))
      htw = hoare_while (\st => LTE (st X) 3) htc'
      (below, contra) = htw st st' rel lte_prf
  in bounded__eq below (fst (lte_nbeq_iff (st' X) 2)
                            (fst not_true_iff_false contra))

always_loop_hoare : (p, q : Assertion) -> HoareTriple p (WHILE BTrue SKIP) q
always_loop_hoare p q =
  let htc = hoare_consequence_pre
              (\st => (p st, BAssn BTrue st))
              p
              p
              (hoare_skip p)
              (\st, (p_st, _) => p_st)
      htw = hoare_while p htc
  in hoare_consequence_post
           p
           q
           (\st => (p st, Not (BAssn BTrue st)))
           htw
           (\st, (_, contra) => absurd (contra Refl))

hoare_if1 : {b : BExp} -> {c : Com} -> (p, q : Assertion) ->
            HoareTriple (\st => (p st, BAssn b st)) c q ->
            (\st => (p st, Not (BAssn b st))) ->> q ->
            HoareTriple p (CIf1 b c) q
hoare_if1 {b} {c} p q htc _ st st' (E_If1True prf cc) p_st =
  htc st st' cc (p_st, prf)
hoare_if1 {b} {c} p q _ imp st _ (E_If1False prf) p_st =
  imp st (p_st, snd not_true_iff_false prf)

hoare_if1_good : HoareTriple (\st => st X + st Y = st Z)
                             (IF1 not (Y == 0) THEN
                                  X ::= X + Y
                              FI)
                             (\st => st X = st Z)
hoare_if1_good =
  let htc = hoare_consequence
              (\st => (st X + st Y = st Z, not (st Y == 0) = True))
              (AssignSub X (X + Y)
                         (\st => (st X = st Z, not (st Y == 0) = True)))
              (\st => st X = st Z)
              (\st => (st X = st Z, not (st Y == 0) = True))
              (hoare_assign (\st => (st X = st Z, not (st Y == 0) = True)))
              (\_, p_st => p_st)
              (\st, (q_st, _) => q_st)
      hts = hoare_consequence
              (\st => (st X + st Y = st Z, Not (not (st Y == 0) = True)))
              (\st => (st X = st Z, Not (not (st Y == 0) = True)))
              (\st => st X = st Z)
              (\st => (st X = st Z, Not (not (st Y == 0) = True)))
              (hoare_skip (\st => (st X = st Z, Not (not (st Y == 0) = True))))
              (\st, (plus_st_X_st_Y__st_Z, prf) =>
                  let st_Y_eq_0 = fst (nat_beq_iff (st Y) 0)
                                      (trans (sym (notInvolutive (st Y == 0)))
                                             (cong {f=not}
                                                   (fst not_true_iff_false prf)))
                      pf = trans (sym (plusZeroRightNeutral (st X)))
                                 (replace {P=\x => st X + x = st Z}
                                          st_Y_eq_0 plus_st_X_st_Y__st_Z)
                  in (pf, prf))
              (\st, (q_st, _) => q_st)
      imp = \st, (plus_st_X_st_Y__st_Z, prf) =>
        let st_Y_eq_0 = fst (nat_beq_iff (st Y) 0)
                            (trans (sym (notInvolutive (st Y == 0)))
                                   (cong {f=not} (fst not_true_iff_false prf)))
        in trans (sym (plusZeroRightNeutral (st X)))
                 (replace {P=\x => st X + x = st Z}
                          st_Y_eq_0 plus_st_X_st_Y__st_Z)
  in hoare_if1 (\st => st X + st Y = st Z) (\st => st X = st Z) htc imp

hoare_for : {init, updt, body : Com} -> {cond : BExp} -> (p, q : Assertion) ->
            HoareTriple p init q ->
            HoareTriple (\st => (q st, BAssn cond st)) (do body; updt) q ->
            HoareTriple p
                        (CFor init cond updt body)
                        (\st => (q st, Not (BAssn cond st)))
hoare_for {init} {updt} {body} {cond} p q ht_init ht_body_updt st st'
          (E_For ci (E_WhileEnd prf)) p_st =
  (ht_init st st' ci p_st, bexp_eval_false prf)
hoare_for {init} {updt} {body} {cond} p q ht_init ht_body_updt st st'
          (E_For ci {st2} (E_WhileLoop {st1} prf cb cn)) p_st =
  let q_st2 = ht_init st st2 ci p_st
      q_st1 = ht_body_updt st2 st1 cb (q_st2, prf)
  in hoare_while q ht_body_updt st1 st' cn q_st1

hoare_repeat : {c : Com} -> {b : BExp} -> (p, q : Assertion) ->
               HoareTriple p c q -> (\st => (q st, Not (BAssn b st))) ->> p ->
               HoareTriple p (CRepeat c b) (\st => (q st, BAssn b st))
hoare_repeat {c} {b} p q htc imp st st' (E_Repeat cc (E_WhileEnd prf)) p_st =
  let q_st' = htc st st' cc p_st
      btrue = trans (sym (notInvolutive (beval st' b))) (cong {f=not} prf)
  in (q_st', btrue)
hoare_repeat {c} {b} p q htc imp st st'
             r@(E_Repeat {st1} cc1 (E_WhileLoop prf cc2 cnext)) p_st =
  let q_st1 = htc st st1 cc1 p_st
      bfalse = bexp_eval_false (trans (sym (notInvolutive (beval st1 b)))
                                      (cong {f=not} prf))
      p_st1 = imp st1 (q_st1, bfalse)
  in hoare_repeat p q htc imp st1 st'
                  (assert_smaller r (E_Repeat cc2 cnext)) p_st1

hoare_repeat_good : HoareTriple (\st => LT 0 (st X))
                                (REPEAT do
                                   Y ::= X
                                   X ::= X - 1
                                 UNTIL X == 0 END)
                                (\st => (st X = 0, LT 0 (st Y)))
hoare_repeat_good =
  let hty = hoare_assign (\st => LT 0 (st Y))
      htx = hoare_assign (\st => LT 0 (st Y))
      htc = hoare_seq (\st => LT 0 (st X))
                      (\st => LT 0 (st Y))
                      (\st => LT 0 (st Y))
                      htx
                      hty
      ht_repeat = hoare_repeat
                    (\st => LT 0 (st X))
                    (\st => LT 0 (st Y))
                    htc
                    (\st, (_, prf) =>
                        notZeroImpliesGTZero
                          (fst (nat_nbeq_iff (st X) 0)
                          (fst not_true_iff_false prf)))
  in hoare_consequence_post (\st => LT 0 (st X))
                            (\st => (st X = 0, LT 0 (st Y)))
                            (\st => (LT 0 (st Y), BAssn (X == 0) st))
                            ht_repeat
                            (\st, (lte_prf, prf) =>
                              let pf = fst (nat_beq_iff (st X) 0) prf
                              in (pf, lte_prf))


module Toolkit.Data.DList.Interleaving

import public Toolkit.Data.List.Interleaving

import Toolkit.Data.DList

%default total

public export
data Interleaving : (a : Type)
                 -> (type : a -> Type)
                 -> {ls, rs, os : List a}
                 -> (lefts  : DList a type ls)
                 -> (rights : DList a type rs)
                 -> (orig   : DList a type os)
                 -> (prf    : Interleaving ls rs os)
                           -> Type
  where
    Empty : Interleaving a type Nil Nil Nil Empty

    Left  : {a : Type}
         -> {type : a -> Type}
         -> {x : a}
         -> {xs, ys, zs : List a}
         -> {ls   : DList a type xs}
         -> {rs   : DList a type ys}
         -> {os   : DList a type zs}
         -> {prf  : Interleaving xs ys zs}
         -> (head : type x)
         -> (tail : Interleaving a type        ls  rs        os         prf)
                 -> Interleaving a type (head::ls) rs (head::os) (x <:: prf)

    Right : {a : Type}
         -> {type : a -> Type}
         -> {y : a}
         -> {xs, ys, zs : List a}
         -> {ls   : DList a type xs}
         -> {rs   : DList a type ys}
         -> {os   : DList a type zs}
         -> {prf  : Interleaving xs ys zs}
         -> (head : type y)
         -> (tail : Interleaving a type ls        rs         os         prf)
                 -> Interleaving a type ls (head::rs) (head::os) (y ::> prf)

(<::) : {a : Type}
     -> {type : a -> Type}
     -> {x    : a}
     -> {xs, ys, zs : List a}
     -> {ls   : DList a type xs}
     -> {rs   : DList a type ys}
     -> {os   : DList a type zs}
     -> {prf  : Interleaving xs ys zs}
     -> (head : type x)
     -> (tail : Interleaving a type        ls  rs        os         prf)
             -> Interleaving a type (head::ls) rs (head::os) (x <:: prf)
(<::) = Left

(::>) : {a : Type}
     -> {type : a -> Type}
     -> {xs, ys, zs : List a}
     -> {ls   : DList a type xs}
     -> {rs   : DList a type ys}
     -> {os   : DList a type zs}
     -> {prf  : Interleaving xs ys zs}
     -> {y    : a}
     -> (head : type y)
     -> (tail : Interleaving a type ls        rs         os         prf)
             -> Interleaving a type ls (head::rs) (head::os) (y ::> prf)
(::>) = Right


module Control.Comonad.Traced.Traced

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

%default total

public export
record TracedT (m : Type) (w : Type -> Type) (a : Type) where
  constructor MkTracedT
  runTracedT : w (m -> a)

public export
Traced : (m : Type) -> (a : Type) -> Type
Traced m = TracedT m Identity

public export %inline
traced : (m -> a) -> Traced m a
traced f = MkTracedT (Id f)

public export %inline
runTraced : Traced m a -> m -> a
runTraced (MkTracedT (Id f)) = f

--------------------------------------------------------------------------------
--          Utilities
--------------------------------------------------------------------------------

public export %inline
listen : Functor w => TracedT m w a -> TracedT m w (a, m)
listen = record { runTracedT $= map (\f,m => (f m, m)) }

public export %inline
listens : Functor w => (m -> b) -> TracedT m w a -> TracedT m w (a, b)
listens g = record { runTracedT $= map (\f,m => (f m, g m)) }

public export %inline
censor : Functor w => (m -> m) -> TracedT m w a -> TracedT m w a
censor g = record { runTracedT $= map (. g) }

--------------------------------------------------------------------------------
--          Interface Implementations
--------------------------------------------------------------------------------

appEnv : (s -> a -> b) -> (s -> a) -> s -> b
appEnv ff fa s = ff s (fa s)

public export %inline
Functor w => Functor (TracedT m w) where
  map f = record { runTracedT $= map (f .) }

public export %inline
Applicative w => Applicative (TracedT m w) where
  pure = MkTracedT . pure . const
  MkTracedT wf <*> MkTracedT wa = MkTracedT (map appEnv wf <*> wa)

public export %inline
(Comonad w, Monoid m) => Comonad (TracedT m w) where
  extract (MkTracedT wf) = extract wf neutral
  extend f =
    record { runTracedT $= extend (\w,m => f (MkTracedT $ map (. (<+> m)) w)) }

public export %inline
(ComonadApply w, Monoid m) => ComonadApply (TracedT m w) where
  MkTracedT wf <@> MkTracedT wa = MkTracedT (map appEnv wf <@> wa)

public export %inline
Monoid m => ComonadTrans (TracedT m) where
  lower = map ($ neutral) . runTracedT


namespace Hoo

  f : Either a b -> Either b a
  f (Left a) = Right a
  f (Right b) = Left b

  natural : (xs : Either a b) -> ((f . f) . map g) xs === (map g . (f . f)) xs
  natural = ?l

mutual

  g : h === h
  g = Refl

  h : g === g
  h = Refl


twice : Char -> Char -> Char -> Char -> Nat -> (Nat, Nat)
twice w x y z Z = (Z, Z)
twice m n o p (S x)
    = case twice m n o p x of
           (a, b) => (S a, S b)

bothS : Int -> String -> (Nat, Nat) -> (Nat, Nat)
bothS test dummy = \(c, d) => (S c, S d)

pf : (x : Nat) -> twice 'a' 'b' 'c' 'd' (S x)
                     = bothS 99 "red balloons" (twice 'a' 'b' 'c' 'd' x)
pf k = Refl -- Refl


import System.Concurrency.Channels

data Message = Add Nat Nat

adder : IO ()
adder = do Just sender_chan <- listen 1
              | Nothing => adder
           Just msg <- unsafeRecv Message sender_chan
              | Nothing => adder
           case msg of
                Add x y => do ok <- unsafeSend sender_chan (x + y)
                              adder

main : IO ()
main = do Just adder_id <- spawn adder
               | Nothing => putStrLn "Spawn failed"
          Just chan <- connect adder_id
               | Nothing => putStrLn "Connection failed"
          ok <- unsafeSend chan (Add 2 3)
          Just answer <- unsafeRecv String chan
               | Nothing => putStrLn "Send failed"
          printLn answer


||| Reasoning about elements in a DList based on their index.
|||
||| Module    : DList/AtIndex.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
module Toolkit.Data.DList.AtIndex

import Decidable.Equality

import Toolkit.Decidable.Informative

import Toolkit.Data.List.AtIndex
import Toolkit.Data.DList

%default total

||| Proof that some element satisfies the predicate
|||
||| @idx   The type of the element's index.
||| @type  The type of the list element.
||| @p     A predicate
||| @xs      The list itself.
public export
data HoldsAtIndex : (type   : Type)
                 -> (item   : type -> Type)
                 -> (p      : {i : type} -> (x : item i) -> Type)
                 -> {is     : List type}
                 -> (xs     : DList type item is)
                 -> (idx    : Nat)
                           -> Type
    where
      ||| Proof that the element is at the front of the list.
      Here : {p   : {i : type} -> (x : item i) -> Type}
          -> {i   : type}
          -> {x   : item i}
          -> (prf : p x)
                 -> HoldsAtIndex type item p (x::xs) Z

      ||| Proof that the element is found later in the list.
      There : {p      : {i : type} -> (x : item i) -> Type}
           -> (contra : p x' -> Void)
           -> (later  : HoldsAtIndex type item p      xs     loc)
                     -> HoldsAtIndex type item p (x'::xs) (S loc)

namespace Find
  namespace HoldsAtIndex
    public export
    data Error type = IsEmpty
                    | Later type (HoldsAtIndex.Error type)

  isEmpty : {p  : {i : type} -> (x : item i) -> Type}
         -> DPair Nat (HoldsAtIndex type item p [])
         -> Void
  isEmpty (MkDPair loc prf) with (prf)
    isEmpty (MkDPair loc prf) | (MkDPair _ (Here _)) impossible
    isEmpty (MkDPair loc prf) | (MkDPair _ (There _)) impossible

  notLater : {p : {i : type} -> (x : item i) -> Type}
          -> (DPair Nat (HoldsAtIndex type item p rest) -> Void)
          -> (p i -> Void)
          -> DPair Nat (HoldsAtIndex type item p (i :: rest))
          -> Void
  notLater f g (MkDPair _ (Here prf))
    = g prf
  notLater f g (MkDPair _ (There contra later))
    = f (MkDPair _ later)

  export
  holdsAtIndex : {p  : {i : type} -> (x : item i) -> Type}
              -> (f  : {i : type} -> (x : item i) -> DecInfo err (p x))
              -> (xs : DList type item is)
                    -> DecInfo (HoldsAtIndex.Error err)
                               (DPair Nat (HoldsAtIndex type item p xs))
  holdsAtIndex f Nil
    = No IsEmpty (isEmpty)

  holdsAtIndex f (x :: y) with (f x)
    holdsAtIndex f (x :: y) | (Yes prf)
      = Yes (MkDPair 0 (Here prf))

    holdsAtIndex f (x :: y) | (No msg contra) with (holdsAtIndex f y)
      holdsAtIndex f (x :: y) | (No msg contra) | (Yes (MkDPair loc prf))
        = Yes (MkDPair (S loc) (There contra prf))

      holdsAtIndex f (x :: y) | (No msg contra) | (No msgR contraR)
        = No (Later msg msgR)
             (notLater contraR contra)

-- [ EOF ]


module Main

import Average

toLine : String -> String
toLine = (++ "\n")

main : IO ()
main = repl prompt $ toLine . (outputPrefix ++) . show . averageWordLen
        where
            prompt = "Enter a String: "
            outputPrefix = "The average word length is "


eq1 : (x : Nat) -> (x = S x) -> Nat
eq1 x p impossible

eq2 : (x : Nat) -> (S x = Z) -> Nat
eq2 x p impossible

eq3 : (x : Nat) -> (S (S x) = (S x)) -> Nat
eq3 x p impossible

eq4 : (x : Nat) -> (S x = x) -> Nat
eq4 x p impossible

eq5 : (x : Nat) -> (Z = S x) -> Nat
eq5 x p impossible

eq6 : (x : Nat) -> (S x = (S (S x))) -> Nat
eq6 x p impossible

eqL1 : (xs : List a) -> (x :: xs = []) -> Nat
eqL1 xs p impossible

eqL2 : (xs : List a) -> (x :: xs = x :: y :: xs) -> Nat
eqL2 xs p impossible

badeq : (x : Nat) -> (y : Nat) -> (S (S x) = S y) -> Nat
badeq x y p impossible

badeqL : (xs : List a) -> (ys : List a) -> (x :: xs = x :: y :: ys) -> Nat
badeqL xs ys p impossible


module CoverBug

import Data.So

public export
data FastNat : Type where
  MkFastNat : (val : Integer) -> {auto 0 prf : So True} -> FastNat

prv1 : Integer -> (x : Integer ** So $ True)
prv1 x =
  case choose True of
    Left prf => (x ** Oh)
    Right noprf => absurd noprf

fromInteger : Integer -> FastNat
fromInteger v =
  let (v ** p) = prv1 $ v
  in MkFastNat v

doit : FastNat -> FastNat
doit 0 = 0


||| Test if :typeat can report the type of variables in interface definitions
||| and implementations

interface Nattable a where
  toNat : a -> Nat

Nattable Bool where
  -- Create some variables just to test
  toNat True  = let x = 0 in S x
  toNat False = let y = 0 in y


module Data.Union

%default total

||| Proof that a value is present in a list. This is
||| isomorphic to `Data.List.Elem` but with (in my opinion)
||| more fitting names for our use case.
public export
data Has : (v : a) -> (ts : List 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

||| Removes an element from a list. This is used to
||| calculate the list of effects after a single effect
||| was properly handled.
public export
0 (-) : (ts : List a) -> (v : a) -> (prf : Has v ts) => List a
(-) (_ :: vs)      _ {prf = Z}   = vs
(-) (y :: x :: xs) v {prf = S k} = y :: (-) (x :: xs) v

||| A list of effect handlers handling effects of types `fs`
||| wrapping results in type `m`.
public export
data Handler : (fs : List (Type -> Type)) -> (m : Type -> Type) -> Type where
  Nil : Handler [] m
  (::) : (h : forall x . f x -> m x) -> Handler fs m -> Handler (f :: fs) m

||| Sum type holding a value of type `t` wrapped in one of the
||| effect types listed in `fs`.
public export
data Union : (fs : List (Type -> Type)) -> (t : Type) -> Type where
  U : (ix : Has f fs) -> (val : f t) -> Union fs t

public export
Uninhabited (Union [] t) where
  uninhabited (U ix v) = absurd ix

||| Inject an effectful computation into a `Union`.
public export %inline
inj : (prf : Has f fs) => f t -> Union fs t
inj = U prf

||| Tries to extract an effect from a `Union`.
public export
prj : (prf : Has f fs) => Union fs t -> Maybe (f t)
prj {prf = Z}    (U Z v)     = Just v
prj {prf = S ix} (U (S x) v) = prj {prf = ix} (U x v)
prj _                        = Nothing

||| Extracts the last effect from a unary sum.
public export
prj1 : Union [f] t -> f t
prj1 (U Z val) = val
prj1 (U (S x) val) impossible

||| Handles all remaining effects via the given
||| (heterogeneous) list of event handlers.
public export
handleAll : Handler fs m -> Union fs t -> m t
handleAll []       y              = absurd y
handleAll (h :: t) (U Z val)     = h val
handleAll (h :: t) (U (S y) val) = handleAll t (U y val)

||| Prepend a new effect to an existing `Union` value.
export
weaken : Union fs a -> Union (f :: fs) a
weaken (U ix val) = U (S ix) val

||| Handle on of the effects in a `Union`. Unlike in other
||| effect libraries, it's not necessary that the effect
||| is the first in the list. To improve type inference,
||| the return type is calculated from the `prf` value.
public export
decomp :  (prf : Has f fs)
       => Union fs a
       -> Either (Union (fs - f) a) (f a)
decomp {prf = Z}                      (U Z     val) = Right $ val
decomp {prf = Z}                      (U (S x) val) = Left $ U x val
decomp {prf = S y} {fs = f :: h :: t} (U Z val)     = Left $ U Z val
decomp {prf = S y} {fs = f :: h :: t} (U (S x) val) =
  mapFst weaken $ decomp (U x val)

||| Handle one of the effects in a `Union`. Unlike in other
||| effect libraries, it's not necessary that the effect
||| is the first in the list. To improve type inference,
||| the return type is calculated from the `prf` value.
public export
handle :  (prf : Has f fs)
       => (f a -> res)
       -> Union fs a
       -> Either (Union (fs - f) a) res
handle g = map g . decomp


-- --------------------------------------------------------- [ Categorical.idr ]

module Data.ML.Categorical

import public Data.ML.Util

%access export

catToNum : (Num n, Cast Bool n, Ord a) => List a -> List (List n)
catToNum xs = [ cast . (== cat) <$> xs | cat <- unique xs ]

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


module Data.List.Lazy

import Data.Fuel
import Data.Stream
import Data.Colist
import Data.Colist1

%default total

-- All functions here are public export
-- because their definitions are pretty much the specification.

public export
data LazyList : Type -> Type where
  Nil : LazyList a
  (::) : (x : a) -> (xs : Lazy (LazyList a)) -> LazyList a

--- Truly lazy functions ---

public export
foldrLazy : (func : elem -> Lazy acc -> acc) -> (init : Lazy acc) -> (input : LazyList elem) -> acc
foldrLazy _  init [] = init
foldrLazy op init (x::xs) = x `op` foldrLazy op init xs

public export
(++) : LazyList a -> Lazy (LazyList a) -> LazyList a
(++) = flip $ foldrLazy (::)

-- Specialized variant of `concatMap` with both `t` and `m` being `LazyList`.
public export
bindLazy : (a -> LazyList b) -> LazyList a -> LazyList b
bindLazy f = foldrLazy ((++) . f) []

public export
choice : Alternative f => LazyList (f a) -> f a
choice = foldrLazy (<|>) empty

public export
choiceMap : Alternative f => (a -> f b) -> LazyList a -> f b
choiceMap g = foldrLazy ((<|>) . g) empty

public export
any : (a -> Bool) -> LazyList a -> Bool
any p = foldrLazy ((||) . p) False

public export
all : (a -> Bool) -> LazyList a -> Bool
all p = foldrLazy ((&&) . p) True

--- Interface implementations ---

public export
Eq a => Eq (LazyList a) where
  [] == [] = True
  x :: xs == y :: ys = x == y && xs == ys
  _ == _ = False

public export
Ord a => Ord (LazyList a) where
  compare [] [] = EQ
  compare [] (x :: xs) = LT
  compare (x :: xs) [] = GT
  compare (x :: xs) (y :: ys)
     = case compare x y of
            EQ => compare xs ys
            c => c

export
Show a => Show (LazyList a) where
  show []       = "[]"
  show (h :: t) = "[" ++ show' "" h t ++ "]"
    where
      -- Idris didn't like the lazyness involved when using the
      -- same implementation as for `List`, therefore, this was
      -- adjusted to first force the head and tail of the list.
      show' : String -> a -> LazyList a -> String
      show' acc h Nil       = acc ++ show h
      show' acc h (x :: xs) = show' (acc ++ show h ++ ", ") x xs

public export
Semigroup (LazyList a) where
  xs <+> ys = xs ++ ys

public export
Monoid (LazyList a) where
  neutral = []

public export
Foldable LazyList where
  foldr op nil [] = nil
  foldr op nil (x :: xs) = x `op` foldr op nil xs

  foldl op acc [] = acc
  foldl op acc (x :: xs) = foldl op (acc `op` x) xs

  foldlM fm init xs = foldrLazy (\x, k, z => fm z x >>= k) pure xs init

  null []     = True
  null (_::_) = False

  foldMap f [] = neutral
  foldMap f (x :: xs) = f x <+> foldMap f xs

public export
Functor LazyList where
  map f [] = []
  map f (x :: xs) = f x :: map f xs

public export
Applicative LazyList where
  pure x = [x]
  fs <*> vs = bindLazy (\f => map f vs) fs

public export
Alternative LazyList where
  empty = []
  (<|>) = (++)

public export
Monad LazyList where
  m >>= f = bindLazy f m

-- There is no Traversable instance for lazy lists.
-- The result of a traversal will be a non-lazy list in general
-- (you can't delay the "effect" of an applicative functor).
public export
traverse : Applicative f => (a -> f b) -> LazyList a -> f (List b)
traverse g [] = pure []
traverse g (x :: xs) = [| g x :: traverse g xs |]

public export %inline
for : Applicative f => LazyList a -> (a -> f b) -> f (List b)
for = flip traverse

public export
sequence : Applicative f => LazyList (f a) -> f (List a)
sequence = traverse id

public export
Zippable LazyList where
  zipWith _ [] _ = []
  zipWith _ _ [] = []
  zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

  zipWith3 _ [] _ _ = []
  zipWith3 _ _ [] _ = []
  zipWith3 _ _ _ [] = []
  zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs

  unzip xs = (fst <$> xs, snd <$> xs)
  unzipWith = unzip .: map

  unzip3 xs = (fst <$> xs, fst . snd <$> xs, snd . snd <$> xs)
  unzipWith3 = unzip3 .: map

--- Lists creation ---

public export
fromList : List a -> LazyList a
fromList []      = []
fromList (x::xs) = x :: fromList xs

covering
public export
iterate : (f : a -> Maybe a) -> (x : a) -> LazyList a
iterate f x = x :: case f x of
  Nothing => []
  Just y  => iterate f y

covering
public export
unfoldr : (b -> Maybe (a, b)) -> b -> LazyList a
unfoldr f c = case f c of
  Nothing     => []
  Just (a, n) => a :: unfoldr f n

public export
iterateN : Nat -> (a -> a) -> a -> LazyList a
iterateN Z     _ _ = []
iterateN (S n) f x = x :: iterateN n f (f x)

public export
replicate : (n : Nat) -> (x : a) -> LazyList a
replicate Z     _ = []
replicate (S n) x = x :: replicate n x

--- Functions acquiring parts of list ---

public export
head' : LazyList a -> Maybe a
head' []     = Nothing
head' (x::_) = Just x

public export
tail' : LazyList a -> Maybe (LazyList a)
tail' []      = Nothing
tail' (_::xs) = Just xs

--- Functions for acquiring different types of sublists ---

public export
take : Nat -> LazyList a -> LazyList a
take (S k) (x::xs) = x :: take k xs
take _ _ = []

public export
drop : Nat -> LazyList a -> LazyList a
drop Z     xs      = xs
drop (S _) []      = []
drop (S n) (_::xs) = drop n xs

public export
takeWhile : (a -> Bool) -> LazyList a -> LazyList a
takeWhile p []      = []
takeWhile p (x::xs) = if p x then x :: takeWhile p xs else []

public export
dropWhile : (a -> Bool) -> LazyList a -> LazyList a
dropWhile p []      = []
dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs

public export
filter : (a -> Bool) -> LazyList a -> LazyList a
filter p []      = []
filter p (x::xs) = if p x then x :: filter p xs else filter p xs

public export
mapMaybe : (a -> Maybe b) -> LazyList a -> LazyList b
mapMaybe f []      = []
mapMaybe f (x::xs) = case f x of
  Nothing => mapMaybe f xs
  Just y  => y :: mapMaybe f xs

namespace Stream

  public export
  take : Fuel -> Stream a -> LazyList a
  take Dry _ = []
  take (More f) (x :: xs) = x :: take f xs

namespace Colist

  public export
  take : Fuel -> Colist a -> LazyList a
  take Dry _ = []
  take _ [] = []
  take (More f) (x :: xs) = x :: take f xs

namespace Colist1

  public export
  take : Fuel -> Colist1 a -> LazyList a
  take fuel as = take fuel (forget as)

--- Functions for extending lists ---

public export
mergeReplicate : a -> LazyList a -> LazyList a
mergeReplicate sep []      = []
mergeReplicate sep (y::ys) = sep :: y :: mergeReplicate sep ys

public export
intersperse : a -> LazyList a -> LazyList a
intersperse sep []      = []
intersperse sep (x::xs) = x :: mergeReplicate sep xs

public export
intercalate : (sep : LazyList a) -> (xss : LazyList (LazyList a)) -> LazyList a
intercalate sep xss = choice $ intersperse sep xss

--- Functions converting lazy lists to something ---

public export
toColist : LazyList a -> Colist a
toColist [] = []
toColist (x::xs) = x :: toColist xs


module vadd

-- :addclause
vadd : Num a => Vect n a -> Vect n a -> Vect n a


-- examples in "Type-Driven Development with Idris"
-- chapter 15, section 15.2

import System.Concurrency.Channels

-- check that all functions are total
%default total

data Message = Add Nat Nat

data MessagePID = MkMessage PID

data ProcState = NoRequest | Sent | Complete

data Process : Type ->
               (in_state : ProcState) ->
               (out_state : ProcState) ->
               Type where
  Action : IO a -> Process a st st
  Pure : a -> Process a st st
  (>>=) : Process a st1 st2 -> (a -> Process b st2 st3) ->
          Process b st1 st3
  Spawn : Process () NoRequest Complete ->
          Process (Maybe MessagePID) st st
  Request : MessagePID -> Message -> Process Nat st st
  Respond : ((msg : Message) -> Process Nat NoRequest NoRequest) ->
            Process (Maybe Message) st Sent
  Loop : Inf (Process a NoRequest Complete) ->
         Process a Sent Complete

data Fuel = Dry | More (Lazy Fuel)

run : Fuel -> Process t in_state out_state -> IO (Maybe t)
run Dry _ = pure Nothing
run fuel (Request (MkMessage pid) msg)
  = do Just chan <- connect pid
       | _ => pure Nothing
       ok <- unsafeSend chan msg
       if ok then do Just x <- unsafeRecv Nat chan
                     | Nothing => pure Nothing
                     pure (Just x)
              else pure Nothing
run fuel (Respond calc)
  = do Just sender <- listen 1
       | Nothing => pure (Just Nothing)
       Just msg <- unsafeRecv Message sender
       | Nothing => pure (Just Nothing)
       Just res <- run fuel (calc msg)
       | Nothing => pure Nothing
       unsafeSend sender res
       pure (Just (Just msg))
run fuel (Action act) = do res <- act
                           pure (Just res)
run fuel (Pure val) = pure (Just val)
run fuel (act >>= next) = do Just x <- run fuel act
                             | Nothing => pure Nothing
                             run fuel (next x)
run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc
                                                 pure ())
                           | Nothing => pure Nothing
                           pure (Just (Just (MkMessage pid)))
run (More fuel) (Loop act) = run fuel act

partial
forever : Fuel
forever = More forever

partial
runProc : Process () in_state out_state -> IO ()
runProc proc = do run forever proc
                  pure ()

Service : Type -> Type
Service a = Process a NoRequest Complete

Client : Type -> Type
Client a = Process a NoRequest NoRequest

procAdder : Service ()
procAdder = do Respond (\msg => case msg of
                                  Add x y => Pure (x + y))
               Loop procAdder

procMain : Client ()
procMain = do Just adder_id <- Spawn procAdder
              | Nothing => Action (putStrLn "Spawn failed")
              answer <- Request adder_id (Add 2 3)
              Action (printLn answer)

-- run with:
-- :exec runProc procMain


module Main

import Cairo
import Data.Bits

-- The following functions are required to avoid that the constantfolder
-- evaluates the expressions at compile time.
-- Maybe we should disable the constantfolder and write the tests more direct.

%foreign
  """
  code:
  func Main_f_200() -> (r):
      return (200)
  end
  """
f_200 : Felt

%foreign
  """
  code:
  func Main_f_100() -> (r):
      return (100)
  end
  """
f_100 : Felt

u_200 : Bits8
u_200 = cast {to=Bits8} f_200

u_100 : Bits8
u_100 = cast {to=Bits8} f_100

out : Cast a Felt => a -> Cairo ()
out = output . cast

%noinline
main : Cairo ()
main = do
  out $ u_200 + u_100
  out $ u_200 - u_100
  out $ u_200 * u_100
  -- BUG, this returns 0!!!
  -- Patternmachting on felt famously does not work.
  -- Best would be to make it work - otherwise throw an error at compile time or at least crash at runtime.
  -- out $ case b of 0 => 0 ; x => (cast {to=Bits8} a) `div` (cast {to=Bits8} x)
  out $ assert_total $ u_200 `div` 7
  out $ assert_total $ u_200 `mod` 7
  out $ - u_100
  out $ u_200 .&. u_100
  out $ u_200 .|. u_100
  out $ u_200 `xor` u_100
  out $ u_200 < u_100
  out $ u_200 <= u_100
  out $ u_200 == u_100
  out $ u_200 >= u_100
  out $ u_200 > u_100
  -- out $ u_100 `shiftL` 1 -- Index is of type Nat. Not implemented yet
  -- out $ u_100 `shiftR` 1


-- ------------------------------------------------------------- [ Tibetan.idr ]
-- Module      : Text.Parse.Tibetan
-- Description : Parsers for Tibetan numerals.
-- --------------------------------------------------------------------- [ EOH ]
||| This module contains an integer parser for Tibetan numerals.
module Text.Parse.Tibetan

import public Data.Composition
import public Lightyear
import public Lightyear.Char
import public Lightyear.Strings

parseDigit : (Integral a) => Char -> a -> Parser a
parseDigit c i = do
  char c
  pure i

-- TODO figure out how to make this lazy
parseNumeral : Parser Int
parseNumeral = foldr (<|>) (parseDigit '༠' 0) $ zipWith parseDigit s (0::[1..10])
  where s = unpack "༠༡༢༣༤༥༦༧༨༩"

parseNumeralFake : Parser Int
parseNumeralFake = foldr (<|>) (parseDigit '0' 0) $ zipWith parseDigit s (0::[1..10])
  where s = unpack "0123456789"

parseLatin : Parser Int
parseLatin = do
  digits <- reverse <$> some parseNumeralFake
  (pure . (\x => div x 10) $ foldr ((*10) .* (+)) 0 digits) <?> "Tibetan integer"

||| A lightyear parser for Tibetan numerals.
export
parseNumber : Parser Int
parseNumber = do
  digits <- reverse <$> some parseNumeral
  (pure . (\x => div x 10) $ foldr ((*10) .* (+)) 0 digits) <?> "Tibetan integer"

||| Given a 'String', try to parse it as an integer written using Tibetan numerals. If this fails, return a 'String' explaining why.
export
readBo : String -> Either String Int
readBo = parse (parseNumber)

export
readTest : String -> Either String Int
readTest = parse parseLatin