module MinesweeperSMT

import Data.Vect
import src.SMTLib
import src.Tensor
import src.GridOps

puzzle : Vect 9 (Vect 9 Int)
puzzle = [ [-1, -1, -1, -1,  1,  0,  0,  1, -1],
           [-1, -1,  2,  1,  1,  0,  0,  1,  1],
           [-1, -1,  1,  0,  0,  0,  0,  0,  0],
           [-1,  2,  1,  0,  0,  0,  0,  0,  0],
           [-1,  2,  0,  0,  0,  0,  0,  0,  0],
           [-1,  3,  1,  0,  0,  0,  1,  1,  1],
           [-1, -1,  1,  0,  0,  0,  1, -1, -1],
           [-1, -1,  2,  2,  1,  1,  1, -1, -1],
           [-1, -1, -1, -1, -1, -1, -1, -1, -1] ]

lookup : Fin n -> Fin m -> List Dir ->  Vect n (Vect m (Expr (NumT IntT))) -> Expr (NumT IntT)
lookup n m ds xss = GridOps.lookup n m ds (int 0) xss

equation : Fin n -> Fin m -> Int -> Vect n (Vect m (Expr (NumT IntT))) -> Expr BoolT
equation n m v xss with (toPos n, toPos m)
  equation n m v xss | (First, First) = add [lookup n m [Left] xss, lookup n m [Up] xss, lookup n m [Up, Left] xss] == (int v)
  equation n m v xss | (Last, Last) = add [lookup n m [Right] xss, lookup n m [Down] xss, lookup n m [Down, Right] xss] == (int v)
  equation n m v xss | (First, Last) = add [lookup n m [Right] xss, lookup n m [Up] xss, lookup n m [Up, Right] xss] == (int v)
  equation n m v xss | (Last, First) = add [lookup n m [Left] xss, lookup n m [Down] xss, lookup n m [Down, Left] xss] == (int v)
  equation n m v xss | (First, _) = add [lookup n m [Left] xss, lookup n m [Right] xss, lookup n m [Up] xss,
                                         lookup n m [Up, Right] xss, lookup n m [Up, Left] xss] == (int v)
  equation n m v xss | (Last, _) = add [lookup n m [Left] xss, lookup n m [Right] xss, lookup n m [Down] xss,
                                        lookup n m [Down, Right] xss, lookup n m [Down, Left] xss] == (int v)
  equation n m v xss | (_, First) = add [lookup n m [Left] xss, lookup n m [Down] xss, lookup n m [Down, Left] xss,
                                         lookup n m [Up] xss, lookup n m [Up, Left] xss] == (int v)
  equation n m v xss | (_, Last) = add [lookup n m [Right] xss, lookup n m [Down] xss, lookup n m [Down, Right] xss,
                                        lookup n m [Up] xss, lookup n m [Up, Right] xss] == (int v)
  equation n m v xss | (_, _) = add [lookup n m [Left] xss, lookup n m [Right] xss, lookup n m [Down] xss,
                                     lookup n m [Up] xss, lookup n m [Down, Right] xss, lookup n m [Down, Left] xss,
                                     lookup n m [Up, Right] xss, lookup n m [Up, Left] xss] == (int v)

collect : Vect n (Vect m Int) -> Vect n (Vect m (Expr (NumT IntT))) -> Vect n (Vect m (Expr BoolT))
collect puzzle vars = tabulate (\n => tabulate (\m => let (x, v) = (index n m puzzle, index n m vars) in
                                                      if x < 0 then (v == (int 0)) || (v == (int 1)) else (v == (int 0)) && equation n m x vars))

vars : Tensor [9, 9] String
vars = toTensor $ tabulate (\i0 => tabulate (\i1 => "x_" ++ show (finToNat i0) ++ "_" ++ show (finToNat i1)))

inst : Vect 9 (Vect 9 (Expr (NumT IntT)))
inst = tabulate (\i0 => tabulate (\i1 => int $ index i0 i1 puzzle))

solver : Smt ()
solver = do vars <- declareVars vars (NumT IntT)
            assert $ and $ concat $ collect puzzle (toVect vars)
            assert $ index 0 1 (toVect vars) == (int 1)
            checkSat
            getModel
            end

test : IO ()
test = print solver


module Quantities.Units

import Quantities.Core
import Quantities.SIBaseQuantities
import Quantities.SIDerivedQuantities
import Quantities.SIBaseUnits

%default total
%access public export

Radian : Unit PlaneAngle
Radian = One
Rad : Unit PlaneAngle
Rad = One

Steradian : Unit SolidAngle
Steradian = One
Sr : Unit SolidAngle
Sr = Steradian

Hertz : Unit Frequency
Hertz = Second ^^ (-1)
Hz : Unit Frequency
Hz = Hertz

Newton : Unit Force'
Newton = ((Metre <//> Second) <//> Second) <**> Kilogram
N : Unit Force'
N = Newton

Pascal : Unit Pressure
Pascal = Newton <//> (Metre ^^ 2)
Pa : Unit Pressure
Pa = Pascal

Joule : Unit Energy
Joule = Newton <**> Metre
J : Unit Energy
J = Joule

Watt : Unit Power
Watt = Joule <//> Second
W : Unit Power
W = Watt

Coulomb : Unit ElectricCharge
Coulomb = Second <**> Ampere
C : Unit ElectricCharge
C = Coulomb

Volt : Unit ElectricPotentialDifference
Volt = Watt <//> Ampere
V : Unit ElectricPotentialDifference
V = Volt

Farad : Unit Capacitance
Farad = Coulomb <//> Volt
F : Unit Capacitance
F = Farad

Ohm : Unit ElectricResistance
Ohm = Volt <//> Ampere

Siemens : Unit ElectricConductance
Siemens = Ampere <//> Volt
S : Unit ElectricConductance
S = Siemens

Weber : Unit MagneticFlux
Weber = Second <**> Volt
Wb : Unit MagneticFlux
Wb = Weber

Tesla : Unit MagneticFluxDensity
Tesla = Weber <//> (Metre ^^ 2)
T : Unit MagneticFluxDensity
T = Tesla

Henry : Unit Inductance
Henry = Weber <//> Ampere
H : Unit Inductance
H = Henry

-- For relative temperature measurements
Celsius : Unit Temperature
Celsius = Kelvin
DC : Unit Temperature
DC = Celsius

Lumen : Unit LuminousFlux
Lumen = Candela <**> Steradian
Lm : Unit LuminousFlux
Lm = Lumen

Lux : Unit Illuminance
Lux = Lumen <//> (Metre ^^ 2)
Lx : Unit Illuminance
Lx = Lux

Becquerel : Unit ActivityReferredToARadionuclide
Becquerel = Second ^^ (-1)
Bq : Unit ActivityReferredToARadionuclide
Bq = Becquerel

Gray : Unit AbsorbedDose
Gray = Joule <//> Kilogram
Gy : Unit AbsorbedDose
Gy = Gray

Sievert : Unit DoseEquivalent
Sievert = Joule <//> Kilogram
Sv : Unit DoseEquivalent
Sv = Sievert

Katal : Unit CatalyticActivity
Katal = Mol <//> Second
Kat : Unit CatalyticActivity
Kat = Katal


labelWith : Stream labelType -> List a -> List (labelType, a)
labelWith lbl [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals

label : List a -> List (Integer, a)
label = labelWith (iterate (+1) 0)


import Data.Vect

-- using implicit arguments in pattern matching
length : Vect n elem -> Nat
length {n} xs = n

-- give explicit values for implicit arguments by
-- using the notation {n = value}
create_empties : Vect n (Vect 0 a)
create_empties {n = Z} = []
create_empties {n = (S k)} = [] :: create_empties


module Verified.Functor.Maybe

import Verified.Functor

instance VerifiedFunctor Maybe where
  functorIdentity Nothing = Refl
  functorIdentity (Just x) = Refl
  functorComposition Nothing g1 g2 = Refl
  functorComposition (Just x) g1 g2 = Refl


data Fin : Nat -> Type where
     FZ : Fin (S k)
     FS : Fin k -> Fin (S k)

interface Finite t where
  card   : Nat
  to     : t -> Fin card
  from   : Fin card -> t
  toFrom : (k : Fin card) -> to (from k) = k
  fromTo : (x : t) -> from (to x) = x

-- Checking dependent methods work, and that having names from the
-- methods shadowed in the interface head doesn't cause any issues

implementation Finite (Fin k) where
  card   = ?ncard
  to     = ?lala
  from   = ?lula
  toFrom = ?foo
  fromTo = ?bar

implementation Finite (Fin n) where
  card   = ?ncard1
  to     = ?lala1
  from   = ?lula1
  toFrom = ?foo1
  fromTo = ?bar1

implementation Finite (Fin t) where
  card   = ?ncard2
  to     = ?lala2
  from   = ?lula2
  toFrom = ?foo2
  fromTo = ?bar2


||| An embedding of `Dec` instances into `Either` to gain access to Do notation.
|||
||| Thanks Matus for figuring it out.
|||
||| So let's have this:
|||
||| ```
||| exampleDo : DecEq a => DecEq b => (ps, rs : Pair a b) -> Dec (ps = rs)
||| exampleDo (x, y) (a,b)
|||   = decDo $ do Refl <- decEq x a `otherwise` (\Refl => Refl)
|||                Refl <- decEq y b `otherwise` (\Refl => Refl)
|||                Right Refl
||| ```
|||
||| Rather than:
|||
||| ```
||| example : DecEq a => DecEq b => (ps, rs : Pair a b) -> Dec (ps = rs)
||| example (x, y) (a, b) with (decEq x a)
|||   example (x, y) (x, b) | (Yes Refl) with (decEq y b)
|||     example (x, y) (x, y) | (Yes Refl) | (Yes Refl) = Yes Refl
|||     example (x, y) (x, b) | (Yes Refl) | (No contra) = No (\Refl => contra Refl)
|||   example (x, y) (a, b) | (No contra) = No (\Refl => contra Refl)
||| ```
|||
module Toolkit.Decidable.Do

import Decidable.Equality

import Toolkit.Decidable.Informative

%default total

export
otherwise : Dec b -> (a -> b) -> Either (Not a) b
otherwise (Yes pfB)  f = Right pfB
otherwise (No notB)  f = Left (notB . f)

export
decDo : Either (Not a) a -> Dec a
decDo (Left notA) = No notA
decDo (Right pfA) = Yes pfA

-- [ EOF ]


module WordLength

allLengths : List String -> List Nat
allLengths [] = []
allLengths (x :: xs) = length x :: allLengths xs


> module Discussion

> import Fix

# Data Types a la Carte in Idris

A brief discussion on design choices implementing DTalC.

## Syntax

One of the problems with the [original Data Types a la Carte implementation](http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf),
was that the coproduct, `(:+:)`, allowed arbitrary grouping of signatures,
e.g. `(f :+: g) :+: g`. However, injection only performed a linear search from
left to right, and so the subtyping relation could not be satisfied in cases
which were not right-associative, such as `f :≺: (f :+: g) :+: h`.

To remedy this, a [list of signatures can be used instead](https://reasonablypolymorphic.com/blog/better-data-types-a-la-carte/).
For example, `f :+: g` would be written as `Sig [f, g]`, using `Sig` below.
Here, `fs` is a list of the different signatures that make up the composite
signature `Sig`. The `a` is the type given to each `f` in `fs`.

(Side note: An alternative method to solve injection into non-right-associative
signatures involves using a [backtracking search](http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.643.3533&rep=rep1&type=pdf),
but using a list provides a simpler solution)

> data Sig : (fs : List (Type -> Type)) -> (a : Type) -> Type where
>     Here  : f a -> Sig (f :: fs) a
>     There : Sig fs a -> Sig (f :: fs) a

Instead of `InL` and `InR` constructors for the coproduct, `Sig` uses `Here`
and `There` to describe how to construct a value of a signature. For example,
the DSL from Data Types a la Carte paper can be described as:

> data Val k = V Int
> data Add k = A k k

Using the standard definition of Fix, and the `Here` and `There` constructors,
DSLs containing both values and addition can be created. Below represents the
expression `1 + 2`:

> ex1 : Fix (Sig [Val, Add])
> ex1 = In (There (Here (A x y))) where
>     x = In (Here (V 1))
>     y = In (Here (V 2))

Clearly, this is very cumbersome to write, and so, like in the original paper,
it would be better to automate injection into some super-type. This will involve
finding the correct combination of `There` and `Here`.

Attempting to use interface instances, like in the original paper, such as
those below to perform this linear-search requires overlapping instances, which
Idris [does not allow](http://docs.idris-lang.org/en/v0.9.18/tutorial/classes.html).

Therefore, another solution to this search is required. Fortunately, this has
already been solved in the standard library (see `Elem` in [Data.List](https://github.com/idris-lang/Idris-dev/blob/master/libs/base/Data/List.idr)),
with a structure similar to `Elem` below.

The constructor `H` is a proof the signature `f` is at the front of the list
of signatures to be composed together, `fs`. The constructor `T` is a proof the
signature is after the front of the list.

> data Elem : (f : Type -> Type) -> (fs : List (Type -> Type)) -> Type where
>     H : Elem f (f :: fs)
>     T : Elem f ys -> Elem f (y :: ys)

Using this, an `inj` function can be created to construct a sequence of `Here`
and `There`:

> inj' : Elem f fs -> f a -> Sig fs a
> inj' H     x = Here x
> inj' (T t) x = There (inj' t x)

However, this does not currently provide any advantage over manually using
`Here` and `There`, since `inj'` requires manually specifying `H` and `T`.
However, Idris' automatic proof search can be leveraged to have it automatically
find the correct combination of `H` and `T`:

> inj : {auto prf : Elem f fs} -> f a -> Sig fs a
> inj {prf=H}   x = Here x
> inj {prf=T t} x = There (inj {prf=t} x)

For convenience, `inj` can be adapted to work with `Fix`:

> inject : {auto prf : Elem f fs} -> f (Fix (Sig fs)) -> Fix (Sig fs)
> inject = In . inj

Putting this together, smart constructors can be created for the example DSL.
Instead of a type constraint, `Val :<: f`, such as in the original paper,
`Elem Val fs` is used to prove that `Val` exists in `fs`:

> val : {auto prf : Elem Val fs} -> Int -> Fix (Sig fs)
> val x = inject (V x)

> add : {auto prf : Elem Add fs} -> Fix (Sig fs) -> Fix (Sig fs) -> Fix (Sig fs)
> add x y = inject (A x y)

Putting this all together, DSLs containing values and addition can be succinctly
represented:

> ex2 : Fix (Sig [Val, Add])
> ex2 = add (val 1) (add (val 2) (val 3))

## Semantics

In the original paper, typeclasses provide a method to specify the semantics
of different pieces of syntax separately, by providing an algebra `f a -> a`
to fold over a fix tree `Fix f`.

In order to fold over a `Fix` tree using `cata`, a `f` needs to be a functor:

```idris
cata : Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . map (cata alg) . inop
```

In this implementation `f` is `Sig fs`, therefore, `Sig fs` needs to be a
functor. This *could* be done by modifying the definition of `Here` to be
`Here : Functor f => f a -> Sig (f :: fs) a`. However, in the implementation
so-far no functions have required `f` to be a functor and so this solution feels
sub-optimal.

Instead, the functor instance for `Sig fs` will be defined inductively such that
`Sig fs` will be a functor when each `f` in `fs` has its own definition of functor.

Firstly, where there are no signatures it is not possible to map over anything:

> Functor (Sig []) where
>     map _ (Here _) impossible
>     map _ (There _) impossible

For the base case, `Here`, `map func x` calls `map : (a -> b) -> f a -> f b`.
Whereas, in the recursive case, `There`, `map func t` calls
`map : (a -> b) -> Sig fs a -> Sig fs b`.

> (Functor f, Functor (Sig fs)) => Functor (Sig (f :: fs)) where
>     map func (Here x) = Here (map func x)
>     map func (There t) = There (map func t)

Continuing the example, by defining functor instances for both values and
addition, `Sig [Val, Add]` is also a functor.

> Functor Val where
>     map f (V x) = V x

> Functor Add where
>     map f (A x y) = A (f x) (f y)

In order to define the algebra `f a -> a` for a signature `f`, an interface is
used to allow the algebra for different pieces of syntax to be defined separately.

> interface Alg (f : Type -> Type) (a : Type) where
>     alg : f a -> a

Using the same technique used to define the `Functor` instance for `Sig`, the
`Alg` instance will be defined for `Sig fs`, provided each `f` in `fs` has its
own `Alg` instance. Again, when there is no syntax it is not possible to
use the algebras of any signatures:

> Alg (Sig []) a where
>     alg (Here _) impossible
>     alg (There _) impossible

In the base case, `alg x` uses `alg : f a -> a`. The recursive case uses
`alg : Sig fs -> a`.

> (Alg f a, Alg (Sig fs) a) => Alg (Sig (f :: fs)) a where
>     alg (Here x) = alg x
>     alg (There x) = alg x

To continue the expression example, `Alg` instances can be created that
translate into a result integer:

> Alg Val Int where
>     alg (V x) = x

> Alg Add Int where
>     alg (A x y) = x + y

Given signatures which have an algebra to which converts their syntax to
integers, a `calc` function can be created which calculates the value of an
expression:

> calc : (Functor (Sig fs), Alg (Sig fs) Int) => Fix (Sig fs) -> Int
> calc = cata alg

## Summary

This demonstrates how Data Types a la Carte can be implemented in such as
way as to solve one of the original problems. This shows how the inability to
create overlapping instances is solved by using the `Elem` type, and how
automatic proof search can be used to automatically inject into a type.

## Related Work: Effect Handlers

A problem inherent with Data Types a la Carte is it inability to allow
different semantic domains to be easily composed. To extend the DSL presented
with exceptions, for example, would require reimplementing the interface
instances `Alg Val Int` and `Alg Add Int` to be `Alg Val (Either Err Int)` and
`Alg Add (Either Err Int)`. One solution to this is [Effect Handlers](http://okmij.org/ftp/Haskell/extensible/extensible-a-la-carte.html)
which handle only specific parts of the syntax composed, instead of *all* the
syntax at once. Fortunately, this has [already been implemented in Idris](http://docs.idris-lang.org/en/latest/effects/introduction.html).


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

import System.File

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

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

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

score : Bracket -> Nat
score P = 1
score S = 2
score B = 3
score L = 4

run : String -> IO ()
run s = do let l = filter (\l => length l > 0) $ findMissing [] . catMaybes . parseChunks . unpack <$> lines s
           let s = sort $ (\bs => foldl (\a => \n => 5 * a + n ) 0 $ score <$> bs) <$> l
           let h = (div (length s) 2) + 1
           putStrLn $ show $ head' $ reverse $ take h s

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


module Minesweeper.Game

import Minesweeper.Board
import Control.Monad.State

public export
data Difficulty = Easy | Medium | Hard

public export
data GState = Playing String | Won | Lost

-- | Get board dimensions and number of mines
--   for the given difficulty level
export
getSetupDetails : Difficulty -> (Pos, Nat)
getSetupDetails Easy = ((MkPos 8 8), 10)
getSetupDetails Medium = ((MkPos 16 16), 40)
getSetupDetails Hard = ((MkPos 30 16), 99)

-- | Attempt to reveal the given position
-- returns the GameState after this move
export
revealPos : Pos -> State (Board m n) GState
revealPos pos@(MkPos x y) = do
  board <- get
  case (reveal pos board) of
    (Left err) => pure $ Playing err
    (Right newBoard) => do
      put newBoard
      if checkWin newBoard then pure Won
      else if checkLose newBoard then pure Lost
      else pure $ Playing $ "Revealed square in row:" ++ show y ++ " col:" ++  show x ++ "\n"


module Algebra.ZeroOneOmega

import Algebra.Semiring
import Algebra.Preorder

%default total

export
data ZeroOneOmega = Rig0 | Rig1 | RigW

export
Preorder ZeroOneOmega where
  Rig0 <=    _ = True
  Rig1 <= Rig1 = True
  _    <= RigW = True
  _    <=    _ = False
  preorderRefl {x = Rig0} = Refl
  preorderRefl {x = Rig1} = Refl
  preorderRefl {x = RigW} = Refl
  preorderTrans {x = Rig0} _ _ = Refl
  preorderTrans {x = Rig1} {y = Rig0} _ _ impossible
  preorderTrans {x = Rig1} {y = Rig1} _ yz = yz
  preorderTrans {x = Rig1} {y = RigW} {z = Rig0} _ _ impossible
  preorderTrans {x = Rig1} {y = RigW} {z = Rig1} _ _ = Refl
  preorderTrans {x = Rig1} {y = RigW} {z = RigW} _ _ = Refl
  preorderTrans {x = RigW} {y = Rig0} _ _ impossible
  preorderTrans {x = RigW} {y = Rig1} _ _ impossible
  preorderTrans {x = RigW} {y = RigW} _ yz = yz

public export
Eq ZeroOneOmega where
  (==) Rig0 Rig0 = True
  (==) Rig1 Rig1 = True
  (==) RigW RigW = True
  (==) _ _ = False

export
Show ZeroOneOmega where
  show Rig0 = "Rig0"
  show Rig1 = "Rig1"
  show RigW = "RigW"

export
rigPlus : ZeroOneOmega -> ZeroOneOmega -> ZeroOneOmega
rigPlus Rig0 a = a
rigPlus a Rig0 = a
rigPlus _ _ = RigW

export
rigMult : ZeroOneOmega -> ZeroOneOmega -> ZeroOneOmega
rigMult Rig0 _ = Rig0
rigMult _ Rig0 = Rig0
rigMult Rig1 a = a
rigMult a Rig1 = a
rigMult _ _ = RigW

public export
Semiring ZeroOneOmega where
  (|+|) = rigPlus
  (|*|) = rigMult
  plusNeutral = Rig0
  timesNeutral = Rig1

||| The top value of a lattice
export
Top ZeroOneOmega where
  top = RigW
  topAbs {x = Rig0} = Refl
  topAbs {x = Rig1} = Refl
  topAbs {x = RigW} = Refl

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

rigPlusAssociative : (x, y, z : ZeroOneOmega) ->
  rigPlus x (rigPlus y z) = rigPlus (rigPlus x y) z
rigPlusAssociative Rig0 _ _ = Refl
rigPlusAssociative Rig1 Rig0 _ = Refl
rigPlusAssociative Rig1 Rig1 Rig0 = Refl
rigPlusAssociative Rig1 Rig1 Rig1 = Refl
rigPlusAssociative Rig1 Rig1 RigW = Refl
rigPlusAssociative Rig1 RigW Rig0 = Refl
rigPlusAssociative Rig1 RigW Rig1 = Refl
rigPlusAssociative Rig1 RigW RigW = Refl
rigPlusAssociative RigW Rig0 _ = Refl
rigPlusAssociative RigW Rig1 Rig0 = Refl
rigPlusAssociative RigW Rig1 Rig1 = Refl
rigPlusAssociative RigW Rig1 RigW = Refl
rigPlusAssociative RigW RigW Rig0 = Refl
rigPlusAssociative RigW RigW Rig1 = Refl
rigPlusAssociative RigW RigW RigW = Refl

rigPlusCommutative : (x, y : ZeroOneOmega) ->
  rigPlus x y = rigPlus y x
rigPlusCommutative Rig0 Rig0 = Refl
rigPlusCommutative Rig0 Rig1 = Refl
rigPlusCommutative Rig0 RigW = Refl
rigPlusCommutative Rig1 Rig0 = Refl
rigPlusCommutative Rig1 Rig1 = Refl
rigPlusCommutative Rig1 RigW = Refl
rigPlusCommutative RigW Rig0 = Refl
rigPlusCommutative RigW Rig1 = Refl
rigPlusCommutative RigW RigW = Refl

rigMultAssociative : (x, y, z : ZeroOneOmega) ->
  rigMult x (rigMult y z) = rigMult (rigMult x y) z
rigMultAssociative Rig0 _ _ = Refl
rigMultAssociative Rig1 Rig0 _ = Refl
rigMultAssociative Rig1 Rig1 Rig0 = Refl
rigMultAssociative Rig1 Rig1 Rig1 = Refl
rigMultAssociative Rig1 Rig1 RigW = Refl
rigMultAssociative Rig1 RigW Rig0 = Refl
rigMultAssociative Rig1 RigW Rig1 = Refl
rigMultAssociative Rig1 RigW RigW = Refl
rigMultAssociative RigW Rig0 _ = Refl
rigMultAssociative RigW Rig1 Rig0 = Refl
rigMultAssociative RigW Rig1 Rig1 = Refl
rigMultAssociative RigW Rig1 RigW = Refl
rigMultAssociative RigW RigW Rig0 = Refl
rigMultAssociative RigW RigW Rig1 = Refl
rigMultAssociative RigW RigW RigW = Refl

rigMultCommutative : (x, y : ZeroOneOmega) ->
  rigMult x y = rigMult y x
rigMultCommutative Rig0 Rig0 = Refl
rigMultCommutative Rig0 Rig1 = Refl
rigMultCommutative Rig0 RigW = Refl
rigMultCommutative Rig1 Rig0 = Refl
rigMultCommutative Rig1 Rig1 = Refl
rigMultCommutative Rig1 RigW = Refl
rigMultCommutative RigW Rig0 = Refl
rigMultCommutative RigW Rig1 = Refl
rigMultCommutative RigW RigW = Refl


module IdrisWeb.Common.Date
import Builtins
%access public

{- Simple date and time records.
   Like, really simple. They'll do for now.

   Allows date serialisation and deserialisation as per
   RFC822, which is used when setting cookies.

   TODO: Timezones, timestamp, comparison

-}

data Day = Monday
         | Tuesday
         | Wednesday
         | Thursday
         | Friday
         | Saturday
         | Sunday

data Month = January
           | February
           | March
           | April
           | May
           | June
           | July
           | August
           | September
           | October
           | November
           | December

-- Not using the show typeclass for cookies, since there are so many
-- different ways of showing dates.
showCookieDay : Day -> String
showCookieDay Monday = "Mon"
showCookieDay Tuesday = "Tue"
showCookieDay Wednesday = "Wed"
showCookieDay Thursday = "Thu"
showCookieDay Friday = "Fri"
showCookieDay Saturday = "Sat"
showCookieDay Sunday = "Sun"

--private
{-
divides : Integer -> Integer -> Bool
divides x y = (x `mod` y) == 0

isLeapYear : (year : Integer) -> Bool
isLeapYear y = if divides y 400 then True
                   else if divides y 100 then False
                   else if divides y 4 then True
                   else False

--  where y : Nat
  --      y = cast year
  -}

isLeapYear : (year : Integer) -> Bool
isLeapYear year = if (y `mod` 400) == O then True
                   else if (y `mod` 100) == O then False
                   else if (y `mod` 4) == O then True
                   else False
  where y : Nat
        y = cast year

daysInMonth : Month -> (year : Integer) -> Int
daysInMonth September _ = 30
daysInMonth April _ = 30
daysInMonth June _ = 30
daysInMonth November _ = 30
daysInMonth February y = if isLeapYear y then 29
                                         else 28
daysInMonth _ _ = 31

dayOfWeek : (year : Integer) -> (month : Integer) -> (day : Integer) -> Int
dayOfWeek year month day = d + (2.6 * m)
  where y = if (month == 1 || month == 2) then year - 1 else year
        m = (month - 2) `mod` 12
        d = daysInMonth month

public
record Date : Type where
  MkDate : (day : Integer) ->
           (month : Integer) ->
           (year : Integer) -> Date

public
record DateTime : Type where
  MkDateTime : (day : Integer) ->
               (month : Integer) ->
               (year : Integer) ->
               (hour : Integer) ->
               (minute : Integer) ->
               (second : Integer) ->
               DateTime

-- Why everyone can't just use the ISO one, I'll never know...
-- Wed, 13 Jan 2021 22:23:01 GMT
--abstract
--showCookieTime : DateTime -> String
--showCookieTime dt


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor -}
module Main

import Data.Vect

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

size : DataStore -> Nat
size (MkData s i) = s

items : (store : DataStore) -> Vect (size store) String
items (MkData s i) = i

addToStore : DataStore -> String -> DataStore
addToStore (MkData s i) n = MkData _ (addToData i)
  where
    addToData : Vect old String -> Vect (S old) String
    addToData [] = [n]
    addToData (i :: is) = i :: addToData is

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

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

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

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

getSize : (store : DataStore) -> Maybe (String, DataStore)
getSize store = Just ("Size of store: " ++ cast (size store), store)

search : (store : DataStore) -> (str : String) -> Maybe (String, DataStore)
search store str =
  let store_items  = items store in
  let found = foldrImpl
                (\(ix, msg), acc => if (str `isInfixOf` msg)
                  then (cast $ finToInteger ix) ++ ": " ++ msg ++ "\n" ++ acc
                  else acc)
                ""
                (\acc => acc)
                (zip range store_items)
  in Just (found, store)

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store inp = case parse inp of
  Nothing           => Just ("Invalid command\n", store)
  Just (Add item)   => Just ("ID " ++ show (size store) ++ "\n", addToStore store item)
  Just (Get pos)    => getEntry pos store
  Just Size         => getSize store
  Just (Search str) => search store str
  Just Quit         => Nothing

main : IO ()
main = replWith (MkData _ []) "Command: " processInput


module Data.List

import Data.Nat
import Data.List1
import Data.Fin
import public Data.Zippable

%default total

public export
isNil : List a -> Bool
isNil [] = True
isNil _  = False

public export
isCons : List a -> Bool
isCons [] = False
isCons _  = True

public export
snoc : List a -> a -> List a
snoc xs x = xs ++ [x]

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

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

||| Satisfiable if `k` is a valid index into `xs`.
|||
||| @ k  the potential index
||| @ xs the list into which k may be an index
public export
data InBounds : (k : Nat) -> (xs : List a) -> Type where
    ||| Z is a valid index into any cons cell
    InFirst : InBounds Z (x :: xs)
    ||| Valid indices can be extended
    InLater : InBounds k xs -> InBounds (S k) (x :: xs)

public export
Uninhabited (InBounds k []) where
  uninhabited InFirst impossible
  uninhabited (InLater _) impossible

export
Uninhabited (InBounds k xs) => Uninhabited (InBounds (S k) (x::xs)) where
  uninhabited (InLater y) = uninhabited y

||| Decide whether `k` is a valid index into `xs`.
public export
inBounds : (k : Nat) -> (xs : List a) -> Dec (InBounds k xs)
inBounds _ [] = No uninhabited
inBounds Z (_ :: _) = Yes InFirst
inBounds (S k) (x :: xs) with (inBounds k xs)
  inBounds (S k) (x :: xs) | (Yes prf) = Yes (InLater prf)
  inBounds (S k) (x :: xs) | (No contra)
      = No $ \(InLater y) => contra y

||| Find a particular element of a list.
|||
||| @ ok a proof that the index is within bounds
public export
index : (n : Nat) -> (xs : List a) -> {auto 0 ok : InBounds n xs} -> a
index Z (x :: xs) {ok = InFirst} = x
index (S k) (_ :: xs) {ok = InLater _} = index k xs

public export
index' : (xs : List a) -> Fin (length xs) -> a
index' (x::_)  FZ     = x
index' (_::xs) (FS i) = index' xs i

||| Generate a list by repeatedly applying a partial function until exhausted.
||| @ f the function to iterate
||| @ x the initial value that will be the head of the list
covering
public export
iterate : (f : a -> Maybe a) -> (x : a) -> List a
iterate f x  = x :: case f x of
  Nothing => []
  Just y => iterate f y

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

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

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

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

||| Applied to a predicate and a list, returns the list of those elements that
||| satisfy the predicate.
public export
filter : (p : a -> Bool) -> List a -> List a
filter p [] = []
filter p (x :: xs)
   = if p x
        then x :: filter p xs
        else filter p xs

||| Find the first element of the list that satisfies the predicate.
public export
find : (p : a -> Bool) -> (xs : List a) -> Maybe a
find p [] = Nothing
find p (x::xs) = if p x then Just x else find p xs

||| Find the index and proof of InBounds of the first element (if exists) of a
||| list that satisfies the given test, else `Nothing`.
public export
findIndex : (a -> Bool) -> (xs : List a) -> Maybe $ Fin (length xs)
findIndex _ [] = Nothing
findIndex p (x :: xs) = if p x
  then Just FZ
  else FS <$> findIndex p xs

||| Find indices of all elements that satisfy the given test.
public export
findIndices : (a -> Bool) -> List a -> List Nat
findIndices p = h 0 where
  h : Nat -> List a -> List Nat
  h _         []  = []
  h lvl (x :: xs) = if p x
    then lvl :: h (S lvl) xs
    else        h (S lvl) xs

||| Find associated information in a list using a custom comparison.
public export
lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b
lookupBy p e []      = Nothing
lookupBy p e ((l, r) :: xs) =
  if p e l then
    Just r
  else
    lookupBy p e xs

||| Find associated information in a list using Boolean equality.
public export
lookup : Eq a => a -> List (a, b) -> Maybe b
lookup = lookupBy (==)

||| Check if something is a member of a list using a custom comparison.
public export
elemBy : (a -> a -> Bool) -> a -> List a -> Bool
elemBy p e []      = False
elemBy p e (x::xs) = p e x || elemBy p e xs

public export
nubBy : (a -> a -> Bool) -> List a -> List a
nubBy = nubBy' []
  where
    nubBy' : List a -> (a -> a -> Bool) -> List a -> List a
    nubBy' acc p []      = []
    nubBy' acc p (x::xs) =
      if elemBy p x acc then
        nubBy' acc p xs
      else
        x :: nubBy' (x::acc) p xs

||| O(n^2). The nub function removes duplicate elements from a list. In
||| particular, it keeps only the first occurrence of each element. It is a
||| special case of nubBy, which allows the programmer to supply their own
||| equality test.
|||
||| ```idris example
||| nub (the (List _) [1,2,1,3])
||| ```
public export
nub : Eq a => List a -> List a
nub = nubBy (==)

||| The deleteBy function behaves like delete, but takes a user-supplied equality predicate.
public export
deleteBy : (a -> a -> Bool) -> a -> List a -> List a
deleteBy _  _ []      = []
deleteBy eq x (y::ys) = if x `eq` y then ys else y :: deleteBy eq x ys

||| `delete x` removes the first occurrence of `x` from its list argument. For
||| example,
|||
|||````idris example
|||delete 'a' ['b', 'a', 'n', 'a', 'n', 'a']
|||````
|||
||| It is a special case of deleteBy, which allows the programmer to supply
||| their own equality test.
public export
delete : Eq a => a -> List a -> List a
delete = deleteBy (==)

||| Delete the first occurrence of each element from the second list in the first
||| list where equality is determined by the predicate passed as the first argument.
||| @ p            A function that returns true when its two arguments should be considered equal.
||| @ source       The list to delete elements from.
||| @ undesirables The list of elements to delete.
public export
deleteFirstsBy : (p : a -> a -> Bool) -> (source : List a) -> (undesirables : List a) -> List a
deleteFirstsBy p = foldl (flip (deleteBy p))

infix 7 \\

||| The non-associative list-difference.
||| A specialized form of @deleteFirstsBy@ where the predicate is equality under the @Eq@
||| interface.
||| Deletes the first occurrence of each element of the second list from the first list.
|||
||| In the following example, the result is `[2, 4]`.
||| ```idris example
||| [1, 2, 3, 4] // [1, 3]
||| ```
|||
public export
(\\) : (Eq a) => List a -> List a -> List a
(\\) = foldl (flip delete)

||| The unionBy function returns the union of two lists by user-supplied equality predicate.
public export
unionBy : (a -> a -> Bool) -> List a -> List a -> List a
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

||| Compute the union of two lists according to their `Eq` implementation.
|||
||| ```idris example
||| union ['d', 'o', 'g'] ['c', 'o', 'w']
||| ```
|||
public export
union : Eq a => List a -> List a -> List a
union = unionBy (==)

||| Like @span@ but using a predicate that might convert a to b, i.e. given a
||| predicate from a to Maybe b and a list of as, returns a tuple consisting of
||| the longest prefix of the list where a -> Just b, and the rest of the list.
public export
spanBy : (a -> Maybe b) -> List a -> (List b, List a)
spanBy p [] = ([], [])
spanBy p (x :: xs) = case p x of
  Nothing => ([], x :: xs)
  Just y => let (ys, zs) = spanBy p xs in (y :: ys, zs)

||| Given a predicate and a list, returns a tuple consisting of the longest
||| prefix of the list whose elements satisfy the predicate, and the rest of the
||| list.
public export
span : (a -> Bool) -> List a -> (List a, List a)
span p []      = ([], [])
span p (x::xs) =
  if p x then
    let (ys, zs) = span p xs in
        (x::ys, zs)
  else
    ([], x::xs)

public export
break : (a -> Bool) -> List a -> (List a, List a)
break p xs = span (not . p) xs

public export
split : (a -> Bool) -> List a -> List1 (List a)
split p xs =
  case break p xs of
    (chunk, [])          => singleton chunk
    (chunk, (c :: rest)) => chunk ::: forget (split p (assert_smaller xs rest))

public export
splitAt : (n : Nat) -> (xs : List a) -> (List a, List a)
splitAt Z xs = ([], xs)
splitAt (S k) [] = ([], [])
splitAt (S k) (x :: xs)
      = let (tk, dr) = splitAt k xs in
            (x :: tk, dr)

public export
partition : (a -> Bool) -> List a -> (List a, List a)
partition p []      = ([], [])
partition p (x::xs) =
  let (lefts, rights) = partition p xs in
    if p x then
      (x::lefts, rights)
    else
      (lefts, x::rights)

||| The inits function returns all initial segments of the argument, shortest
||| first. For example,
|||
||| ```idris example
||| inits [1,2,3]
||| ```
public export
inits : List a -> List (List a)
inits xs = [] :: case xs of
  []        => []
  x :: xs'  => map (x ::) (inits xs')

||| The tails function returns all final segments of the argument, longest
||| first. For example,
|||
||| ```idris example
||| tails [1,2,3] == [[1,2,3], [2,3], [3], []]
|||```
public export
tails : List a -> List (List a)
tails xs = xs :: case xs of
  []        => []
  _ :: xs'  => tails xs'

||| Split on the given element.
|||
||| ```idris example
||| splitOn 0 [1,0,2,0,0,3]
||| ```
|||
public export
splitOn : Eq a => a -> List a -> List1 (List a)
splitOn a = split (== a)

public export
replaceWhen : (a -> Bool) -> a -> List a -> List a
replaceWhen p b l = map (\c => if p c then b else c) l

||| Replaces all occurences of the first argument with the second argument in a list.
|||
||| ```idris example
||| replaceOn '-' ',' ['1', '-', '2', '-', '3']
||| ```
|||
public export
replaceOn : Eq a => a -> a -> List a -> List a
replaceOn a = replaceWhen (== a)

||| Construct a list with `n` copies of `x`.
||| @ n how many copies
||| @ x the element to replicate
public export
replicate : (n : Nat) -> (x : a) -> List a
replicate Z     _ = []
replicate (S n) x = x :: replicate n x

||| Compute the intersect of two lists by user-supplied equality predicate.
export
intersectBy : (a -> a -> Bool) -> List a -> List a -> List a
intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]

||| Compute the intersect of two lists according to the `Eq` implementation for the elements.
export
intersect : Eq a => List a -> List a -> List a
intersect = intersectBy (==)

export
intersectAllBy : (a -> a -> Bool) -> List (List a) -> List a
intersectAllBy eq [] = []
intersectAllBy eq (xs :: xss) = filter (\x => all (elemBy eq x) xss) xs

export
intersectAll : Eq a => List (List a) -> List a
intersectAll = intersectAllBy (==)

---------------------------
-- Zippable --
---------------------------

public export
Zippable List 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

  unzipWith f [] = ([], [])
  unzipWith f (x :: xs) = let (b, c) = f x
                              (bs, cs) = unzipWith f xs in
                              (b :: bs, c :: cs)

  unzipWith3 f [] = ([], [], [])
  unzipWith3 f (x :: xs) = let (b, c, d) = f x
                               (bs, cs, ds) = unzipWith3 f xs in
                               (b :: bs, c :: cs, d :: ds)

---------------------------
-- Non-empty List
---------------------------

public export
data NonEmpty : (xs : List a) -> Type where
    IsNonEmpty : NonEmpty (x :: xs)

export
Uninhabited (NonEmpty []) where
  uninhabited IsNonEmpty impossible

||| Get the head of a non-empty list.
||| @ ok proof the list is non-empty
public export
head : (l : List a) -> {auto 0 ok : NonEmpty l} -> a
head [] impossible
head (x :: _) = x

||| Get the tail of a non-empty list.
||| @ ok proof the list is non-empty
public export
tail : (l : List a) -> {auto 0 ok : NonEmpty l} -> List a
tail [] impossible
tail (_ :: xs) = xs

||| Retrieve the last element of a non-empty list.
||| @ ok proof that the list is non-empty
public export
last : (l : List a) -> {auto 0 ok : NonEmpty l} -> a
last [] impossible
last [x] = x
last (x :: xs@(_::_)) = last xs

||| Return all but the last element of a non-empty list.
||| @ ok proof the list is non-empty
public export
init : (l : List a) -> {auto 0 ok : NonEmpty l} -> List a
init [] impossible
init [x] = []
init (x :: xs@(_::_)) = x :: init xs

||| Attempt to get the head of a list. If the list is empty, return `Nothing`.
public export
head' : List a -> Maybe a
head' []      = Nothing
head' (x::_) = Just x

||| Attempt to get the tail of a list. If the list is empty, return `Nothing`.
export
tail' : List a -> Maybe (List a)
tail' []      = Nothing
tail' (_::xs) = Just xs

||| Attempt to retrieve the last element of a non-empty list.
|||
||| If the list is empty, return `Nothing`.
export
last' : List a -> Maybe a
last' [] = Nothing
last' xs@(_::_) = Just (last xs)

||| Attempt to return all but the last element of a non-empty list.
|||
||| If the list is empty, return `Nothing`.
export
init' : List a -> Maybe (List a)
init' [] = Nothing
init' xs@(_::_) = Just (init xs)

public export
foldr1By : (func : a -> b -> b) -> (map : a -> b) ->
           (l : List a) -> {auto 0 ok : NonEmpty l} -> b
foldr1By f map [] impossible
foldr1By f map [x] = map x
foldr1By f map (x :: xs@(_::_)) = f x (foldr1By f map xs)

public export
foldl1By : (func : b -> a -> b) -> (map : a -> b) ->
           (l : List a) -> {auto 0 ok : NonEmpty l} -> b
foldl1By f map [] impossible
foldl1By f map (x::xs) = foldl f (map x) xs

||| Foldr a non-empty list without seeding the accumulator.
||| @ ok proof that the list is non-empty
public export
foldr1 : (a -> a -> a) -> (l : List a) -> {auto 0 ok : NonEmpty l} -> a
foldr1 f xs = foldr1By f id xs

||| Foldl a non-empty list without seeding the accumulator.
||| @ ok proof that the list is non-empty
public export
foldl1 : (a -> a -> a) -> (l : List a) -> {auto 0 ok : NonEmpty l} -> a
foldl1 f xs = foldl1By f id xs

||| Convert to a non-empty list.
||| @ ok proof the list is non-empty
export
toList1 : (l : List a) -> {auto 0 ok : NonEmpty l} -> List1 a
toList1 [] impossible
toList1 (x :: xs) = x ::: xs

||| Convert to a non-empty list, returning Nothing if the list is empty.
export
toList1' : (l : List a) -> Maybe (List1 a)
toList1' [] = Nothing
toList1' (x :: xs) = Just (x ::: xs)

||| Prefix every element in the list with the given element
|||
||| ```idris example
||| with List (mergeReplicate '>' ['a', 'b', 'c', 'd', 'e'])
||| ```
|||
export
mergeReplicate : a -> List a -> List a
mergeReplicate sep []      = []
mergeReplicate sep (y::ys) = sep :: y :: mergeReplicate sep ys

||| Insert some separator between the elements of a list.
|||
||| ````idris example
||| with List (intersperse ',' ['a', 'b', 'c', 'd', 'e'])
||| ````
|||
export
intersperse : a -> List a -> List a
intersperse sep []      = []
intersperse sep (x::xs) = x :: mergeReplicate sep xs

||| Given a separator list and some more lists, produce a new list by
||| placing the separator between each of the lists.
|||
||| @ sep the separator
||| @ xss the lists between which the separator will be placed
|||
||| ```idris example
||| intercalate [0, 0, 0] [ [1, 2, 3], [4, 5, 6], [7, 8, 9] ]
||| ```
export
intercalate : (sep : List a) -> (xss : List (List a)) -> List a
intercalate sep xss = concat $ intersperse sep xss

||| Apply a partial function to the elements of a list, keeping the ones at which
||| it is defined.
public export
mapMaybe : (a -> Maybe b) -> List a -> List b
mapMaybe f []      = []
mapMaybe f (x::xs) =
  case f x of
    Nothing => mapMaybe f xs
    Just j  => j :: mapMaybe f xs

||| Extract all of the values contained in a List of Maybes
public export
catMaybes : List (Maybe a) -> List a
catMaybes = mapMaybe id

--------------------------------------------------------------------------------
-- Sorting
--------------------------------------------------------------------------------

||| Check whether a list is sorted with respect to the default ordering for the type of its elements.
export
sorted : Ord a => List a -> Bool
sorted (x :: xs @ (y :: _)) = x <= y && sorted xs
sorted _ = True

||| Merge two sorted lists using an arbitrary comparison
||| predicate. Note that the lists must have been sorted using this
||| predicate already.
export
mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a
mergeBy order []      right   = right
mergeBy order left    []      = left
mergeBy order (x::xs) (y::ys) =
  -- The code below will emit `y` before `x` whenever `x == y`.
  -- If you change this, `sortBy` will stop being stable, unless you fix `sortBy`, too.
  case order x y of
       LT => x :: mergeBy order xs (y::ys)
       _  => y :: mergeBy order (x::xs) ys

||| Merge two sorted lists using the default ordering for the type of their elements.
export
merge : Ord a => List a -> List a -> List a
merge left right = mergeBy compare left right

||| Sort a list using some arbitrary comparison predicate.
|||
||| @ cmp how to compare elements
||| @ xs the list to sort
export
sortBy : (cmp : a -> a -> Ordering) -> (xs : List a) -> List a
sortBy cmp []  = []
sortBy cmp [x] = [x]
sortBy cmp xs  = let (x, y) = split xs in
    mergeBy cmp
          (sortBy cmp (assert_smaller xs x))
          (sortBy cmp (assert_smaller xs y)) -- not structurally smaller, hence assert
  where
    splitRec : List b -> List a -> (List a -> List a) -> (List a, List a)
    splitRec (_::_::xs) (y::ys) zs = splitRec xs ys (zs . ((::) y))
    splitRec _          ys      zs = (ys, zs [])
    -- In the above base-case clause, we put `ys` on the LHS to get a stable sort.
    -- This is because `mergeBy` prefers taking elements from its RHS operand
    -- if both heads are equal, and all elements in `zs []` precede all elements of `ys`
    -- in the original list.

    split : List a -> (List a, List a)
    split xs = splitRec xs xs id

||| Sort a list using the default ordering for the type of its elements.
export
sort : Ord a => List a -> List a
sort = sortBy compare

export
isPrefixOfBy : (eq : a -> a -> Bool) -> (left, right : List a) -> Bool
isPrefixOfBy p [] _            = True
isPrefixOfBy p _ []            = False
isPrefixOfBy p (x::xs) (y::ys) = p x y && isPrefixOfBy p xs ys

||| The isPrefixOf function takes two lists and returns True iff the first list is a prefix of the second.
export
isPrefixOf : Eq a => List a -> List a -> Bool
isPrefixOf = isPrefixOfBy (==)

export
isSuffixOfBy : (a -> a -> Bool) -> List a -> List a -> Bool
isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)

||| The isSuffixOf function takes two lists and returns True iff the first list is a suffix of the second.
export
isSuffixOf : Eq a => List a -> List a -> Bool
isSuffixOf = isSuffixOfBy (==)

||| The isInfixOf function takes two lists and returns True iff the first list
||| is contained, wholly and intact, anywhere within the second.
|||
||| ```idris example
||| isInfixOf ['b','c'] ['a', 'b', 'c', 'd']
||| ```
||| ```idris example
||| isInfixOf ['b','d'] ['a', 'b', 'c', 'd']
||| ```
|||
export
isInfixOf : Eq a => List a -> List a -> Bool
isInfixOf n h = any (isPrefixOf n) (tails h)

||| Transposes rows and columns of a list of lists.
|||
||| ```idris example
||| with List transpose [[1, 2], [3, 4]]
||| ```
|||
||| This also works for non square scenarios, thus
||| involution does not always hold:
|||
|||     transpose [[], [1, 2]] = [[1], [2]]
|||     transpose (transpose [[], [1, 2]]) = [[1, 2]]
export
transpose : List (List a) -> List (List a)
transpose [] = []
transpose (heads :: tails) = spreadHeads heads (transpose tails) where
  spreadHeads : List a -> List (List a) -> List (List a)
  spreadHeads []              tails           = tails
  spreadHeads (head :: heads) []              = [head] :: spreadHeads heads []
  spreadHeads (head :: heads) (tail :: tails) = (head :: tail) :: spreadHeads heads tails

------------------------------------------------------------------------
-- Grouping

||| `groupBy` operates like `group`, but uses the provided equality
||| predicate instead of `==`.
public export
groupBy : (a -> a -> Bool) -> List a -> List (List1 a)
groupBy _ [] = []
groupBy eq (h :: t) = let (ys,zs) = go h t
                       in ys :: zs

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

||| The `group` function takes a list of values and returns a list of
||| lists such that flattening the resulting list is equal to the
||| argument.  Moreover, each list in the resulting list
||| contains only equal elements.
public export
group : Eq a => List a -> List (List1 a)
group = groupBy (==)

||| `groupWith` operates like `group`, but uses the provided projection when
||| comparing for equality
public export
groupWith : Eq b => (a -> b) -> List a -> List (List1 a)
groupWith f = groupBy (\x,y => f x == f y)

||| `groupAllWith` operates like `groupWith`, but sorts the list
||| first so that each equivalence class has, at most, one list in the
||| output
public export
groupAllWith : Ord b => (a -> b) -> List a -> List (List1 a)
groupAllWith f = groupWith f . sortBy (comparing f)

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

export
Uninhabited ([] = x :: xs) where
  uninhabited Refl impossible

export
Uninhabited (x :: xs = []) where
  uninhabited Refl impossible

export
{0 xs : List a} -> Either (Uninhabited $ x === y) (Uninhabited $ xs === ys) => Uninhabited (x::xs = y::ys) where
  uninhabited @{Left  z} Refl = uninhabited @{z} Refl
  uninhabited @{Right z} Refl = uninhabited @{z} Refl

||| (::) is injective
export
consInjective : forall x, xs, y, ys .
                the (List a) (x :: xs) = the (List b) (y :: ys) -> (x = y, xs = ys)
consInjective Refl = (Refl, Refl)

reverseReverseOnto : (l, r : List a) -> reverse (reverseOnto l r) = reverseOnto r l
reverseReverseOnto _ [] = Refl
reverseReverseOnto l (x :: xs) = reverseReverseOnto (x :: l) xs

||| List reverse applied twice yields the identity function.
export
reverseInvolutive : (xs : List a) -> reverse (reverse xs) = xs
reverseInvolutive = reverseReverseOnto []

consReverse : (x : a) -> (l, r : List a) -> x :: reverseOnto r l = reverseOnto r (reverseOnto [x] (reverse l))
consReverse _ [] _ = Refl
consReverse x (y::ys) r
  = rewrite consReverse x ys (y :: r) in
      rewrite cong (reverseOnto r . reverse) $ consReverse x ys [y] in
        rewrite reverseInvolutive (y :: reverseOnto [x] (reverse ys)) in
          Refl

consTailRecAppend : (x : a) -> (l, r : List a) -> tailRecAppend (x :: l) r = x :: (tailRecAppend l r)
consTailRecAppend x l r
  = rewrite consReverse x (reverse l) r in
      rewrite reverseInvolutive l in
        Refl

||| Proof that `(++)` and `tailRecAppend` do the same thing, so the %transform
||| directive is safe.
tailRecAppendIsAppend : (xs, ys : List a) -> tailRecAppend xs ys = xs ++ ys
tailRecAppendIsAppend [] ys = Refl
tailRecAppendIsAppend (x::xs) ys =
  trans (consTailRecAppend x xs ys) (cong (x ::) $ tailRecAppendIsAppend xs ys)

||| The empty list is a right identity for append.
export
appendNilRightNeutral : (l : List a) -> l ++ [] = l
appendNilRightNeutral []      = Refl
appendNilRightNeutral (_::xs) = rewrite appendNilRightNeutral xs in Refl

||| Appending lists is associative.
export
appendAssociative : (l, c, r : List a) -> l ++ (c ++ r) = (l ++ c) ++ r
appendAssociative []      c r = Refl
appendAssociative (_::xs) c r = rewrite appendAssociative xs c r in Refl

revOnto : (xs, vs : List a) -> reverseOnto xs vs = reverse vs ++ xs
revOnto _ [] = Refl
revOnto xs (v :: vs)
    = rewrite revOnto (v :: xs) vs in
        rewrite appendAssociative (reverse vs) [v] xs in
                                  rewrite revOnto [v] vs in Refl

export
revAppend : (vs, ns : List a) -> reverse ns ++ reverse vs = reverse (vs ++ ns)
revAppend [] ns = rewrite appendNilRightNeutral (reverse ns) in Refl
revAppend (v :: vs) ns
    = rewrite revOnto [v] vs in
        rewrite revOnto [v] (vs ++ ns) in
          rewrite sym (revAppend vs ns) in
            rewrite appendAssociative (reverse ns) (reverse vs) [v] in
              Refl

export
dropFusion : (n, m : Nat) -> (l : List t) -> drop n (drop m l) = drop (n+m) l
dropFusion  Z     m    l      = Refl
dropFusion (S n)  Z    l      = rewrite plusZeroRightNeutral n in Refl
dropFusion (S n) (S m) []     = Refl
dropFusion (S n) (S m) (x::l) = rewrite plusAssociative n 1 m in
                                rewrite plusCommutative n 1 in
                                dropFusion (S n) m l

export
lengthMap : (xs : List a) -> length (map f xs) = length xs
lengthMap [] = Refl
lengthMap (x :: xs) = cong S (lengthMap xs)


||| Until Idris2 starts supporting the 'syntax' keyword, here's a
||| poor-man's equational reasoning
module Syntax.PreorderReasoning

infixl 0  ~~
prefix 1  |~
infix  1  ...

|||Slightly nicer syntax for justifying equations:
|||```
||| |~ a
||| ~~ b ...( justification )
|||```
|||and we can think of the `...( justification )` as ASCII art for a thought bubble.
public export
(...) : (x : a) -> (y ~=~ x) -> (z : a ** y ~=~ z)
(...) x pf = (x ** pf)

public export
data FastDerivation : (x : a) -> (y : b) -> Type where
  (|~) : (x : a) -> FastDerivation x x
  (~~) : FastDerivation x y -> (step : (z : c ** y ~=~ z)) -> FastDerivation x (fst step)

public export
Calc : {x : a} -> {y : b} -> FastDerivation x y -> x ~=~ y
Calc (|~ x) = Refl
Calc ((~~) {z=_} {y=_} der (_ ** Refl)) = Calc der

{- -- requires import Data.Nat
0
example : (x : Nat) -> (x + 1) + 0 = 1 + x
example x =
  Calc $
   |~ (x + 1) + 0
   ~~ x+1  ...( plusZeroRightNeutral $ x + 1 )
   ~~ 1+x  ...( plusCommutative x 1          )
-}


||| Projection based on Plain Merge.
|||
||| The POPL '08 Paper /Multi-Party Asynchronous Session Types/.
||| When projecting a =Choice= in which the projected role is not involved,
||| projection occurs when all choices are equal.
module Sessions.Projection.Plain

import Decidable.Equality
import Data.List
import Data.List.Elem

import Data.List1

import Sessions.Meta

import Sessions.Global
import Sessions.Global.Involved

import Sessions.Local
import Sessions.Local.Same
import Sessions.Local.Same.All

import public Sessions.Projection.Error
import public Sessions.Projection

%default total

public export
data Merge : (this  : List1 (typeL, typeM, Local typeR typeL typeM rs g))
          -> (that  :                      Local typeR typeL typeM rs g)
                   -> Type
  where
    PMerge : (same : All ((cl,cm,c):::cs))
                  -> Merge ((cl,cm,c):::cs) c

public export
merge : DecEq typeR typeL typeM
     => (this : List1 (typeL, typeM, Local typeR typeL typeM rs g))
             -> Maybe (that ** Merge this that)
merge ((l,(m,c)) ::: tail) with (allSame ((l,(m,c)) ::: tail))
  merge ((l,(m,c)) ::: tail) | (Yes prf)
    = Just (c ** PMerge prf)
  merge ((l,(m,c)) ::: tail) | (No contra)
    = Nothing

public export
project : DecEq typeR typeL typeM
       => {rs    : List Ty}
       -> {g     :      Ty}
       -> (role  : typeR)
       -> (termG : Global typeR typeL typeM rs g)
                -> Maybe (termL ** Project Merge role termG termL)
project = Projection.Term.project merge

-- [ EOF ]


module NN.Dense

import Backprop
import Control.Optics
import Linear.Backprop
import Linear.V
import Utils.String

public export
record Dense (i : Nat) (o : Nat) (a : Type) where
  constructor MkDense
  weights : T [i, o] a
  biases : T [o] a

export
lweights : Simple Lens (Dense i o a) (T [i, o] a)
lweights = lens weights (\s, b => { weights := b } s)

export
lbiases : Simple Lens (Dense i o a) (T [o] a)
lbiases = lens biases (\s, b => { biases := b } s)

export
{i : _} -> {o : _} -> FromDouble a => FromDouble (Dense i o a) where
  fromDouble x = MkDense (fromDouble x) (fromDouble x)

export
{i : _} -> {o : _} -> CanBack a => CanBack (Dense i o a) where
  zero = MkDense zero zero
  one = MkDense one one
  add x1 x2 = MkDense (add x1.weights x2.weights) (add x1.biases x2.biases)

export
{i : _} -> {o : _} -> Num a => Num (Dense i o a) where
  x1 + x2 = MkDense (x1.weights + x2.weights) (x1.biases + x2.biases)
  x1 * x2 = MkDense (x1.weights * x2.weights) (x1.biases * x2.biases)
  fromInteger x = MkDense (fromInteger x) (fromInteger x)

export
{i : _} -> {o : _} -> Neg a => Neg (Dense i o a) where
  x1 - x2 = MkDense (x1.weights - x2.weights) (x1.biases - x2.biases)
  negate x = MkDense (negate x.weights) (negate x.biases)

export
Show a => Show (Dense i o a) where
  show x = show_record "MkDense" [("weights", show x.weights), ("biases", show x.biases)]

export
apply : {i, o, n, a : _} -> CanBack a => Num a => Node s (Dense i o a) -> Node s (T [n, i] a) -> Node s (T [n, o] a)
apply layer x = x <> (layer ^. lweights) + konst (layer ^. lbiases)


{-
  1. Input: Vect n elem
     Output: Vect n elem
     Operations: Cloning the Vect, replacing the elements of the Vect with random elements.

     Input: Vect n elem
     Output: Vect (n * 2) elem
     Operations: Append a Vect with itself, inserting `n` random elements into the Vect.

     Input: Vect (1 + n) elem
     Output: Vect n elem
     Operations: Popping an element from any position in the Vect.

     Input: Bounded n, Vect n elem
     Output: elem
     Operations: Retrieving the element at index `Bounded n` in the Vect.

-}


module Data.AVL.Core.API

import public Data.Tree
import public Data.AVL.Core

%default total
%access export

namespace AVL
  ||| Find a value in the tree.
  lookup : (Ord k) => k -> AVLTree h k v -> Maybe v
  lookup key (Element t _) = lookup' key t
    where
      lookup' : (Ord k) => k -> Tree k v -> Maybe v
      lookup' key Empty = Nothing
      lookup' key (Node key' value' l r) with (compare key key')
        lookup' key (Node key' value' l r) | LT = lookup' key l
        lookup' key (Node key' value' l r) | EQ = Just value'
        lookup' key (Node key' value' l r) | GT = lookup' key r

  ||| Update an element in the tree.
  update : (Ord k) => k
                   -> (v -> v)
                   -> AVLTree h k v
                   -> AVLTree h k v
  update key f t@(Element Empty inv) = t
  update key f (Element (Node key' value' l r) inv) with (compare key key')
      update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | LT with (assert_total $ update key f (Element l invl)) -- Totality checker again
        update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | LT | (Element l' invl')
                                                             = Element (Node key' value' l' r) (AVLNode invl' invr b)
      update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | EQ
                                                             = Element (Node key' (f value') l r) (AVLNode invl invr b)
      update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | GT with (assert_total $ update key f (Element r invr))
        update key f (Element (Node key' value' l r) (AVLNode invl invr b)) | GT | (Element r' invr')
                                                             = Element (Node key' value' l r') (AVLNode invl invr' b)

  ||| Perform a right fold over the tree.
  foldr : (step : k -> v -> p -> p)
       -> (init : p)
       -> AVLTree n k v
       -> p
  foldr step init (Element t _) = foldr' step init t
    where
      foldr' : (k -> v -> p -> p) -> p -> Tree k v -> p
      foldr' step' init' Empty = init'
      foldr' step' init' (Node key val l r) = foldr' step' (step' key val (foldr' step' init' r)) l

  ||| Construct a AVL Tree from an association list.
  fromList : (Ord k) => List (k, v)
                     -> (n : Nat ** AVLTree n k v)
  fromList [] = (0 ** Element Empty AVLEmpty)
  fromList ((k, v) :: xs) with (doInsert k v (snd (fromList xs)))
    fromList ((k, v) :: xs) | (Same x) = (_ ** x)
    fromList ((k, v) :: xs) | (Grew x) = (_ ** x)

  ||| Flatten the tree to an association list.
  toList : AVLTree n k v -> List (k, v)
  toList = foldr (\k,v,xs => (k, v) :: xs) []

  ||| Is the tree empty?
  isEmpty : AVLTree h k v -> Bool
  isEmpty (Element t _) = isEmpty' t
    where
      isEmpty' : Tree k v -> Bool
      isEmpty' Empty          = True
      isEmpty' (Node _ _ _ _) = False

  ||| Calculate the size of the tree.
  size : AVLTree h k v -> Nat
  size = foldr (\_,_=> S) 0

  ||| Return a list of keys in the tree.
  keys : AVLTree h k v -> List k
  keys = map fst . toList

  ||| Return a list of the values in the key.
  values : AVLTree h k v -> List v
  values = map snd . toList

  ||| Check if the provided check holds for all elements in the tree.
  all : (pred : k -> v -> Bool) ->  AVLTree h k v -> Bool
  all pred = foldr (\k,v,pred' => pred' && pred k v) True

  ||| Check if the provided check holds for at least one element in the tree.
  any : (pred : k -> v -> Bool) ->  AVLTree h k v -> Bool
  any pred = foldr (\k,v,pred' => pred' || pred k v) False

  ||| Does the given key exist in the tree?
  hasKey : (o : Ord k) => k -> AVLTree h k v -> Bool
  hasKey key = any (\key',value' => key == key')

  ||| Does the given value exist in the tree?
  hasValue : (Eq v) => v -> AVLTree h k v -> Bool
  hasValue value = any (\key',value' => value == value')

  ||| Find the first key that satisfies the provided predicate.
  findKey : (pred : v -> Bool) -> AVLTree h k v -> Maybe k
  findKey pred = foldr (\k,v,p => if pred v then Just k else p) Nothing

  ||| Find the key that is associated with provided value.
  findKeyOf : (Eq v) => v -> AVLTree h k v -> Maybe k
  findKeyOf value = findKey (== value)

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

private
eqTree : (Eq k, Eq v) => Tree k v -> Tree k v -> Bool
eqTree Empty              Empty              = True
eqTree (Node xk xv xl xr) (Node yk yv yl yr) =
      xk == yk  &&
      xv == yv  &&
      eqTree xl yl &&
      eqTree xr yr
eqTree _ _                                   = False

(Eq k, Eq v) => Eq (Tree k v) where
  (==) = eqTree

(Eq k, Eq v) => Eq (AVLTree h k v) where
  (==) (Element t _) (Element t' _) = t == t'

(Show k, Show v) => Show (Tree k v) where
  show Empty          = ""
  show (Node k v l r) = unwords
      [
        "{"
      , show l
      , "(", show k, ":", show v, "),"
      , show r
      , "}"
      ]

(Show k, Show v) => Show (AVLTree h k v) where
  show (Element t _) = show t


word_lengths : List String -> List Nat
word_lengths [] = []
word_lengths (word :: words) = length word :: word_lengths words


module Flexidisc.OrdList.Row

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

%default total
%access public export

||| Proof that a key value pair is part of an `OrdList`. If you don't need the value, use `Label`.
data OrdRow : (l : k) -> (ty : v) -> OrdList k o v -> Type where
  ||| The label is in the first element of the list
  Here  :                             OrdRow l ty ((l, ty) :: xs)
  ||| The label is in the tail
  There : (later : OrdRow l ty xs) -> OrdRow l ty (x::xs)

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

||| Demote it to a label existence proof
labelFromOrdRow : OrdRow l v xs -> OrdLabel l xs
labelFromOrdRow Here          = Here
labelFromOrdRow (There later) = There (labelFromOrdRow later)

Uninhabited (OrdRow k v []) where
  uninhabited Here      impossible
  uninhabited (There _) impossible

||| Map a row and its header simultaneously
mapRow : {xs : OrdList k o a} -> (f : a -> b) -> (loc : OrdRow l ty xs) -> OrdRow l (f ty) (map f xs)
mapRow f loc {xs = []} = absurd loc
mapRow f Here {xs = ((k, x) :: xs)} = Here
mapRow f (There later) {xs = ((k, x) :: xs)} = There (mapRow f later)

||| Given a proof that an element is in a vector, remove it
dropOrdRow : (xs : OrdList k o v) -> (loc : OrdRow l ty xs) -> OrdList k o v
dropOrdRow xs = dropLabel xs . labelFromOrdRow

||| Update a value in the list given it's location and an update function
changeValue : (xs : OrdList k o v) -> (loc : OrdRow l old xs) -> (new : v) ->
             OrdList k o v
changeValue xs loc new = changeValue xs (labelFromOrdRow loc) new

changeWithSameTypeIsUnchanged : (row : OrdRow l x xs) -> changeValue xs row x = xs
changeWithSameTypeIsUnchanged Here = Refl
changeWithSameTypeIsUnchanged (There later) = cong $ changeWithSameTypeIsUnchanged later

findInsertOrdRow : (l : k) -> (xs : OrdList k o v) -> OrdRow l ty (insert (l,ty) xs)
findInsertOrdRow l [] = Here
findInsertOrdRow l ((kx, vx) :: xs) with (l < kx)
  | True  = Here
  | False = There (findInsertOrdRow l xs)

dropInsertInv : (l : k) -> (ty : v) -> (xs : OrdList k o v) ->
                dropOrdRow (insert (l, ty) xs) (findInsertOrdRow l xs) = xs
dropInsertInv l ty [] = Refl
dropInsertInv l ty ((kx,vx) :: xs) with (l < kx)
  | True  = Refl
  | False = cong (dropInsertInv l ty xs)


-- --------------------------------------------------------------- [ Nonce.idr ]
-- Module      : Nonce
-- Description : Types for Nonces
-- Copyright   : (c) Jan de Muijnck-Hughes
-- License     : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
module Crypto.Nonce

import Crypto.Common

data TyNonce = Zero | Random

||| Nonces for guaranteeing freshness.
|||
||| @ s The setting.
||| @ tyN The nonce type.
||| @ l The length.
data Nonce : (s : Setting) -> (tyN : TyNonce) -> (l : Nat) -> Type where
  ||| The all zero nonce for asymmetric encryption.
  MkZeroPkNonce : Vect n a -> Nonce Asymm Zero n
  ||| A randomly generated nonce for asymmetric encryption.
  MkRndPkNonce  : Vect n a -> Nonce Asymm Random n

  ||| The all zero nonce for symmetric encryption.
  MkZeroSkNonce : Vect n a -> Nonce Symm Zero n
  ||| A randomly generated nonce for symmetric encryption.
  MkRndSkNonce  : Vect n a -> Nonce Symm Random n

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


> module Functor.tests.Main

> import Control.Monad.Identity

> import Functor.Operations
> import Identity.Properties

> %default total
> %auto_implicits off

> b : Bool
> b = elem Z (Id Z)

> B : Type
> B = Elem (S Z) (Id Z)

> b' : Bool
> b' = decAsBool (decElem (S Z) (Id Z))

> main : IO ()
> main = do putStrLn ("b  = " ++ show b)
>           putStrLn ("b' = " ++ show b')


module Examples.ConferenceLattice

import public DepSec.Lattice
import Decidable.Equality
import Pruviloj.Derive.DecEq
import Pruviloj.Disjoint
import Pruviloj.Injective

%language ElabReflection
%access public export

data Id : Type where
  Top : Id
  Nat : Nat -> Id
  Bot : Id

Uid : Type
Uid = Id

Sid : Type
Sid = Id

natInjective : (Nat a) = (Nat b) -> a = b
natInjective Refl = Refl

DecEq Id where
  decEq Top Top = Yes Refl
  decEq Top (Nat k) = No (%runElab disjoint)
  decEq Top Bot = No (%runElab disjoint)
  decEq (Nat k) Top = No (%runElab disjoint)
  decEq (Nat k) (Nat j) with (decEq k j)
    | (Yes prf) = Yes $ cong prf
    | (No contra) = No $ \a => contra $ natInjective a
  decEq (Nat k) Bot = No (%runElab disjoint)
  decEq Bot Top = No (%runElab disjoint)
  decEq Bot (Nat k) = No (%runElab disjoint)
  decEq Bot Bot = Yes Refl

Eq Id where
  Top == Top         = True
  Top == (Nat k)     = False
  Top == Bot         = False
  (Nat k) == Top     = False
  (Nat k) == (Nat j) = k == j
  (Nat k) == Bot     = False
  Bot == Top         = False
  Bot == (Nat k)     = False
  Bot == Bot         = True

data Compartment : Type where
  U  : Uid -> Compartment
  A  : Uid -> Sid -> Compartment
  PC : Uid -> Sid -> Compartment

total
joinId : (x, y : Id) -> Id
joinId Top y = Top
joinId (Nat k) Top = Top
joinId (Nat k) (Nat j) with (decEq k j)
  | (Yes _) = Nat k
  | (No _) = Top
joinId (Nat k) Bot = (Nat k)
joinId Bot y = y

total
joinComp : (x , y : Compartment) -> Compartment
joinComp (U x) (U y) = U (joinId x y)
joinComp (U x) (A y z) = A (joinId x y) z
joinComp (U x) (PC y z) = PC y z
joinComp (A x z) (U y) = A (joinId x y) z
joinComp (A x z) (A y w) = A (joinId x y) (joinId z w)
joinComp (A x z) (PC y w) = PC y (joinId z w)
joinComp (PC x z) (U y) = PC x z
joinComp (PC x z) (A y w) = PC x (joinId z w)
joinComp (PC x z) (PC y w) = PC (joinId x y) (joinId z w)

lemma1 : a = b -> joinId (Nat a) (Nat b) = (Nat a)
lemma1 {a} {b} prf with (decEq a b)
  | (Yes x) = Refl
  | (No contra) = void $ contra prf

lemma2 : (a = b -> Void) -> joinId (Nat a) (Nat b) = Top
lemma2 {a} {b} contra with (decEq a b)
  | (Yes prf) = void $ contra prf
  | (No f) = Refl

lemma3 : a = b -> (b = c -> Void) -> a = c -> Void
lemma3 prf contra prf' = contra $ trans (sym prf) prf'

implementation JoinSemilattice Id where
  join = joinId
  associative Top y z = Refl
  associative (Nat k) Top z = Refl
  associative (Nat k) (Nat j) Top with (decEq k j)
    | (Yes prf) = Refl
    | (No contra) = Refl
  associative (Nat k) (Nat j) (Nat i) with (decEq k j, decEq j i)
    | (Yes prf, Yes prf') =
        rewrite lemma1 prf in
        rewrite lemma1 prf' in
        rewrite lemma1 (trans prf prf') in
        lemma1 prf
    | (Yes prf, No contra) =
        rewrite lemma1 prf in
        rewrite lemma2 contra in
        rewrite lemma2 $ lemma3 prf contra in
        Refl
    | (No contra, Yes prf) =
        rewrite lemma2 contra in
        rewrite lemma1 prf in
        lemma2 contra
    | (No contra, No contra') =
        rewrite lemma2 contra in
        rewrite lemma2 contra' in
        Refl
  associative (Nat k) (Nat j) Bot with (decEq k j)
    | (Yes _) = Refl
    | (No _) = Refl
  associative (Nat k) Bot z = Refl
  associative Bot y z = Refl

  commutative Top Top = Refl
  commutative Top (Nat k) = Refl
  commutative Top Bot = Refl
  commutative (Nat k) Top = Refl
  commutative (Nat k) (Nat j) with (decEq k j)
    | (Yes prf) = rewrite lemma1 $ sym prf in cong prf
    | (No contra) = sym $ lemma2 $ negEqSym contra
  commutative (Nat k) Bot = Refl
  commutative Bot Top = Refl
  commutative Bot (Nat k) = Refl
  commutative Bot Bot = Refl

  idempotent Top = Refl
  idempotent (Nat k) with (decEq k k)
    | (Yes _) = Refl
    | (No contra) = void $ contra Refl
  idempotent Bot = Refl

implementation BoundedJoinSemilattice Id where
  Bottom = Bot

  unitary Top = Refl
  unitary (Nat k) = Refl
  unitary Bot = Refl

implementation JoinSemilattice Compartment where
  join = joinComp

  associative (U x) (U y) (U z) = cong $ associative x y z
  associative (U x) (U y) (A z w) = rewrite associative x y z in Refl
  associative (U x) (U y) (PC z w) = Refl
  associative (U x) (A y w) (U z) = rewrite associative x y z in Refl
  associative (U x) (A y w) (A z s) = rewrite associative x y z in Refl
  associative (U x) (A y w) (PC z s) = Refl
  associative (U x) (PC y w) (U z) = Refl
  associative (U x) (PC y w) (A z s) = Refl
  associative (U x) (PC y w) (PC z s) = Refl
  associative (A x w) (U y) (U z) = rewrite associative x y z in Refl
  associative (A x w) (U y) (A z s) = rewrite associative x y z in Refl
  associative (A x w) (U y) (PC z s) = Refl
  associative (A x w) (A y s) (U z) = rewrite associative x y z in Refl
  associative (A x w) (A y s) (A z t) =
    rewrite associative x y z in
    rewrite associative w s t in Refl
  associative (A x w) (A y s) (PC z t) = rewrite associative w s t in Refl
  associative (A x w) (PC y s) (U z) = Refl
  associative (A x w) (PC y s) (A z t) = rewrite associative w s t in Refl
  associative (A x w) (PC y s) (PC z t) = rewrite associative w s t in Refl
  associative (PC x w) (U y) (U z) = Refl
  associative (PC x w) (U y) (A z s) = Refl
  associative (PC x w) (U y) (PC z s) = Refl
  associative (PC x w) (A y s) (U z) = Refl
  associative (PC x w) (A y s) (A z t) = rewrite associative w s t in Refl
  associative (PC x w) (A y s) (PC z t) = rewrite associative w s t in Refl
  associative (PC x w) (PC y s) (U z) = Refl
  associative (PC x w) (PC y s) (A z t) = rewrite associative w s t in Refl
  associative (PC x w) (PC y s) (PC z t) =
    rewrite associative x y z in
    rewrite associative w s t in Refl

  commutative (U x) (U y) = cong $ commutative x y
  commutative (U x) (A y z) = rewrite commutative x y in Refl
  commutative (U x) (PC y z) = Refl
  commutative (A x z) (U y) = rewrite commutative x y in Refl
  commutative (A x z) (A y w) =
    rewrite commutative x y in
    rewrite commutative z w in
    Refl
  commutative (A x z) (PC y w) = rewrite commutative w z in Refl
  commutative (PC x z) (U y) = Refl
  commutative (PC x z) (A y w) = rewrite commutative z w in Refl
  commutative (PC x z) (PC y w) =
    rewrite commutative x y in
    rewrite commutative z w in
    Refl

  idempotent (U x) = cong $ idempotent x
  idempotent (A x y) =
     rewrite idempotent x in
     rewrite idempotent y in
     Refl
  idempotent (PC x y) =
     rewrite idempotent x in
     rewrite idempotent y in
     Refl

implementation BoundedJoinSemilattice Compartment where
  Bottom = U Bot

  unitary (U x) = cong $ unitary x
  unitary (A x y) = rewrite unitary x in Refl
  unitary (PC x y) = Refl

--------------------------------------------------------------------------------
-- Lemmas
--------------------------------------------------------------------------------
U_leq_A : U uid `leq` A uid sid
U_leq_A {uid} = rewrite reflexive uid in Refl

A_leq_PC : A uid1 sid `leq` PC uid2 sid
A_leq_PC {sid} = rewrite reflexive sid in Refl


module Mem

import Data.Vect

-- Effectively (size : Nat ** Vect size a)
record Region a where
  constructor MkRegion
  regionSize : Nat
  regionData : Vect regionSize a

-- Effectively (regs : Nat ** Vect regs (Region a))
record RegionsOfType a where
  constructor MkRegOfType
  regionCnt : Nat
  regionsOfType : Vect regs $ Region a

record Memory where
  constructor MkMemReg
  regionsByType : (a : Type) -> RegionsOfType a

record Pointer where
  constructor MkPointer
  type : Type
  regionNum : Nat
  idxInRegion : Nat

data CorrectPointer : Pointer -> Memory -> Type where


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

import Data.Morphisms

-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.
public export
data Yoneda : ( f : Type -> Type ) -> ( a : Type ) -> Type where
  MkYoneda : ({0 b : Type} -> (a -> b) -> f b) -> Yoneda f a

-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma
-- is witnessed by 'liftYoneda' and 'lowerYoneda'
--
-- @
-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'
-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'
-- @
--
-- @
-- lowerYoneda (liftYoneda fa) =         -- definition
-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition
-- (\f -> fmap f fa) id                  -- beta reduction
-- fmap id fa                            -- functor law
-- fa
-- @
--
-- @
-- 'lift' = 'liftYoneda'
-- @
public export
liftYoneda : { f : Type -> Type } -> Functor f => f a -> Yoneda f a
liftYoneda a = MkYoneda (flip map a)

public export
lowerYoneda : {0 a : Type} -> Yoneda f a -> f a
lowerYoneda (MkYoneda f) = f id

public export
implementation Functor f => Functor (Yoneda f) where
  map h (MkYoneda k) = MkYoneda (flip map (k h))

public export
implementation Applicative f => Applicative (Yoneda f) where
  pure a = MkYoneda (\f => pure (f a))
  (MkYoneda m) <*> (MkYoneda n) = MkYoneda (\f => m (f .) <*> n id)


myfib : Integer -> Integer
myfib 0 = 1
myfib 1 = 1
myfib n = myfib (n - 1) + myfib (n - 2)

main : IO ()
main = putStrLn $ show $ myfib 40


module Solutions.Functions1

--------------------------------------------------------------------------------
--          Exercise 1
--------------------------------------------------------------------------------

square : Integer -> Integer
square n = n * n

testSquare : (Integer -> Bool) -> Integer -> Bool
testSquare fun = fun . square

twice : (Integer -> Integer) -> Integer -> Integer
twice f = f . f

--------------------------------------------------------------------------------
--          Exercise 2
--------------------------------------------------------------------------------

isEven : Integer -> Bool
isEven n = (n `mod` 2) == 0

isOdd : Integer -> Bool
isOdd = not . isEven

--------------------------------------------------------------------------------
--          Exercise 3
--------------------------------------------------------------------------------

isSquareOf : Integer -> Integer -> Bool
isSquareOf n x = n == x * x

--------------------------------------------------------------------------------
--          Exercise 4
--------------------------------------------------------------------------------

isSmall : Integer -> Bool
isSmall n = n <= 100

--------------------------------------------------------------------------------
--          Exercise 5
--------------------------------------------------------------------------------

absIsSmall : Integer -> Bool
absIsSmall = isSmall . abs

--------------------------------------------------------------------------------
--          Exercise 6
--------------------------------------------------------------------------------

and : (Integer -> Bool) -> (Integer -> Bool) -> Integer -> Bool
and f1 f2 n = f1 n && f2 n

or : (Integer -> Bool) -> (Integer -> Bool) -> Integer -> Bool
or f1 f2 n = f1 n || f2 n

negate : (Integer -> Bool) -> Integer -> Bool
negate f = not . f

--------------------------------------------------------------------------------
--          Exercise 7
--------------------------------------------------------------------------------

(&&) : (Integer -> Bool) -> (Integer -> Bool) -> Integer -> Bool
(&&) = and

(||) : (Integer -> Bool) -> (Integer -> Bool) -> Integer -> Bool
(||) = or

not : (Integer -> Bool) -> Integer -> Bool
not = negate


> module Interfaces.Math

> %default total
> %access public export
> %auto_implicits off

> interface (Num ty) => Math ty where
>   exp : ty -> ty
>   sin : ty -> ty
>   cos : ty -> ty


module Inputs
import Data.Primitives.Views

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

public export
arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
  where
    bound : Int -> Int
    bound num with (divides num 12)
      bound ((12 * div) + rem) | (DivBy prf) = rem + 1


module LinearTypes

import Data.Vect

infixr 10 ::
infix 5 #

%default total

public export
data LFstPair : Type -> Type -> Type where
  (#) : (1 _ : a) -> b -> LFstPair a b

public export
data LVect : Nat -> Type ->  Type where
  Nil : LVect Z a
  (::) : (1 _ : a) -> (1 _ : LVect k a) -> LVect (S k) a

public export
Show a => Show (LVect n a) where
  show v = "[" ++ show' v ++ "]" where
    show' :  LVect k a -> String
    show' Nil = ""
    show' [x] = show x
    show' (x :: xs) = show x ++ " , " ++ show' xs

public export
(Show a, Show b) => Show (LPair a b) where
  show ( a # b ) = "( " ++ show a ++ " # " ++ show b ++ " )"

public export
(Show a, Show b) => Show (LFstPair a b) where
  show ( a # b ) = "( " ++ show a ++ " # " ++ show b ++ " )"

public export
(++) : (1 xs : LVect m a) -> (1 ys : LVect n a) -> LVect (m + n) a
(++) []      ys = ys
(++) (x::xs) ys = x :: (xs ++ ys)

public export
splitAt : {n : Nat} -> (i : Nat) -> (1 xs : LVect (i+n) a) -> LPair (LVect i a) (LVect n a)
splitAt 0 xs            = [] # xs
splitAt (S k) (x :: xs) = let ys # zs = LinearTypes.splitAt k xs in
                              (x :: ys) # zs

||| diff n i = n - i
public export
diff : Nat -> Nat -> Nat
diff Z     n = Z
diff (S k) n = S (diff k n)

export
lemmaDiffZero : (n : Nat) -> diff n 0 = n
lemmaDiffZero 0 = Refl
lemmaDiffZero (S k) = rewrite lemmaDiffZero k in Refl

public export
consLin : (1 _ : Bool) -> (1 _ : Vect n Bool) -> Vect (S n) Bool
consLin False [] = [False]
consLin False (x :: xs) = False :: x :: xs
consLin True [] = [True]
consLin True (x :: xs) = True :: x :: xs

public export
toVect : (1 _ : LVect n Bool) -> Vect n Bool
toVect [] = []
toVect (x :: xs) = x `consLin` (toVect xs)


module Data.SortedMap.Extra

import Data.SortedMap
import Data.List

export
filter : Ord k => (k -> v -> Bool) -> SortedMap k v -> SortedMap k v
filter pred = fromList . filter (uncurry pred) . toList

export
size : Foldable t => t a -> Nat
size = foldr (\_ => (+ 1)) 0


module Main

import Data.List

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

Show a => Show (Tree a) where
  show Empty = "Empty"
  show (Node left val right) = "(Node " ++ show left ++ " " ++ show val ++ " " ++ show right ++ ")"

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

flatten : Tree a -> List a
flatten Empty = []
flatten (Node left val right) = flatten left ++ val :: flatten right

treeLabelWith
  : Stream labelType
  -> Tree a
  -> (Stream labelType, Tree (labelType, a))
treeLabelWith lbls Empty = (lbls, Empty)
treeLabelWith lbls (Node left val right)
  = let (lblThis :: lblsLeft, leftLabelled) = treeLabelWith lbls left
        (lblRight, rightLabelled) = treeLabelWith lblsLeft right
    in (lblRight, Node leftLabelled (lblThis, val) rightLabelled)

treeLabel : Tree a -> Tree (Integer, a)
treeLabel tree = snd (treeLabelWith [1..] tree)

main : IO ()
main = do
  printLn $ flatten testTree
  printLn $ flatten $ treeLabel testTree


-- Tests bitwise ops for the different data types
--
-- The tests in `idris2/basic055`, `chez/chez032` and `node/node024` are the
-- same and should all have the same output.

import Data.Stream

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

shl1 : Int -> Int
shl1 = prim__shl_Int 1

b8max : Bits8
b8max = 0xff

b16max : Bits16
b16max = 0xffff

b32max : Bits32
b32max = 0xffffffff

b64max : Bits64
b64max = 18446744073709551615

-- the only way to create -2^31
intmin : Int
intmin = shl1 31

intmax : Int
intmax = 0x7fffffff

powsOf2 : Num a => Nat -> List a
powsOf2 n = take n (iterate (*2) 1)

--------------------------------------------------------------------------------
--          shiftR
--------------------------------------------------------------------------------

shiftRBits8 : List Bits8
shiftRBits8 = map (`prim__shr_Bits8` 1) (powsOf2 8 ++ [b8max])

shiftRBits16 : List Bits16
shiftRBits16 = map (`prim__shr_Bits16` 1) (powsOf2 16 ++ [b16max])

shiftRBits32 : List Bits32
shiftRBits32 = map (`prim__shr_Bits32` 1) (powsOf2 32 ++ [b32max])

shiftRBits64 : List Bits64
shiftRBits64 = map (`prim__shr_Bits64` 1) (powsOf2 64 ++ [b64max])

shiftRInteger : List Integer
shiftRInteger = map (`prim__shr_Integer` 1) (powsOf2 128)

shiftRInt : List Int
shiftRInt = map (`prim__shr_Int` 1) (powsOf2 31 ++ [intmax])

shiftRNegativeInt : List Int
shiftRNegativeInt = map (`prim__shr_Int` 1) (map negate (powsOf2 31) ++ [intmin])

--------------------------------------------------------------------------------
--          shiftL
--------------------------------------------------------------------------------

shiftLBits8 : List Bits8
shiftLBits8 = map (`prim__shl_Bits8` 1) (0 :: powsOf2 7)

shiftLBits16 : List Bits16
shiftLBits16 = map (`prim__shl_Bits16` 1) (0 :: powsOf2 15)

shiftLBits32 : List Bits32
shiftLBits32 = map (`prim__shl_Bits32` 1) (0 :: powsOf2 31)

shiftLBits64 : List Bits64
shiftLBits64 = map (`prim__shl_Bits64` 1) (0 :: powsOf2 63)

shiftLInteger : List Integer
shiftLInteger = map (`prim__shl_Integer` 1) (0 :: powsOf2 127)

shiftLInt : List Int
shiftLInt = map (`prim__shl_Int` 1) (0 :: powsOf2 30)

shiftLNegativeInt : List Int
shiftLNegativeInt = map (`prim__shl_Int` 1) (map negate (powsOf2 30))

--------------------------------------------------------------------------------
--          Bitwise AND
--------------------------------------------------------------------------------

andBits8 : List Bits8
andBits8 = [ prim__and_Bits8 11 b8max
           , prim__and_Bits8 11 0
           , prim__and_Bits8 11 1
           , prim__and_Bits8 11 2
           , prim__and_Bits8 11 4
           , prim__and_Bits8 11 11
           ]

andBits16 : List Bits16
andBits16 = [ prim__and_Bits16 11 b16max
            , prim__and_Bits16 11 0
            , prim__and_Bits16 11 1
            , prim__and_Bits16 11 2
            , prim__and_Bits16 11 4
            , prim__and_Bits16 11 11
            ]

andBits32 : List Bits32
andBits32 = [ prim__and_Bits32 11 b32max
            , prim__and_Bits32 11 0
            , prim__and_Bits32 11 1
            , prim__and_Bits32 11 2
            , prim__and_Bits32 11 4
            , prim__and_Bits32 11 11
            ]

andBits64 : List Bits64
andBits64 = [ prim__and_Bits64 11 b64max
            , prim__and_Bits64 11 0
            , prim__and_Bits64 11 1
            , prim__and_Bits64 11 2
            , prim__and_Bits64 11 4
            , prim__and_Bits64 11 11
            ]

andInteger : List Integer
andInteger = [ prim__and_Integer 11 (prim__shl_Integer 1 128 - 1)
             , prim__and_Integer 11 0
             , prim__and_Integer 11 1
             , prim__and_Integer 11 2
             , prim__and_Integer 11 4
             , prim__and_Integer 11 11
             ]

andInt : List Int
andInt = [ prim__and_Int 11 intmax
         , prim__and_Int 11 0
         , prim__and_Int 11 1
         , prim__and_Int 11 2
         , prim__and_Int 11 4
         , prim__and_Int 11 11
         ]

andNegativeInt : List Int
andNegativeInt = [ prim__and_Int (-11) intmax
                 , prim__and_Int (-11) 0
                 , prim__and_Int (-11) 1
                 , prim__and_Int (-11) 2
                 , prim__and_Int (-11) 4
                 , prim__and_Int (-11) 11
                 , prim__and_Int (-11) intmin
                 , prim__and_Int (-11) (-1)
                 , prim__and_Int (-11) (-2)
                 , prim__and_Int (-11) (-4)
                 , prim__and_Int (-11) (-11)
                 ]

--------------------------------------------------------------------------------
--          Bitwise OR
--------------------------------------------------------------------------------

orBits8 : List Bits8
orBits8 = [ prim__or_Bits8 11 b8max
          , prim__or_Bits8 11 0
          , prim__or_Bits8 11 1
          , prim__or_Bits8 11 2
          , prim__or_Bits8 11 4
          , prim__or_Bits8 11 11
          ]

orBits16 : List Bits16
orBits16 = [ prim__or_Bits16 11 b16max
           , prim__or_Bits16 11 0
           , prim__or_Bits16 11 1
           , prim__or_Bits16 11 2
           , prim__or_Bits16 11 4
           , prim__or_Bits16 11 11
           ]

orBits32 : List Bits32
orBits32 = [ prim__or_Bits32 11 b32max
           , prim__or_Bits32 11 0
           , prim__or_Bits32 11 1
           , prim__or_Bits32 11 2
           , prim__or_Bits32 11 4
           , prim__or_Bits32 11 11
           ]

orBits64 : List Bits64
orBits64 = [ prim__or_Bits64 11 b64max
           , prim__or_Bits64 11 0
           , prim__or_Bits64 11 1
           , prim__or_Bits64 11 2
           , prim__or_Bits64 11 4
           , prim__or_Bits64 11 11
           ]

orInteger : List Integer
orInteger = [ prim__or_Integer 11 (prim__shl_Integer 1 128 - 1)
            , prim__or_Integer 11 0
            , prim__or_Integer 11 1
            , prim__or_Integer 11 2
            , prim__or_Integer 11 4
            , prim__or_Integer 11 11
            ]

orInt : List Int
orInt = [ prim__or_Int 11 intmax
        , prim__or_Int 11 0
        , prim__or_Int 11 1
        , prim__or_Int 11 2
        , prim__or_Int 11 4
        , prim__or_Int 11 11
        ]

orNegativeInt : List Int
orNegativeInt = [ prim__or_Int (-11) intmax
                , prim__or_Int (-11) 0
                , prim__or_Int (-11) 1
                , prim__or_Int (-11) 2
                , prim__or_Int (-11) 4
                , prim__or_Int (-11) 11
                , prim__or_Int (-11) intmin
                , prim__or_Int (-11) (-1)
                , prim__or_Int (-11) (-2)
                , prim__or_Int (-11) (-4)
                , prim__or_Int (-11) (-11)
                ]

--------------------------------------------------------------------------------
--          Bitwise XOR
--------------------------------------------------------------------------------

xorBits8 : List Bits8
xorBits8 = [ prim__xor_Bits8 11 b8max
           , prim__xor_Bits8 11 0
           , prim__xor_Bits8 11 1
           , prim__xor_Bits8 11 2
           , prim__xor_Bits8 11 4
           , prim__xor_Bits8 11 11
           ]

xorBits16 : List Bits16
xorBits16 = [ prim__xor_Bits16 11 b16max
            , prim__xor_Bits16 11 0
            , prim__xor_Bits16 11 1
            , prim__xor_Bits16 11 2
            , prim__xor_Bits16 11 4
            , prim__xor_Bits16 11 11
            ]

xorBits32 : List Bits32
xorBits32 = [ prim__xor_Bits32 11 b32max
            , prim__xor_Bits32 11 0
            , prim__xor_Bits32 11 1
            , prim__xor_Bits32 11 2
            , prim__xor_Bits32 11 4
            , prim__xor_Bits32 11 11
            ]

xorBits64 : List Bits64
xorBits64 = [ prim__xor_Bits64 11 b64max
            , prim__xor_Bits64 11 0
            , prim__xor_Bits64 11 1
            , prim__xor_Bits64 11 2
            , prim__xor_Bits64 11 4
            , prim__xor_Bits64 11 11
            ]

xorInteger : List Integer
xorInteger = [ prim__xor_Integer 11 (prim__shl_Integer 1 128 - 1)
             , prim__xor_Integer 11 0
             , prim__xor_Integer 11 1
             , prim__xor_Integer 11 2
             , prim__xor_Integer 11 4
             , prim__xor_Integer 11 11
             ]

xorInt : List Int
xorInt = [ prim__xor_Int 11 intmax
         , prim__xor_Int 11 0
         , prim__xor_Int 11 1
         , prim__xor_Int 11 2
         , prim__xor_Int 11 4
         , prim__xor_Int 11 11
         ]

xorNegativeInt : List Int
xorNegativeInt = [ prim__xor_Int (-11) intmax
                 , prim__xor_Int (-11) 0
                 , prim__xor_Int (-11) 1
                 , prim__xor_Int (-11) 2
                 , prim__xor_Int (-11) 4
                 , prim__xor_Int (-11) 11
                 , prim__xor_Int (-11) intmin
                 , prim__xor_Int (-11) (-1)
                 , prim__xor_Int (-11) (-2)
                 , prim__xor_Int (-11) (-4)
                 , prim__xor_Int (-11) (-11)
                 ]

--------------------------------------------------------------------------------
--          Running Tests
--------------------------------------------------------------------------------

main : IO ()
main = do printLn intmin

          putStrLn ""

          printLn shiftRBits8
          printLn shiftRBits16
          printLn shiftRBits32
          printLn shiftRBits64
          printLn shiftRInteger
          printLn shiftRInt
          printLn shiftRNegativeInt

          putStrLn ""

          printLn shiftLBits8
          printLn shiftLBits16
          printLn shiftLBits32
          printLn shiftLBits64
          printLn shiftLInteger
          printLn shiftLInt
          printLn shiftLNegativeInt

          putStrLn ""

          printLn andBits8
          printLn andBits16
          printLn andBits32
          printLn andBits64
          printLn andInteger
          printLn andInt
          printLn andNegativeInt

          putStrLn ""

          printLn orBits8
          printLn orBits16
          printLn orBits32
          printLn orBits64
          printLn orInteger
          printLn orInt
          printLn orNegativeInt

          putStrLn ""

          printLn xorBits8
          printLn xorBits16
          printLn xorBits32
          printLn xorBits64
          printLn xorInteger
          printLn xorInt
          printLn xorNegativeInt


module ReadNum

import Data.Strings

%default total

readNumber : HasIO io => io (Maybe Nat)
readNumber = do n <- getLine
                if all isDigit (unpack n)
                   then pure $ Just (stringToNatOrZ n)
                   else pure Nothing

readNumbers : HasIO io => io (Maybe (Nat, Nat))
readNumbers = do m <- readNumber
                 case m of
                      Nothing => pure Nothing
                      Just mm => do n <- readNumber
                                    case n of
                                         Nothing => pure Nothing
                                         Just nn => pure $ Just (mm, nn)

-- pattern-matched destucturing

readNumbersImproved : HasIO io => io (Maybe (Nat, Nat))
readNumbersImproved = do Just m <- readNumber | Nothing => pure Nothing
                         Just n <- readNumber | Nothing => pure Nothing
                         pure $ Just (m, n)


module NanoParsec.Combinators

import NanoParsec.Parser
import Data.String

%access export

oneOf : List Char -> Parser Char
oneOf st = satisfy (flip elem st)

chainl1 : Parser a -> Parser (a -> a -> a) -> Parser a
chainl1 p op = do { a <- p; rest a }
    where
        rest a = (do f <- op
                     b <- p
                     rest (f a b))
                <|> return a

chainl : Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op a = (chainl1 p op) <|> return a

char : Char -> Parser Char
char ch = satisfy (ch ==)

digit : Parser Char
digit = satisfy isDigit

spaces : Parser String
spaces = pack <$> (many . oneOf . unpack $ " \n\r")

string : String -> Parser String
string st = pack <$> (string' $ unpack st)
    where
        string' : List Char -> Parser (List Char)
        string' [] = return []
        string' (c :: cs) = char c
                          >>= \_ => string' cs
                          >>= \_ => return (c :: cs)

token : Parser a -> Parser a
token p = p >>= \a => spaces >>= \_ => return a

reserved : String -> Parser String
reserved st = token (string st)

maybeNatural : Parser (Maybe Integer)
maybeNatural = parseInteger <$> (pack <$> some digit)

natural : Parser Integer
natural = fromMaybe <$> maybeNatural

maybeNumber : Parser (Maybe Int)
maybeNumber = do
    sign   <- (unpack <$> string "-") <|> return []
    digits <- some digit
    return $ parseInteger $ pack (sign ++ digits)

number : Parser Int
number = fromMaybe <$> maybeNumber

parens : Parser a -> Parser a
parens p = do
    reserved "("
    val <- p
    reserved ")"
    return val