module Module

import Monoid
import Group
import Ring
import Group_property
import NatUtils

--(modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) ->
-- ((*) : ring -> ring -> ring) -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
--This just the data required for a module, the set modu and a ring. So, this big chunk of code will appear everywhere

|||Type of operation between a ring and a moduule that distributes over addition of the ring
total
dotDistributesOverRing : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring)
                          -> ((*) : ring -> ring -> ring) -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotDistributesOverRing modu ring (+) (++) (*) prfRing (.) = (r : ring) -> (s : ring) -> (m : modu) -> ((r ++ s) . m = (r . m) + (s . m))

|||Type of operation between a ring and a moduuule that distributes over addition of the Module
total
dotDistributesOverModule : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring)
                            -> ((*) : ring -> ring -> ring) -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotDistributesOverModule modu ring (+) (++) (*) prfRing (.) = (m : modu) -> (n : modu) -> (r : ring) -> (r . (m + n) = (r . m) + (r . n))

|||Type of operation that respects ring multiplication
total
dotRespectsRingMult : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                       -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotRespectsRingMult modu ring (+) (++) (*) prfRing (.) = (r : ring) -> (s : ring) -> (m : modu) -> ((r*s) . m = r . (s . m))

|||Type of operation that maps 1.m to m.
total
dotRespectsIdentity : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                        -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
dotRespectsIdentity modu ring (+) (++) (*) prfRing (.) = (m : modu) -> (e . m = m) where
                                                                              e = fst (snd (fst (snd prfRing)))
|||The type of a Module. As the operations on the set modu determines it's abelianess property, we should only include the operation on the set modu and the operation between the set modu and the ring
total
IsleftModule : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                -> (IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu) -> Type
IsleftModule modu ring (+) (++) (*) prfRing (.) = ((IsAbelianGrp modu (+)) , (dotRespectsIdentity modu ring (+) (++) (*) prfRing (.) , (dotDistributesOverRing modu ring (+) (++) (*) prfRing (.) , ( dotDistributesOverModule modu ring (+) (++) (*) prfRing (.) , dotRespectsRingMult modu ring (+) (++) (*) prfRing (.)))))

--Below are a bunch of auxiliary functions to get recover dot distributing over blah from the envelope Type IsleftModule

|||Gives the Abelian Group property of a module
total
AbelianAddition : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                    -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                    -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> (IsAbelianGrp modu (+))
AbelianAddition modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (prfLeftModule)

|||Gives the Zero of the Module
total
ZeroOfModule : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                 -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> (e : modu ** ((a : modu) -> (a + e = a , e + a = a)))
ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (fst (fst (prfLeftModule))))

|||Gives the dot distributes over Ring addition property of the module
total
dotOverRingAdd : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                  -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                   -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotDistributesOverRing modu ring (+) (++) (*) prfRing (.)
dotOverRingAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (snd (prfLeftModule)))

|||Gives the dot distributes over module addition property of the module
total
dotOverModuleAdd : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                    -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                     -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotDistributesOverModule modu ring (+) (++) (*) prfRing (.)
dotOverModuleAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (snd (snd (prfLeftModule))))

|||Gives the dot Associates with ring multiplication property of the module
total
dotAssociatesRingMult : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                        -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                         -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotRespectsRingMult modu ring (+) (++) (*) prfRing (.)
dotAssociatesRingMult modu ring (+) (++) (*) prfRing (.) prfLeftModule = snd (snd (snd (snd (prfLeftModule))))

|||Gives the dot Associates with ring multiplication property of the module
total
dotRingIdentity : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                    -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                     -> (IsleftModule modu ring (+) (++) (*) prfRing (.)) -> dotRespectsIdentity modu ring (+) (++) (*) prfRing (.)
dotRingIdentity modu ring (+) (++) (*) prfRing (.) prfLeftModule = fst (snd (prfLeftModule))

|||Proof that r*0 = 0 for all r in the underlying ring
total
RingMultZeroEqualsZero : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                          -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                           -> (prfLeftModule : IsleftModule modu ring (+) (++) (*) prfRing (.))
                            -> ((r : ring) -> (r . (fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) = (fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule))))
RingMultZeroEqualsZero modu ring (+) (++) (*) prfRing (.) prfLeftModule = k where
                                                                              e : modu
                                                                              e = fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)
                                                                              u : ring -> modu -> modu
                                                                              u r m = r . m
                                                                              f : (r : ring) -> (r . (e + e) = (r . e) + (r . e))
                                                                              f r = (dotOverModuleAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule e e r)
                                                                              g : (r : ring) -> (r . (e + e) = r . e)
                                                                              g r = (cong (fst ((snd (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) e)))
                                                                              h : (r : ring) -> (r . e = (r . e) + (r . e))
                                                                              h r = (trans (sym (g r)) (f r))
                                                                              i : (r : ring) -> ((r . e) + e = (r . e))
                                                                              i r = (fst ((snd (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) (r . e)))
                                                                              j : (r : ring) -> ((r . e) + e = (r . e) + (r . e))
                                                                              j r = (trans (i r) (h r))
                                                                              k : (r : ring) -> ((r . e) = e)
                                                                              k r = (sym (Group_property_4 modu (+) (fst (fst prfLeftModule)) (r . e) e (r . e) (j r)))

|||Proof that 0*m = 0 for m in the module
total
ZeroMultModuleEqualsZero : (modu : Type) -> (ring : Type) -> ((+) : modu -> modu -> modu) -> ((++) : ring -> ring -> ring) -> ((*) : ring -> ring -> ring)
                            -> (prfRing : IsRing_with_identity ring (++) (*)) -> ((.) : ring -> modu -> modu)
                             -> (prfLeftModule : IsleftModule modu ring (+) (++) (*) prfRing (.))
                              -> ((m : modu) -> ((fst (fst (snd (fst (fst prfRing))))) . m = fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)))
ZeroMultModuleEqualsZero modu ring (+) (++) (*) prfRing (.) prfLeftModule = k where
                                                                                e : modu
                                                                                e = fst (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)
                                                                                z : ring
                                                                                z = fst (fst (snd (fst (fst prfRing))))
                                                                                u : modu -> ring -> modu
                                                                                u m r = r . m
                                                                                f : (m : modu) -> ((z ++ z) . m = (z . m) + (z . m))
                                                                                f m = (dotOverRingAdd modu ring (+) (++) (*) prfRing (.) prfLeftModule z z m)
                                                                                g : (m : modu) -> ((z ++ z) . m = z . m)
                                                                                g m = (functionExtendsEquality2 ring modu (u m) (z ++ z) z (fst (snd (fst (snd (fst (fst prfRing)))) z)))
                                                                                h : (m : modu) -> (z . m = (z . m) + (z . m))
                                                                                h m = (trans (sym (g m)) (f m))
                                                                                i : (m : modu) -> ((z . m) + e = (z . m))
                                                                                i m = (fst ((snd (ZeroOfModule modu ring (+) (++) (*) prfRing (.) prfLeftModule)) (z . m)))
                                                                                j : (m : modu) -> ((z . m) + e = (z . m) + (z . m))
                                                                                j m = (trans (i m) (h m))
                                                                                k : (m : modu) -> ((z . m) = e)
                                                                                k m = (sym (Group_property_4 modu (+) (fst (fst prfLeftModule)) (z . m) e (z . m) (j m)))


module Data.Crypto.Encryption.Stream.ARC4

import Control.Monad.State
import Data.Bits
import Data.Fin
import Data.Vect

import Data.Crypto.Util
import Data.Crypto.Encryption
import Data.Crypto.Encryption.Stream
import Data.Mod

%default total
%access private

-- This is off-by-one to make it easy to prove non-zero with (S x) in the code.
-- Hopefully, no one will ever actually need to construct one of these
-- explicitly.
public export
KeySizeMin1 : Type
KeySizeMin1 = Fin 255

public export
ARC4Key : KeySizeMin1 -> Type
ARC4Key n = Vect (S (cast n)) (Mod 256) -- should be Byte, but can’t convert yet

public export
data AllegedRivestCipher4 : KeySizeMin1 -> Type where
  ARC4 : ARC4Key n -> AllegedRivestCipher4 n

KSA : ARC4Key n -> Vect 256 (Mod 256)
KSA {n=n} key =
  nextJ 255 0 0 (map fromInteger (fromList [0..255]))
  where
    nextJ : Nat -> Fin 256 -> Mod 256 -> Vect 256 (Mod 256) -> Vect 256 (Mod 256)
    nextJ Z i j s =
      let ind = tightmod (cast i) (S (cast n))
      in let newJ = j + index i s + index ind key
         in swap i (cast newJ) s
    nextJ (S c) i j s =
      let ind = tightmod (cast i) (S (cast n))
      in let newJ = j + index i s + index ind key
         in let newS = (swap i (cast newJ) s)
            in case strengthen (FS i) of
              Left _ => newS
              Right newI => nextJ c newI newJ newS

PGRA : Mod 256 -> Mod 256 -> Vect 256 (Mod 256) -> Stream Byte
PGRA i j S = let newI = i + 1
             in let newJ = j + index (cast newI) S
                in let newS = swap (cast newI) (cast newJ) S
                   in Prelude.Stream.(::)
                      (modToBits (index (cast (index (cast newI) newS + index (cast newJ) newS)) newS))
                      (PGRA newI newJ newS)

implementation Cipher (AllegedRivestCipher4 n) 8 where

implementation StreamCipher (AllegedRivestCipher4 n) 8 where
  generateKeystream (ARC4 key) = PGRA 0 0 (KSA key)


module Conway.Parse

import Conway
import Control.Comonad.Store.Representable
import Data.Functor.Representable
import Data.List
import Data.String
import Data.Vect
import Data.Vect.Extra

%default total

parseLine : {n : Nat} -> String -> Maybe (List (Fin n))
parseLine str = findIndices (== '#') <$> toVect n (unpack str)

export
parseGrid : String -> Maybe (DPair (Nat, Nat) (\(n, m) => Grid n m Bool))
parseGrid text = do
  (S n ** rows) <- pure $ asVect (lines text) | _ => Nothing
  S m <- pure $ length (head rows) | _ => Nothing
  coords' <- traverse (parseLine {n = S m}) rows
  let coords = foldMap id $ mapWithIndex (\i, c => (i,) <$> c) coords'
  pure $ ((S n, S m) ** store @{Compose} (`elem` coords) (0, FZ))


||| N-ary simple (non-dependent) functions using telescopes
|||
||| Compare with `base/Data.Fun` and `contrib/Data.Fun.Extra` and with:
||| Guillaume Allais. 2019. Generic level polymorphic n-ary functions. TyDe 2019.
module Data.Telescope.SimpleFun

import Data.Telescope.Telescope
import Data.Telescope.Segment

||| An n-ary function whose codomain does not depend on its
||| arguments. The arguments may have dependencies.
public export
0 SimpleFun : (env : Left.Environment gamma) -> {n : Nat} -> (0 delta : Segment n gamma)
           -> (cod : Type) -> Type
SimpleFun env {n = 0  } [] cod = cod
SimpleFun env {n = S n} (ty :: delta) cod = (x : ty env) -> SimpleFun (env ** x) delta cod

public export
target : {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma} -> {cod : Type}
      -> SimpleFun env delta cod -> Type
target {cod} _ = cod

public export
uncurry : {n : Nat} -> {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma}
       -> (f : SimpleFun env delta cod) -> Environment env delta -> cod
uncurry {n = Z}   {delta = []}     f xs        = f
uncurry {n = S n} {delta = _ :: _} f (x .= xs) = uncurry (f x) xs

public export
curry : {n : Nat} -> {0 env : Left.Environment gamma} -> {0 delta : Segment n gamma}
     -> (f : Environment env delta -> cod)
     -> SimpleFun env delta cod
curry {n = 0  } {delta = []         } f = f Empty
curry {n = S n} {delta = ty :: delta} f = \x => curry (\xs => f (x .= xs))


module Adder

AdderType : (numargs : Nat) -> Type -> Type
AdderType Z numType = numType
AdderType (S k) numType = (next : numType) -> AdderType k numType

adder : Num num => (numargs : Nat) -> (acc : num) -> AdderType numargs num
adder Z acc = acc
adder (S k) acc = \i => adder k (i + acc)


natElim : (p : Nat -> Type) -> p Z -> ((k : Nat) -> p k -> p (S k)) ->
          (x : Nat) -> p x

natElim2 : (p : Nat -> Type) -> p Z -> ((k : Nat) -> p k -> p (S k)) ->
           (x : Nat) -> p x
natElim2 p x f Z = x
natElim2 p x f (S k) = ?foo

listElim : (p : List a -> Type) ->
           (mnil : p []) ->
           (mcons : (x : _) -> (xs : List a) -> p xs -> p (x :: xs)) ->
           (xs : List a) -> p xs


-- --------------------------------------------------------- [ Interactive.idr ]
-- Module      : Exercises.Test.Interactive
-- Description : Test covering the Chapter 3 exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Exercises.Test.Interactive

import Exercises.Interactive

import Test.Helpers

import Data.Vect
%hide Data.Vect.overLength

%access export

testLength : IO Bool
testLength = "my_length" `assertEqual'` 10 $ my_length [1..10]

testReverse : IO Bool
testReverse = "my_reverse" `assertEqual'` [10,9..1] $ my_reverse [1..10]

testMap : IO Bool
testMap = "my_map" `assertEqual'` [2,4..20] $ my_map (*2) [1..10]

testVectMap : IO Bool
testVectMap =
  "my_vect_map" `assertEqual'` the (Vect _ Nat) [3, 3, 7, 4] $
  my_vect_map length ["Hot", "Dog", "Jumping", "Frog"]

testAddMatrix : (Eq elem, Num elem, Show elem) =>
                (a, b, expected : Vect n (Vect m elem)) ->
                IO Bool
testAddMatrix {n} {m} a b expected =
  unwords ["addMatrix", show n, "x", show m] `assertEqual'` expected $
  addMatrix a b

testMultMatrix : (Eq elem, Num elem, Show elem) =>
                 Vect n (Vect m elem) -> Vect m (Vect p elem) ->
                 Vect n (Vect p elem) ->
                 IO Bool
testMultMatrix {n} {m} {p} a b expected =
  unwords ["multMatrix (", show n, "x", show m, ") (", show m, "x", show p, ")"]
  `assertEqual'` expected $ multMatrix a b

testTransposeMat : (Eq elem, Show elem) =>
                   Vect n (Vect m elem) -> Vect m (Vect n elem) ->
                   IO Bool
testTransposeMat {n} {m} toTranspose expected =
  unwords ["transpose_mat", show n, "x", show m] `assertEqual'` expected $
  transpose_mat toTranspose

allTests : List (IO Bool)
allTests = [ testLength
           , testReverse
           , testMap
           , testVectMap
           , testTransposeMat [ [1, 2,   3,  4],
                                [5, 6,   7,  8],
                                [9, 10, 11, 12] ]
                              [ [1, 5,  9],
                                [2, 6, 10],
                                [3, 7, 11],
                                [4, 8, 12] ]
           , testTransposeMat [ [1, 2],
                                [3, 4],
                                [5, 6] ]
                              [ [1, 3, 5],
                                [2, 4, 6] ]
           , testAddMatrix [ [1, 2],
                             [3, 4] ]
                           [ [5, 6],
                             [7, 8] ]
                           [ [ 6,  8],
                             [10, 12] ]
           , testMultMatrix [ [  1,   2],
                              [  3,   4],
                              [  5,   6] ]
                            [ [  7,   8,   9,  10],
                              [ 11,  12,  13,  14] ]
                            [ [ 29,  32,  35,  38],
                              [ 65,  72,  79,  86],
                              [101, 112, 123, 134] ]
           ]

runTests : IO (Vect (length Interactive.allTests) Bool)
runTests = testChapter "3: Interactive development with types" allTests

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


module Rational
import SignedInt

%default total
%access public export

-- a/(1+b)
record Rational where
    constructor MkRat
    a: SignedInt
    b: Nat

implementation Num Rational where
    (MkRat a1 b1) + (MkRat a2 b2) = MkRat (a1 $* (S b2) + a2 $* (S b1)) (b1 * b2 + b1 + b2)
    (MkRat a1 b1) * (MkRat a2 b2) = MkRat (a1 * a2) (b1 * b2 + b1 + b2)
    fromInteger a = MkRat (fromInteger a) 0

implementation Neg Rational where
    negate (MkRat a b) = MkRat (negate a) b
    a - b = a + negate b

data RationalEq : Rational -> Rational -> Type where
    RationalRefl : (eq : a1 $* (S b2) `SignedEq` a2 $* (S b1)) -> RationalEq (MkRat a1 b1) (MkRat a2 b2)


module Modulo

import Data.Fin

%access export
%default total

add : Fin k -> Fin k -> Fin k
add {k=S k} n m = restrict k $ finToInteger n + finToInteger m

negate : Fin k -> Fin k
negate {k=S k} n = restrict k $ toIntegerNat (S k) - finToInteger n

subt : Fin k -> Fin k -> Fin k
subt {k=S k} n m = restrict k $ finToInteger n - finToInteger m + toIntegerNat (S k)

mult : Fin k -> Fin k -> Fin k
mult {k=S k} n m = restrict k $ finToInteger n * finToInteger m


import Data.Vect
import Data.Fin

-- %default total  -- WHY NOT ?

-- Possible types
data Ty = TyInt | TyBool | TyFun Ty Ty

-- Types interpreted in idris
interpTy : Ty -> Type
interpTy TyInt       = Integer
interpTy TyBool      = Bool
interpTy (TyFun A T) = interpTy A -> interpTy T

using (G:Vect n Ty)  -- the context
  data Expr : Vect n Ty -> Ty -> Type   -- local vars Type -> Expr Type

  -- Representation of expressions
  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where
   Stop : HasType FZ (t :: G) t
   Pop  : HasType k G t -> HasType (FS k) (u :: G) t

  data Expr : Vect n Ty -> Ty -> Type where
    Var : HasType i G t -> Expr G t
    Val : (x : Integer) -> Expr G TyInt
    Lam : Expr (a :: G) t -> Expr G (TyFun a t)
    App : Expr G (TyFun a t) -> Expr G a -> Expr G t
    Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> Expr G c
    If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

  data Env : Vect n Ty -> Type where
    Nil  : Env Nil
    (::) : interpTy a -> Env G -> Env (a :: G)

  lookup : HasType i G t -> Env G -> interpTy t
  lookup Stop    (x :: xs) = x
  lookup (Pop k) (x :: xs) = lookup k xs

  interp : Env G -> Expr G t -> interpTy t
  interp env (Var i)     = lookup i env
  interp env (Val x)     = x
  interp env (Lam sc)    = \x => interp (x :: env) sc
  interp env (App f s)   = interp env f (interp env s)
  interp env (Op op x y) = op (interp env x) (interp env y)
  interp env (If x t e)  = if interp env x then interp env t
                           else interp env e

  add : Expr G (TyFun TyInt (TyFun TyInt TyInt))
  add = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

  fact : Expr G (TyFun TyInt TyInt)
  fact = Lam (If (Op (==) (Var Stop) (Val 0))
                 (Val 1)
                 (Op (*) (App fact (Op (-) (Var Stop) (Val 1)))
                         (Var Stop)))

partial
main : IO ()
main = do putStr "Enter a number: "
          x <- getLine
          printLn (interp [] fact (cast x))


module Control.Comonad

import Control.Monad.Identity

import Data.List1
import Data.Morphisms
import Data.Stream

%default total

--------------------------------------------------------------------------------
--          Comonad
--------------------------------------------------------------------------------

public export
interface Functor w => Comonad w where
  extract   : w a -> a

  duplicate : w a -> w (w a)
  duplicate = extend id

  extend    : (w a -> b) -> w a -> w b
  extend f = map f . duplicate

--------------------------------------------------------------------------------
--          Comonad Implementations
--------------------------------------------------------------------------------

public export
Comonad (Pair e) where
  extract         = snd
  duplicate (e,a) = (e, (e, a))

public export
Comonad Identity where
  extract   = runIdentity
  duplicate = Id

public export
Comonad Stream where
  extract               = head
  duplicate xs@(_ :: t) = xs :: duplicate t

public export
Comonad List1 where
  extract = head
  duplicate (x ::: xs) = (x ::: xs) ::: tails xs
    where tails : List a -> List (List1 a)
          tails []        = []
          tails (x :: xs) = (x ::: xs) :: tails xs

public export
Monoid e => Comonad (Morphism e) where
  extract   (Mor f) = f neutral
  duplicate (Mor f) = Mor $ \e => Mor (\e' => f (e <+> e'))

--------------------------------------------------------------------------------
--          ComonadApply
--------------------------------------------------------------------------------

infixl 4 <@, @>, <@@>, <@>

public export
interface Comonad w => ComonadApply w where
  (<@>) : w (a -> b) -> w a -> w b

  (@>)  : w a -> w b -> w b
  (@>) = flip (<@)

  (<@) : w a -> w b -> w a
  a <@ b = map const a <@> b

--------------------------------------------------------------------------------
--          ComonadApply Implementations
--------------------------------------------------------------------------------

public export
Semigroup m => ComonadApply (Pair m) where
  (m, f) <@> (n, a) = (m <+> n, f a)
  (m, a) <@  (n, _) = (m <+> n, a)
  (m, _)  @> (n, b) = (m <+> n, b)

public export
ComonadApply List1 where
  (<@>) = (<*>)

public export
ComonadApply Stream where
  (<@>) = (<*>)

public export
Monoid m => ComonadApply (Morphism m) where
  (<@>) = (<*>)

public export
ComonadApply Identity where
  (<@>) = (<*>)
  _ @> b = b
  b <@ _ = b

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

infixl 1 =>>
infixr 1 <<=, =<=, =>=

||| `extend` with the arguments swapped. Dual to `>>=` for a `Monad`.
public export %inline
(=>>) : Comonad w => w a -> (w a -> b) -> w b
(=>>) = flip extend

||| `extend` in operator form
public export %inline
(<<=) : Comonad w => (w a -> b) -> w a -> w b
(<<=) = extend

||| Right-to-left `Cokleisli` composition
public export %inline
(=<=) : Comonad w => (w b -> c) -> (w a -> b) -> w a -> c
f =<= g = f . extend g

||| Left-to-right `Cokleisli` composition
public export %inline
(=>=) : Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
f =>= g = g . extend f

||| Flipped version of `<@>`.
public export %inline
(<@@>) : ComonadApply w => w a -> w (a -> b) -> w b
(<@@>) = flip (<@>)


module Data.Profunctor.Choice

import Data.Profunctor.Class
import Data.Morphisms

public export
interface Profunctor p => Choice (0 p : Type -> Type -> Type) where
  left' : p a b -> p (Either a c) (Either b c)
  left' = dimap (either Right Left) (either Right Left) . right'

  right' : p a b -> p (Either c a) (Either c b)
  right' = dimap (either Right Left) (either Right Left) . left'

public export
Choice Morphism where
  left' (Mor f) = Mor g
    where g : Either a c -> Either b c
          g (Left a) = Left (f a)
          g (Right c) = Right c

  right' (Mor f) = Mor g
    where g : Either c a -> Either c b
          g (Left c) = Left c
          g (Right a) = Right (f a)


module Algebra.Solver.Prod

import public Data.List.Elem

%default total

||| A product of variables each represented by the exponent,
||| to which it is raised.
|||
||| When normalizing arithmetic expressions, they often
||| get converted to (sums of) products of variables
||| (listed in index `as`), each raised to a certain
||| exponent. This is the case for commutative monoids
||| (a single product) as well as commutative (semi)rings
||| (a sum of products).
public export
data Prod : (a : Type) -> (as : List a) -> Type where
  Nil  : Prod a []
  (::) : (exp : Nat) -> Prod a xs -> Prod a (x :: xs)

||| Multiplying two products means adding all
||| expontents pairwise.
public export
mult : Prod a as -> Prod a as -> Prod a as
mult []        []        = []
mult (x :: xs) (y :: ys) = (x + y) :: mult xs ys

||| We sort products by lexicographically comparing
||| the exponents.
public export
compProd : Prod a as -> Prod a as -> Ordering
compProd []        []        = EQ
compProd (x :: xs) (y :: ys) = case compare x y of
  LT => LT
  GT => GT
  EQ => compProd xs ys

||| The neutral product where all exponents are zero.
public export
one : {as : List a} -> Prod a as
one {as = []}      = []
one {as = x :: xs} = 0 :: one

||| Convert a single variable to a product of variables.
public export
fromVar : {as : List a} -> Elem x as -> Prod a as
fromVar {as = x :: xs} Here      = 1 :: one
fromVar {as = x :: xs} (There y) = 0 :: fromVar y
fromVar {as = []} Here impossible
fromVar {as = []} (There y) impossible

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

Uninhabited (LT = EQ) where
  uninhabited _ impossible

Uninhabited (GT = EQ) where
  uninhabited _ impossible

export
0 pcompNat : (x,y : Nat) -> (compare x y === EQ) -> x === y
pcompNat 0 0         prf = Refl
pcompNat (S k) (S j) prf = cong S $ pcompNat k j prf
pcompNat 0 (S k) Refl impossible
pcompNat (S k) 0 Refl impossible

export
0 pcompProd :  (x,y : Prod a as)
            -> (compProd x y === EQ)
            -> x === y
pcompProd []        []        prf = Refl
pcompProd (x :: xs) (y :: ys) prf with (compare x y) proof eq
  _ | EQ = cong2 (::) (pcompNat x y eq) (pcompProd xs ys prf)
  _ | LT = absurd prf
  _ | GT = absurd prf
pcompProd []        (_ :: _)  Refl impossible
pcompProd (_ :: _)  []        Refl impossible


import Data.List

[myord] Ord Nat where
   compare Z (S n)     = GT
   compare (S n) Z     = LT
   compare Z Z         = EQ
   compare (S x) (S y) = compare @{myord} x y

testList : List Nat
testList = [3,4,1]


module Control.WellFounded

import Control.Relation
import Data.Nat
import Data.List

%default total

public export
data Accessible : (rel : a -> a -> Type) -> (x : a) -> Type where
  Access : (rec : (y : a) -> rel y x -> Accessible rel y) ->
           Accessible rel x

public export
interface WellFounded a rel where
  wellFounded : (x : a) -> Accessible rel x

export
accRec : {0 rel : (arg1 : a) -> (arg2 : a) -> Type} ->
         (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->
         (z : a) -> (0 acc : Accessible rel z) -> b
accRec step z (Access f) =
  step z $ \yarg, lt => accRec step yarg (f yarg lt)

export
accInd : {0 rel : a -> a -> Type} -> {0 P : a -> Type} ->
         (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->
         (z : a) -> (0 acc : Accessible rel z) -> P z
accInd step z (Access f) =
  step z $ \y, lt => accInd step y (f y lt)

export
wfRec : (0 _ : WellFounded a rel) =>
        (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->
        a -> b
wfRec step x = accRec step x (wellFounded {rel} x)

export
wfInd : (0 _ : WellFounded a rel) => {0 P : a -> Type} ->
        (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->
        (myz : a) -> P myz
wfInd step myz = accInd step myz (wellFounded {rel} myz)

public export
interface Sized a where
  constructor MkSized
  total size : a -> Nat

public export
Smaller : Sized a => a -> a -> Type
Smaller = \x, y => size x `LT` size y

public export
SizeAccessible : Sized a => a -> Type
SizeAccessible = Accessible Smaller

export
sizeAccessible : Sized a => (x : a) -> SizeAccessible x
sizeAccessible x = Access (acc $ size x)
  where
    acc : (sizeX : Nat) -> (y : a) -> (size y `LT` sizeX) -> SizeAccessible y
    acc (S x') y (LTESucc yLEx')
        = Access $ \z, zLTy => acc x' z $ transitive {rel = LTE} zLTy yLEx'

export
sizeInd : Sized a => {0 P : a -> Type} ->
          (step : (x : a) -> ((y : a) -> Smaller y x -> P y) -> P x) ->
          (z : a) ->
          P z
sizeInd step z = accInd step z (sizeAccessible z)

export
sizeRec : Sized a =>
          (step : (x : a) -> ((y : a) -> Smaller y x -> b) -> b) ->
          (z : a) -> b
sizeRec step z = accRec step z (sizeAccessible z)

export
Sized Nat where
  size = id

export
WellFounded Nat LT where
  wellFounded = sizeAccessible

export
Sized (List a) where
  size = length

export
(Sized a, Sized b) => Sized (Pair a b) where
  size (x,y) = size x + size y


module Main
import Data.Bits

boolToInt : Bool -> Int
boolToInt True = 1
boolToInt False = 0

main : IO ()
main = do
  putStrLn . show $ (the Int8 100) + (the Int8 50)
  putStrLn . show $ (the Int8 100) - (the Int8 50)
  putStrLn . show $ (the Int8 100) * (the Int8 50)
  putStrLn . show $ (the Int8 100) `div` (the Int8 7)
  putStrLn . show $ (the Int8 100) `mod` (the Int8 7)
  putStrLn . show $ -(the Int8 50)

  putStrLn . show $ the Int8 100 .&. the Int8 50
  putStrLn . show $ the Int8 100 .|. the Int8 50
  putStrLn . show $ the Int8 100 `xor` the Int8 50

  putStrLn . show . boolToInt $ the Int8 100 < the Int8 50
  putStrLn . show . boolToInt $ the Int8 100 <= the Int8 50
  putStrLn . show . boolToInt $ the Int8 100 == the Int8 50
  putStrLn . show . boolToInt $ the Int8 100 >= the Int8 50
  putStrLn . show . boolToInt $ the Int8 100 > the Int8 50
  -- putStrLn . show  $ the Int8 50 `shiftL` 1
  -- putStrLn . show  $ the Int8 100 `shiftR` 1


module CoinToss

import Data.Vect
import QStateT
import QuantumOp
import LinearTypes

||| A fair coin toss (as an IO effect) via quantum resources.
|||
||| first create a new qubit in state |0>
||| then apply a hadamard gate to it, thereby preparing state |+>
||| and finally measure the qubit and return this as the result
export
coin : QuantumOp t => IO Bool
coin = do
  [b] <- run (do
           q <- newQubit {t = t}
           q <- applyH q
           r <- measure [q]
           pure r
         )
  pure b

testCoin : IO Bool
testCoin = coin {t = SimulatedOp}


module Control.Kan

||| left kan extension
data Lan : (Type -> Type) -> Type -> Type where
  FMap : (x -> a) -> g x -> Lan g a

||| 'free' functor for any *->*
Functor (Lan f) where
  map func (FMap g y) = FMap (func . g) y


module Lambdapants.Term

||| In the lambda calculus, a term is one of three things:
||| * A variable is a term;
||| * Application of two terms is a term; and
||| * A lambda abstraction is a term.
|||
||| Nothing else is a term. Application is left-associative, so the term
||| `(s t u)` is the same as `(s t) u`. One often omits outermost parentheses.
||| In abstractions, the body extends as far to the right as possible.
public export
data Term : Type where
  ||| Variable
  Var : String -> Term
  ||| Lambda abstraction
  Lam : String -> Term -> Term
  ||| Application
  App : Term -> Term -> Term

export
Eq Term where
  (Var a)   == (Var b)   = a == b
  (Lam x t) == (Lam y u) = x == y && t == u
  (App t u) == (App v w) = t == v && u == w
  _         == _         = False

export
Show Term where
  show (Var v)   = "Var "  ++ show v
  show (App t u) = "App (" ++ show t ++ ") ("
                           ++ show u ++ ")"
  show (Lam x t) = "Lam "  ++ show x ++ " ("
                           ++ show t ++ ")"

mutual
  lam : Term -> String
  lam (Lam x t) = "\x03BB" ++ x ++ "." ++ lam t
  lam term = app term

  app : Term -> String
  app (App t u) = app t ++ " " ++ pretty u
  app term = pretty term

  ||| Translate the given term to a pretty-printed string.
  export
  pretty : Term -> String
  pretty term =
    case term of
         Lam _ _ => "(" ++ lam term ++ ")"
         App _ _ => "(" ++ app term ++ ")"
         Var var => var

||| Return a list of all variables which appear free in the term *t*.
export total
freeVars : (t : Term) -> List String
freeVars (Var v)   = [v]
freeVars (Lam v t) = delete v (freeVars t)
freeVars (App t u) = freeVars t `union` freeVars u

||| Return a boolean to indicate whether the variable *v* appears free in the
||| term *t*.
export total
isFreeIn : (v : String) -> (t : Term) -> Bool
isFreeIn var term = elem var (freeVars term)

||| De Bruijn-indexed intermediate representation for more convenient alpha
||| comparison of terms.
data Indexed : Type where
  ||| Bound variable (depth indexed)
  Bound : Nat -> Indexed
  ||| Free variable
  Free  : String -> Indexed
  ||| Application
  IxApp : Indexed -> Indexed -> Indexed
  ||| Lambda abstraction
  IxLam : Indexed -> Indexed

Show Indexed where
  show (Bound n)   = "Bound "  ++ show n
  show (Free v)    = "Free "   ++ show v
  show (IxApp t u) = "IxApp (" ++ show t ++ ") ("
                               ++ show u ++ ")"
  show (IxLam t)   = "IxLam (" ++ show t ++ ")"

Eq Indexed where
  (Bound m)   == (Bound n)   = m == n
  (Free v)    == (Free w)    = v == w
  (IxApp t u) == (IxApp v w) = t == v && u == w
  (IxLam t)   == (IxLam u)   = t == u
  _           == _           = False

||| Translate the term *t* to a canonical De Bruijn (depth-indexed) form.
total
toIndexed : (t : Term) -> Indexed
toIndexed = indexed [] where
  indexed : List String -> Term -> Indexed
  indexed bound (Var x)   = maybe (Free x) Bound (elemIndex x bound)
  indexed bound (App t u) = IxApp (indexed bound t) (indexed bound u)
  indexed bound (Lam x t) = IxLam (indexed (x :: bound) t)

||| Return a boolean to indicate whether two terms are alpha equivalent; that
||| is, whether one can be converted to the other purely by renaming of bound
||| variables.
export total
alphaEq : Term -> Term -> Bool
alphaEq t u = toIndexed t == toIndexed u


module Dummy

import Data.Vect

namespace DList

  ||| A list construct for dependent types.
  |||
  ||| @aTy    The type of the value contained within the list element type.
  ||| @elemTy The type of the elements within the list
  ||| @as     The List used to contain the different values within the type.
  public export
  data DList : (aTy : Type)
            -> (elemTy : aTy -> Type)
            -> (as : List aTy)
            -> Type where
    ||| Create an empty List
    Nil  : DList aTy elemTy Nil
    ||| Cons
    |||
    ||| @elem The element to add
    ||| @rest The list for `elem` to be added to.
    (::) : (elem : elemTy x)
        -> (rest : DList aTy elemTy xs)
        -> DList aTy elemTy (x::xs)

namespace DVect
  ||| A list construct for dependent types.
  |||
  ||| @aTy    The type of the value contained within the list element type.
  ||| @elemTy The type of the elements within the list
  ||| @len    The length of the list.
  ||| @as     The List used to contain the different values within the type.
  public export
  data DVect : (aTy : Type)
            -> (elemTy : aTy -> Type)
            -> (len : Nat)
            -> (as : Vect len aTy)
            -> Type where
    ||| Create an empty List
    Nil  : DVect aTy elemTy Z Nil
    ||| Cons
    |||
    ||| @ex The element to add
    ||| @rest The list for `elem` to be added to.
    (::) : (ex : elemTy x)
        -> (rest : DVect aTy elemTy n xs)
        -> DVect aTy elemTy (S n) (x::xs)

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

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


> module Double.Properties

> import Data.So

> import Double.Predicates
> import Double.Postulates
> import Double.Operations
> import So.Properties
> import Ordering.Properties
> import Rel.TotalPreorder
> import So.Properties
> import Interfaces.Math

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

* Implementations

> implementation Math Double where
>   exp = Prelude.Doubles.exp
>   sin = Prelude.Doubles.sin
>   cos = Prelude.Doubles.cos

* Decidability of EQ

> |||
> decEQ : (x : Double) -> (y : Double) -> Dec (x `EQ` y)
> decEQ x y with (decSo (x == y))
>   | Yes p = Yes (MkEQ p)
>   | No contra = No (\ (MkEQ p) => contra p)

* Properties of Ord methods

> |||
> LTinLTE : {x, y : Double} -> So (x < y) -> So (x <= y)
> LTinLTE {x} {y} prf = soOrIntro1 (x < y) (x == y) prf
> -- LTinLTE : {x, y : Double} -> x `LT` y -> x `LTE` y
> -- LTinLTE {x} {y} (MkLT prf) = MkLTE (soOrIntro1 (x < y) (x == y) prf)

> |||
> EQinLTE : {x, y : Double} -> So (x == y) -> So (x <= y)
> EQinLTE {x} {y} prf = soOrIntro2 (x < y) (x == y) prf

> |||
> compareLT : {x, y : Double} -> LT = compare x y -> So (x < y)
> compareLT {x} {y} p with (compare x y)
>   compareLT {x} {y} _ | LT = Oh
>   compareLT {x} {y} p | EQ = absurd p
>   compareLT {x} {y} p | GT = absurd p

> compareEQ : {x, y : Double} -> EQ = compare x y -> So (x == y)
> compareEQ {x} {y} p with (compare x y) proof prf
>   | LT = absurd p
>   | EQ with (decSo (x == y))
>     | (Yes q) = q
>     | (No  c) = void (notCompareEQ c prf)
>   | GT = absurd p

> compareEQ' : {x, y : Double} -> So (x == y) -> compare x y = EQ
> compareEQ' {x} {y} p with (x == y) proof q
>   | True  = Refl
>   | False = absurd p

> |||
> compareGT : {x, y : Double} -> GT = compare x y -> So (x > y)
> compareGT {x} {y} p with (compare x y)
>   compareGT {x} {y} p | LT = absurd p
>   compareGT {x} {y} p | EQ = absurd p
>   compareGT {x} {y} _ | GT = Oh

* LT, LTE:

> ||| LTE is total
> totalLTE : (x, y : Double) -> Either (x `LTE` y) (y `LTE` x)
> totalLTE x y with (compare x y) proof prf
>   | LT = Left  (MkLTE (LTinLTE (compareLT prf)))
>   | EQ = Left  (MkLTE (EQinLTE (compareEQ prf)))
>   | GT = Right (MkLTE (LTinLTE (gtLT (compareGT prf))))

> ||| LTE is a total preorder
> totalPreorderLTE : TotalPreorder Double.Predicates.LTE
> totalPreorderLTE = MkTotalPreorder LTE reflexiveLTE transitiveLTE totalLTE

> ||| LT is decidable
> decLT : (x : Double) -> (y : Double) -> Dec (x `LT` y)
> decLT x y with (decSo (x < y))
>   | Yes prf    = Yes (MkLT prf)
>   |  No contra =  No (\ (MkLT prf) => void (contra prf))

> ||| LTE is decidable
> decLTE : (x : Double) -> (y : Double) -> Dec (x `LTE` y)
> decLTE x y with (decSo (x <= y))
>   | Yes prf    = Yes (MkLTE prf)
>   |  No contra =  No (\ (MkLTE prf) => void (contra prf))

> |||
> minusLTELemma : (x : Double) -> (y : Double) ->
>                 x `LTE` y -> 0.0 `LTE` y - x
> minusLTELemma x y xLTEy = s2 where
>   s1 : x - x `LTE` y - x
>   s1 = monotoneMinusConstLTE xLTEy
>   s2 : 0.0 `LTE` y - x
>   s2 = replace {P = \ X => X `LTE` y - x} (minusSelfZero) s1

> |||
> divLTELemma : (x : Double) -> (y : Double) -> x `LTE` y ->
>               Positive y -> x / y `LTE` 1.0
> divLTELemma x y xLTEy py = s2 where
>   s1 : x / y `LTE` y / y
>   s1 = monotoneDivConstLTE xLTEy py
>   s2 : x / y `LTE` 1.0
>   s2 = replace {P = \ X => x / y `LTE` X} (divPositiveSelfOne py) s1

> |||
> divNonNegativePositiveNonNegative : (x : Double) -> (y : Double) ->
>                                     0.0 `LTE` x -> Positive y ->
>                                     0.0 `LTE` x / y
> divNonNegativePositiveNonNegative x y zLTEx py = s2 where
>   s1 : 0.0 / y `LTE` x / y
>   s1 = monotoneDivConstLTE zLTEx py
>   s2 : 0.0 `LTE` x / y
>   s2 = replace {P = \ X => X `LTE` x / y} (divZeroPositiveZero py) s1

> ||| |sum| is monotone
> monotoneSum : {A : Type} ->
>               (f : A -> Double) -> (g : A -> Double) ->
>               (p : (a : A) -> f a `LTE` g a) ->
>               (as : List A) ->
>               sum (map f as) `LTE` sum (map g as)
> monotoneSum f g p Nil = reflexiveLTE 0.0
> monotoneSum f g p (a :: as) =
>   monotonePlusLTE {a = f a} {b = g a} {c = sum (map f as)} {d = sum (map g as)} (p a) (monotoneSum f g p as)

* Non-negative double precision floating point numbers:

> ||| Non-negative |Double|s are closed w.r.t. sum
> plusPreservesNonNegativity : {x, y : Double} ->
>                              NonNegative x -> NonNegative y -> NonNegative (x + y)
> plusPreservesNonNegativity {x} {y} zeroLTEx zeroLTEy = s2 where
>   s1 : 0.0 + 0.0 `LTE` x + y
>   s1 = monotonePlusLTE {a = 0.0} {b = x} {c = 0.0} {d = y} zeroLTEx zeroLTEy
>   s2 : 0.0 `LTE` x + y
>   s2 = replace {P = \ X => X `LTE` x + y} plusZeroLeftNeutral s1

> ||| Non-negative |Double|s are closed w.r.t. multiplication
> multPreservesNonNegativity : {x, y : Double} ->
>                              NonNegative x -> NonNegative y -> NonNegative (x * y)
> multPreservesNonNegativity {x} {y} zeroLTEx zeroLTEy = s2 where
>   s1 : 0.0 * 0.0 `LTE` x * y
>   s1 = monotoneMultLTE {a = 0.0} {b = x} {c = 0.0} {d = y} zeroLTEx zeroLTEy
>   s2 : 0.0 `LTE` x * y
>   s2 = replace {P = \ X => X `LTE` x * y} (multZeroLeftZero {x = 0.0}) s1

* Positive double precision floating point numbers:

> |||
> positiveImpliesNonNegative : {x : Double} -> Positive x -> NonNegative x
> positiveImpliesNonNegative (MkLT prf) = MkLTE (LTinLTE prf)

* Properties of constants:

> ||| one is not zero
> notOneEqZero : Not (1.0 = 0.0)
> notOneEqZero Refl impossible

> ||| zero is not positive
> notPositiveZero : Not (Positive 0.0)
> notPositiveZero (MkLT prf) = contra Refl prf

* Properties of |fromNat|

> |||
> fromNatNonNegative : {n : Nat} -> NonNegative (fromNat n)
> fromNatNonNegative {n = Z}   = MkLTE Oh
> fromNatNonNegative {n = S m} = plusPreservesNonNegativity (MkLTE Oh) fromNatNonNegative

> |||
> fromSuccPositive : {n : Nat} -> Positive (fromNat (S n))
> fromSuccPositive {n} = positivePlusAnyPositive (MkLT Oh) fromNatNonNegative

* Convexity

> |||
> convexLemma1 : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                (x : Double) -> (q : x1 `LTE` x) ->
>                0.0 `LTE` (x - x1) / (x2 - x1)
> convexLemma1 x1 x2 px2mx1 x x1LTEx =
>   divNonNegativePositiveNonNegative (x - x1) (x2 - x1) s1 px2mx1 where
>     s1 : 0.0 `LTE` (x - x1)
>     s1 = minusLTELemma x1 x x1LTEx

> |||
> convexLemma2 : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                (x : Double) -> (q : x `LTE` x2) ->
>                (x - x1) / (x2 - x1) `LTE` 1.0
> convexLemma2 x1 x2 px2mx1 x q = divLTELemma (x - x1) (x2 - x1) s1 px2mx1 where
>   s1 : (x - x1) `LTE` (x2 - x1)
>   s1 = monotoneMinusConstLTE q

> |||
> convexLemma : (x1 : Double) -> (x2 : Double) -> (alpha : Double) ->
>               NonNegative x1 -> NonNegative x2 ->
>               0.0 `LTE` alpha -> alpha `LTE` 1.0 ->
>               NonNegative (x1 * (1.0 - alpha) + x2 * alpha)
> convexLemma x1 x2 alpha nnx1 nnx2 (MkLTE p1) (MkLTE p2) = s4 where
>   s1 : NonNegative alpha
>   s1 = MkLTE p1
>   s2 : alpha - alpha `LTE` 1.0 - alpha
>   s2 = monotoneMinusConstLTE (MkLTE p2)
>   s3 : NonNegative (1.0 - alpha)
>   s3 = replace {P = \ X => X `LTE` 1.0 - alpha} minusSelfZero s2
>   s4 : NonNegative (x1 * (1.0 - alpha) + x2 * alpha)
>   s4 = plusPreservesNonNegativity {x = x1 * (1.0 - alpha)} {y = x2 * alpha}
>                                   (multPreservesNonNegativity nnx1 s3)
>                                   (multPreservesNonNegativity nnx2 s1)

* Properties of |mkLinearStepLemma|:

> |||
> mkLinearStepLemma : (x1 : Double) -> (x2 : Double) -> Positive (x2 - x1) ->
>                     (y1 : Double) -> (y2 : Double) ->
>                     NonNegative y1 -> NonNegative y2 ->
>                     (x : Double) -> NonNegative (mkLinearStep x1 x2 prf y1 y2 x)
> mkLinearStepLemma x1 x2 px2mx1 y1 y2 nny1 nny2 x with (decSo (x < x1))
>   | Yes _ = nny1
>   | No  _ with (decSo (x1 <= x && x <= x2))
>     | Yes prf = s3 where
>         alpha : Double
>         alpha = (x - x1) / (x2 - x1)
>         s1 : 0.0 `LTE` alpha
>         s1 = convexLemma1 x1 x2 px2mx1 x (MkLTE (soAndElim1 (x1 <= x) (x <= x2) prf))
>         s2 : alpha `LTE` 1.0
>         s2 = convexLemma2 x1 x2 px2mx1 x (MkLTE (soAndElim2 (x1 <= x) (x <= x2) prf))
>         s3 : NonNegative (y1 * (1.0 - alpha) + y2 * alpha)
>         s3 = convexLemma y1 y2 alpha nny1 nny2 s1 s2
>     | No _ = nny2

> {-

> ---}


import Data.Vect

removeElem : (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem value {n = Z} (y :: []) {prf = There later} = absurd later
removeElem value {n = (S k)} (y :: ys) {prf = There later} = y :: removeElem value ys

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

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

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

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

multipleLetters : ValidInput (x :: (y :: xs)) -> Void
multipleLetters (Letter _) impossible

isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No notEmpty
isValidInput (x :: []) = Yes (Letter x)
isValidInput (x :: (y :: xs)) = No multipleLetters

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

readGuess : IO (x ** ValidInput x)
readGuess =
    do
        putStr "Guess: "
        x <- getLine
        case isValidString (toUpper x) of
            Yes prf => pure (_ ** prf)
            No contra =>
                do
                    putStrLn "Invalid guess"
                    readGuess

processGuess : (letter : Char) -> WordState (S guesses) (S letters) ->
    Either (WordState guesses (S letters)) (WordState (S guesses) letters)
processGuess letter (MkWordState word missing) =
    case isElem letter missing of
        Yes prf => Right (MkWordState word (removeElem letter missing))
        No contra => Left (MkWordState word missing)

game : WordState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st =
    do
        (_ ** Letter letter) <- readGuess
        case processGuess letter st of
            Left l =>
                do
                    putStrLn "Wrong!"
                    case guesses of
                        Z => pure (Lost l)
                        S k => game l

            Right r =>
                do
                    putStrLn "Right!"
                    case letters of
                        Z => pure (Won r)
                        S k => game r

main : IO ()
main =
    do
        result <- game {guesses = 2} (MkWordState "Test" ['T', 'E', 'S'])
        case result of
            Lost (MkWordState word missing) =>
                putStrLn ("You lose. The word was " ++ word)
            Won game =>
                putStrLn "You win!"


> module PNat.Properties

> import Syntax.PreorderReasoning

> import PNat.PNat
> import PNat.Operations
> import Nat.Positive
> import Unique.Predicates
> import Subset.Properties
> import Nat.LTProperties
> import Pairs.Operations

> %default total
> %access export

> ||| PNat is an implementation of DecEq
> implementation DecEq PNat where
>   decEq (Element m pm) (Element n pn) with (decEq m n)
>     | (Yes prf) = Yes (subsetEqLemma1 (Element m pm) (Element n pn) prf PositiveUnique)
>     | (No contra) = No (\ prf => contra (getWitnessPreservesEq prf))

> ||| PNat is an implementation of Show
> implementation Show PNat where
>   show = show . toNat

> |||
> predToNatLemma : (x : PNat) -> S (pred x) = toNat x
> predToNatLemma (Element _ (MkPositive {n})) = Refl

> |||
> toNatfromNatLemma : (m : Nat) -> (zLTm : Z `LT` m) -> toNat (fromNat m zLTm) = m
> {-
> toNatfromNatLemma  Z zLTz = absurd zLTz
> toNatfromNatLemma (S m) _ = Refl
> ---}
> --{-
> toNatfromNatLemma m zLTm = Refl
> ---}

> |||
> toNatLTLemma : (x : PNat) -> Z `LT` toNat x
> toNatLTLemma x = s2 where
>   s1 : Z `LT` (S (pred x))
>   s1 = ltZS (pred x)
>   s2 : Z `LT` (toNat x)
>   s2 = replace (predToNatLemma x) s1

> |||
> toNatEqLemma : {x, y : PNat} -> (toNat x) = (toNat y) -> x = y
> toNatEqLemma {x} {y} p = subsetEqLemma1 x y p PositiveUnique

> |||
> -- toNatMultLemma : {x, y : PNat} -> toNat (x * y) = (toNat x) * (toNat y)
> toNatMultLemma : {x, y : PNat} -> toNat (x * y) = (toNat x) * (toNat y)
> toNatMultLemma {x = (Element m pm)} {y = (Element n pn)} = Refl

> |||
> multOneRightNeutral : (x : PNat) -> x * (Element 1 MkPositive) = x
> multOneRightNeutral (Element m pm) =
>     ( (Element m pm) * (Element 1 MkPositive) )
>   ={ Refl }=
>     ( Element (m * 1) (multPreservesPositivity pm MkPositive) )
>   ={ toNatEqLemma (multOneRightNeutral m) }=
>     ( Element m pm )
>   QED

> |||
> multCommutative : (x : PNat) -> (y : PNat) -> x * y = y * x
> multCommutative (Element m pm) (Element n pn) =
>   let pmn = multPreservesPositivity pm pn in
>   let pnm = multPreservesPositivity pn pm in
>     ( Element (m * n) pmn )
>   ={ toNatEqLemma (multCommutative m n) }=
>     ( Element (n * m) pnm )
>   QED

> |||
> multAssociative : (x : PNat) -> (y : PNat) -> (z : PNat) ->
>                   x * (y * z) = (x * y) * z
> multAssociative (Element m pm) (Element n pn) (Element o po) =
>   let pno   = multPreservesPositivity pn po  in
>   let pmno  = multPreservesPositivity pm pno in
>   let pmn   = multPreservesPositivity pm pn  in
>   let pmno' = multPreservesPositivity pmn po in
>     ( (Element m pm) * ((Element n pn) * (Element o po)) )
>   ={ Refl }=
>     ( (Element m pm) * (Element (n * o) pno) )
>   ={ Refl }=
>     ( Element (m * (n * o)) pmno )
>   ={ toNatEqLemma (multAssociative m n o) }=
>     ( Element ((m * n) * o) pmno' )
>   ={ Refl }=
>     ( (Element (m * n) pmn) * (Element o po) )
>   ={ Refl }=
>     ( ((Element m pm) * (Element n pn)) * (Element o po) )
>   QED

> {-

> ---}


data Expr num = Val num
              | Add (Expr num) (Expr num)
              | Sub (Expr num) (Expr num)
              | Mul (Expr num) (Expr num)
              | Div (Expr num) (Expr num)
              | Abs (Expr num)

eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y
eval (Div x y) = eval x `div` eval y
eval (Abs x) = abs (eval x)

Num ty => Num (Expr ty) where
    (+) = Add
    (*) = Mul
    fromInteger = Val . fromInteger

Neg ty => Neg (Expr ty) where
    negate x = 0 - x
    (-) = Sub
    abs = Abs


-- Conway's Game Of Life in Idris
module Conway.Conway

import Data.Vect

-- | An individual Cell can either be alive or dead
public export
data CellState = Alive | Dead

public export
data Conway : Nat -> Nat -> Type where
   MkConway : (Vect m (Vect n CellState)) -> Conway m n

-- | Neighbours of a given cell, typically has 8 neighbours
--   (we'll count the missing neighbours from edges as dead)
data Neighbours : Nat -> Type where
   MkNeighbours : CellState -> (Vect n CellState) -> Neighbours n

-- | Count number of alive neighbours, guaranteed to be <= total
--   number of neighbours
numAlive : Neighbours n -> Fin (n + 1)
numAlive {n} nbs = case natToFin (numAlive' nbs) (n + 1) of
                  Just f => f
  where
    -- | Count number of alive neighbours
    numAlive' : Neighbours n -> Nat
    numAlive' (MkNeighbours _ v) = foldl accFn 0 v
      where accFn : Nat -> CellState -> Nat
            accFn cnt Alive = (cnt + 1)
            accFn cnt Dead =  (cnt + 0)

-- | Count the number of dead neighbours, guaranteed to be <= total
--   number of given neighbours
numDead : Neighbours n -> Fin (n + 1)
numDead {n} nbs = case natToFin (numDead' nbs) (n + 1) of
                  Just f => f
  where
    -- | Count number of dead neighbours
    numDead' : Neighbours n -> Nat
    numDead' (MkNeighbours _ v) = foldl accFn 0 v
      where accFn : Nat -> CellState -> Nat
            accFn cnt Alive = (cnt + 0)
            accFn cnt Dead =  (cnt + 1)

-- | Work out the new state of a cell given its neighbours
newCellState : Neighbours n -> CellState
newCellState (MkNeighbours cs v) with (cs, finToInteger $ numAlive $ MkNeighbours cs v)
  |  (Alive, 2) = Alive -- Stays alive
  |  (_, 3) = Alive -- Comes to life or stays alive
  |  (_, _) = Dead -- < 2 dies or stays dead and > 3 dies or stays dead

-- | Generate Neighbours for a given point in the board
getNeighbours : Conway m n -> Fin m -> Fin n -> Neighbours 8
getNeighbours (MkConway v) y x =
  (MkNeighbours cs [l, topL, top, topR, r, botR, bot, botL])

  where
        -- Check if Cell at given position is Dead Or Alive
        -- If out of bounds the Cell is considered Dead
        getDoA : Conway a b -> Integer -> Integer -> CellState
        getDoA {a} {b} (MkConway v) y x  =
          case getCell of
            Just c => c
            Nothing => Dead

           where getCell : Maybe CellState
                 getCell = do
                    row <- integerToFin y a
                    col <- integerToFin x b
                    return $ index col (index row v)

        ix : Integer
        ix = finToInteger x
        iy : Integer
        iy = finToInteger y

        cs = index x (index y v)

        l    = getDoA (MkConway v)  iy      (ix - 1)
        topL = getDoA (MkConway v) (iy - 1) (ix - 1)
        top  = getDoA (MkConway v) (iy - 1)  ix
        topR = getDoA (MkConway v) (iy - 1) (ix + 1)
        r    = getDoA (MkConway v)  iy      (ix + 1)
        botR = getDoA (MkConway v) (iy + 1) (ix + 1)
        bot  = getDoA (MkConway v) (iy + 1)  ix
        botL = getDoA (MkConway v) (iy + 1) (ix - 1)

-- | Generates a List of values 0 to N - 1
--   Guarantees that returned Vector has N values
sequence : (n : Nat) -> Vect n Nat
sequence n = reverse $ sequence' n
  where sequence' : (m : Nat) -> Vect m Nat
        sequence' Z = Nil
        sequence' (S n) = n::(sequence' n)

-- | Generates a Vector of values 0 to N - 1
--   Guarantees that returned Vector has N values
--   and every values is < N
export
sequenceFin : (n : Nat) -> Vect n (Fin n)
sequenceFin n = map n2f (sequence n)
  where n2f : Nat -> Fin n
        n2f m = case natToFin m n of
                  Just f => f

-- | Get the next state from the current state
export
iterateGame : Conway m n -> Conway m n
iterateGame {m} {n} (MkConway v) =  MkConway (map iterateRow (sequenceFin m))
  where iterateRow : Fin m -> Vect n CellState
        iterateRow y = map iteratePos (sequenceFin n)
        where iteratePos : Fin n -> CellState
              iteratePos x = newCellState (getNeighbours (MkConway v) y x)


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

interface Finite t where
  0 card   : Nat
  to     : t -> Fin card

implementation Finite (Fin k) where
  card = k
  to = id

interface BadFinite t where
  badcard   : Nat
  badto     : t -> Fin card

implementation BadFinite (Fin k) where
  badcard = k
  badto = id


module Main

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

identity : ty -> ty
identity x = x

the2 : (ty : Type) -> ty -> ty
the2 ty x = x

twice : (a -> a) -> a -> a
twice f x = f (f x)

-- Shape : Type
-- rotate : Shape -> Shape

longer : String -> String -> Nat
longer w1 w2
  = let l1 = length w1
        l2 = length w2
    in if l1 > l2 then l1 else l2

||| Calculates the value of the pythagoras equasion.
||| @x a value for the first side of a triangle
||| @y a value for the second side of a triangle
pythagoras : (x : Double) -> (y : Double) -> Double
pythagoras x y = sqrt (square x + square y)
  where
    square : Double -> Double
    square x = x * x

main : IO ()
main = do
  putStrLn $ cast $ twice double $ the2 Int $ identity 3
  putStrLn $ cast $ longer "Hello" "World!"
  putStrLn $ cast $ pythagoras 1 3


module Subst

import FinCmp
import Term

%default total

--------------------------------------------------------------
-- Begin: WEAKENING, I.E. ADDING UNUSED VARIABLES TO THE SCOPE

-- Abbreviate the name of the function 'weakenN'
-- from 'Data.Fin' (for better readability):
wkN : (n : Nat) -> Fin m -> Fin (m + n)
wkN = Data.Fin.weakenN

weakenContext : (m : Nat) -> (n : Nat) -> Term m -> Term (m + n)
weakenContext m n (TVar i)     = TVar (wkN n i)
weakenContext m n (TAbs x)     = TAbs (weakenContext (S m) n x)
weakenContext m n (TApp x y)   = TApp (weakenContext m n x)
                                      (weakenContext m n y)
weakenContext _ _ TZero         = TZero
weakenContext m n (TSucc x)     = TSucc (weakenContext m n x)
weakenContext m n (TPred x)     = TPred (weakenContext m n x)
weakenContext m n (TIfz x y z)  = TIfz (weakenContext m n x)
                                       (weakenContext m n y)
                                       (weakenContext m n z)

-- End: WEAKENING, I.E. ADDING UNUSED VARIABLES TO THE SCOPE
------------------------------------------------------------

-------------------------
-- Begin: TECHNICAL LEMMA

tightenBound :  {n : Nat} ->
                (j : Fin (S n)) -> (i : Fin (S n)) ->
                j :<: i ->
                (j_ : Fin n ** (finToNat j_ = finToNat j))
--
tightenBound             _         FZ      lt = absurd $ finNotLtZ lt
--
tightenBound {n = (S k)} FZ        (FS i') lt = (FZ ** Refl)
--
tightenBound {n = (S k)} (FS j') (FS i') lt =
  let (j'_ ** eq') = tightenBound {n = k} j' i' (finLtPred lt)
  in (FS j'_ ** cong eq')

-- End: TECHNICAL LEMMA
-----------------------

------------------------------------------------------------------------------
-- Begin: SUBSTITUTION PRESERVES SCOPING OF EXPRESSIONS IN THE LAMBDA CALCULUS

subst_var : Term 0 ->           -- Term that is subtituted in.
            (i : Fin (S n)) ->  -- The i-th variable (Var i) is substituted for.
            (j : Fin (S n)) ->  -- Substitution takes place inside the term (Var j).
            Term n
-- An actual substitution occurs only if "i = j".
subst_var {n} ts i j = case finCmpDec i j of
  CmpEq eq => weakenContext 0 n ts
  CmpLt lt => case j of
                   FZ    => absurd $ finNotLtZ lt
                   FS j' => TVar j'
  CmpGt gt => case i of
                   FZ    => absurd $ finNotLtZ gt
                   FS i' => let (j_ ** _) = tightenBound j (FS i') gt
                            in TVar j_

export subst : Term 0 ->           -- Term that is substituted in.
               (i : Fin (S n)) ->  -- The i-th varibale (Var i) is substituted for.
               Term (S n) ->       -- Substitution takes place inside this term.
               Term n
--
-- The hard part is substitution in expressions that
-- are variables, i.e. substitution in 'Var j'.
subst ts i (TVar j) = subst_var ts i j
--
-- Substitution in expressions that are not variables
-- is handled by recursing over (and substituting in)
-- subexpressions:
subst ts i (TAbs e)        = TAbs (subst ts (FS i) e)
subst ts i (TApp e1 e2)    = TApp (subst ts i e1) (subst ts i e2)
subst _  _ TZero           = TZero
subst ts i (TSucc e)       = TSucc (subst ts i e)
subst ts i (TPred e)       = TPred (subst ts i e)
subst ts i (TIfz e1 e2 e3) = TIfz (subst ts i e1) (subst ts i e2) (subst ts i e3)

-- End: SUBSTITUTION PRESERVES SCOPING OF EXPRESSIONS IN THE LAMBDA CALCULUS
----------------------------------------------------------------------------


module ElemsAreSame
import Data.Vect
--=======================================================================================================
--=======================================================================================================
--Elems are same
--=======================================================================================================
--=======================================================================================================
public export data ElemsAreSame : (xs:Vect n e) -> (ys:Vect n e) -> Type where
    ||| Empty vectors are the same
    NilIsNil :
        ElemsAreSame Nil Nil
    ||| Prepending x to two vectors with the same elements
    ||| Gives two vectors which still have the same elements
    PrependXIsPrependX :
        (x:e) -> ElemsAreSame zs zs' ->
        ElemsAreSame (x::zs) (x::zs')
    ||| Given two elements x and y
    ||| and a proof that two vectors zs and zs' have the same elements
    |||
    PrependXYIsPrependYX :
        (x:e) -> (y:e) -> ElemsAreSame zs zs' ->
        ElemsAreSame (x::(y::zs)) (y::(x::(zs')))
    -- NOTE: Probably could derive this last axiom from the prior ones
    SamenessIsTransitive :
        ElemsAreSame xs zs -> ElemsAreSame zs ys ->
        ElemsAreSame xs ys

export sameListsAreSame: (xs: Vect n e) -> ElemsAreSame xs xs
sameListsAreSame [] = NilIsNil
sameListsAreSame (x :: xs) = PrependXIsPrependX x (sameListsAreSame xs)

swap: ElemsAreSame xs ys -> ElemsAreSame ys xs
swap NilIsNil = NilIsNil
swap (PrependXIsPrependX x y) = PrependXIsPrependX x (swap y)
swap (PrependXYIsPrependYX x y z) = PrependXYIsPrependYX y x (swap z)
swap (SamenessIsTransitive x y) = SamenessIsTransitive (swap y)
                     (SamenessIsTransitive y (swap (SamenessIsTransitive x y)))

export swapHeads: ElemsAreSame (x::y::zs) us -> ElemsAreSame (y::x::zs) us
swapHeads {x} {y} {zs} {us} e = let xYIsYX = PrependXYIsPrependYX y x (sameListsAreSame zs) in
                                    SamenessIsTransitive xYIsYX e


module Signed

%access export
%default total

||| A signed binary number represented with `n` bits
data Signed : (n : Nat) -> Type where
  ||| Built from an underlying integer
  S : Integer -> Signed n

-- We could require a proof for this contructor that our Integer is indeed in
-- the range 0 -> 2*n-1. We don't bother because only (trusted) functions in
-- this module can use the constructor.

||| Cast instance for `Signed n` to an integer
Cast (Signed n) Integer where
  cast (S x) = x

||| Eq instacne for equality of `Signed n`
Eq (Signed n) where
  (==) (S x) (S y) = x==y

||| Ord instance for ordering of `Signed n`
Ord (Signed n) where
  compare (S x) (S y) = compare x y

||| MinBound instance for generating extremes of `Signed n`
MinBound (Signed n) where
  minBound = S . negate . cast . power 2 $ n `minus` 1

||| MaxBound instance for generating extremes of `Signed n`
MaxBound (Signed n) where
  maxBound = S $ cast (power 2 $ n `minus` 1) - 1

||| Safely create an `Signed n` from an Integer using saturation
saturate : Integer -> Signed n
saturate x = let tryS = S {n} x
             in if tryS > maxBound then maxBound else
                if tryS < minBound then minBound else tryS

||| Num instance for saturating arithmetic with `Signed n`
Num (Signed n) where
  (+) (S x) (S y) = saturate $ (x+y)
  (*) (S x) (S y) = saturate $ (x*y)
  fromInteger x   = saturate $ x

||| Show instance for printing `Signed n`
Show (Signed n) where
  show (S x) = "S" ++ show n ++ " " ++ show x


> module NonNegDouble.Operations

> import Data.So

> import Double.Predicates
> import Double.Postulates
> import Double.Properties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Predicates
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import Pairs.Operations

> %default total
> %access public export

> ||| Addition of positive double precision floating point numbers
> plus : NonNegDouble -> NonNegDouble -> NonNegDouble
> plus (Element x nnx) (Element y nny) = Element (x + y) (plusPreservesNonNegativity nnx nny)

> ||| Subtraction of positive double precision floating point numbers
> minus : (x : NonNegDouble) -> (y : NonNegDouble) -> {auto prf : y `LTE` x} -> NonNegDouble
> minus (Element x nnx) (Element y nny) {prf} = Element (x - y) (minusPreservesNonNegativity nnx nny prf)

> (-) : (x : NonNegDouble) -> (y : NonNegDouble) -> {auto prf : y `LTE` x} -> NonNegDouble
> (-) = minus

> ||| Multiplication of positive double precision floating point numbers
> mult : NonNegDouble -> NonNegDouble -> NonNegDouble
> mult (Element x nnx) (Element y nny) = Element (x * y) (multPreservesNonNegativity nnx nny)

> ||| Division of positive double precision floating point numbers
> div : NonNegDouble -> NonNegDouble -> NonNegDouble
> div (Element x nnx) (Element y nny) = Element (x / y) (divPreservesNonNegativity nnx nny)

> |||
> fromNat : (n : Nat) -> NonNegDouble
> fromNat  Z    = zero
> fromNat (S m) = one `plus` (fromNat m)

> {-

> ---}


infixr 5 ::

namespace List
    public export
    data List a = Nil | (::) a (List a)

namespace Stream
    public export
    data Stream a = (::) a (Inf (Stream a))

ones : Stream Integer
ones = num :: ones
  where
    num : Integer -- gratuitous where for a regression test!
    num = 1

data Nat = Z | S Nat

take : Nat -> Stream a -> List a
take Z xs = Nil
take (S k) (x :: xs) = List.(::) x (take k xs)


module Main

import Data.Vect
import Data.Stream

foo : List Char
foo = unpack $ pack $ take 4000 (repeat 'a')

factorialAux : Integer -> Integer -> Integer
factorialAux 0 a = a
factorialAux n a = factorialAux (n-1) (a*n)

factorial : Integer -> Integer
factorial n = factorialAux n 1

sum : Nat -> Nat
sum n = go 0 n where
  go : Nat -> Nat -> Nat
  go acc Z = acc
  go acc n@(S k) = go (acc + n) k

main : IO ()
main =
   do
      printLn $ factorial 100
      printLn $ factorial 10000
      printLn $ show $ the (Vect 3 String) ["red", "green", "blue"]
      printLn foo
      printLn (sum 50000)


import Data.Vect

{-

data Elem : a -> Vect k a -> Type where
   Here : Elem x (x :: xs)
   There : (later : Elem x xs) -> Elem x (y :: xs)

-}

total
removeElem : (value : a) -> (xs : Vect (S n) a) -> (witn : Elem value xs) ->
             Vect n a
removeElem value (value :: ys) Here = ys
{- removeElem value (y :: []) (There later) = absurd  later -}
removeElem {n = (S k)} value (y :: ys) (There later)
     = y :: removeElem value ys later

not_in_nil : Elem value [] -> Void
not_in_nil Here impossible
not_in_nil (There _) impossible


> module NonNegDouble.BasicOperations

> import Data.So

> import Double.Predicates
> import Double.Postulates
> import Double.Properties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import Pairs.Operations

> %default total
> %access public export

> |||
> mkNonNegDouble : (x : Double) -> {auto prf : 0.0 `LTE` x} -> NonNegDouble
> mkNonNegDouble x {prf} = Element x prf

> |||
> cast : (x : Double) -> {auto prf : 0.0 `LTE` x} -> NonNegDouble
> cast = mkNonNegDouble

> |||
> toDouble : NonNegDouble -> Double
> toDouble = getWitness

> |||
> fromDouble : (x : Double) -> NonNegative x -> NonNegDouble
> fromDouble x prf = Element x prf

> {-

> ---}


import Data.Vect

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

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

runStack : (stk : Vect inHeight Integer) ->
           StackCmd ty inHeight outHeight ->
           (ty, Vect outHeight Integer)
runStack stk (Push val) = ((), val :: stk)
runStack (val :: stk) Pop = (val, stk)
runStack (val :: stk) Top = (val, val :: stk)
runStack stk (Pure x) = (x, stk)
runStack stk (x >>= f) = let (x', newStk) = runStack stk x in
                             runStack newStk (f x')

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

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


module Main

import Data.Vect

readVectLen : (len : Nat) -> IO (Vect len String)
readVectLen Z = pure []
readVectLen (S k) = do x <- getLine
                       xs <- readVectLen k
                       pure (x :: xs)

data UnknownVect : Type -> Type where
  UVect : (len : Nat) -> Vect len a -> UnknownVect a

readUVect : IO (UnknownVect String)
readUVect = do x <- getLine
               if (x == "")
                  then pure (UVect _ [])
                  else do UVect _ xs <- readUVect
                          pure (UVect _ (x :: xs))

printVect : Show a => UnknownVect a -> IO ()
printVect (UVect len xs) = putStrLn (show xs ++ " (length " ++ show len ++ ")")

readVect : IO (len ** Vect len String)
readVect = do x <- getLine
              if (x == "")
                 then pure (_ ** [])
                 else do (_ ** xs) <- readVect
                         pure (_ ** x :: xs)

zipInputs : IO ()
zipInputs = do putStrLn "Enter vector #1 (blank line to end): "
               (len1 ** vec1) <- readVect
               putStrLn "Enter vector #2 (blank line to end): "
               (len2 ** vec2) <- readVect
               case exactLength len1 vec2 of
                    Nothing => do putStrLn "Vector are of different length. Try again"
                                  zipInputs
                    Just vec2' => do printLn (zip vec1 vec2')
                                     zipInputs

main : IO ()
main = ?main_rhs


import Data.Vect

tri : Vect 3 (Double, Double)
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

Position : Type
Position = (Double, Double)

tri' : Vect 3 Position
tri' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

Polygon : Nat -> Type
Polygon n = Vect n Position

tri'' : Polygon 3
tri'' = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]


module Mult

import public Nat

public export
mult : Nat -> Nat -> Nat
mult Z y = Z
mult (S k) y = plus y (mult k y)


module Data.Bool.Decidable

import Data.Void

public export
data Reflects : Type -> Bool -> Type where
  RTrue  :     p -> Reflects p True
  RFalse : Not p -> Reflects p False

public export
recompute : Dec a -> (0 x : a) -> a
recompute (Yes x) _ = x
recompute (No contra) x = absurdity $ contra x

public export
invert : {0 b : Bool} -> {0 p : Type} -> Reflects p b -> if b then p else Not p
invert {b = True} (RTrue  x ) = x
invert {b = False} (RFalse nx) = nx

public export
remember : {b : Bool} -> {0 p : Type} -> (if b then p else Not p) -> Reflects p b
remember {b = True } = RTrue
remember {b = False} = RFalse

public export
reflect : {c : Bool} -> Reflects p b -> (if c then p else Not p) -> b = c
reflect {c = True } (RTrue   x)  _ = Refl
reflect {c = True } (RFalse nx)  x = absurd $ nx x
reflect {c = False} (RTrue   x) nx = absurd $ nx x
reflect {c = False} (RFalse nx)  _ = Refl


module Data.Precision

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

-- TODO: this needs to be accessible (maybe from Data.Nat?)
private
greaterNat : Nat -> Nat -> Nat
greaterNat k j with (compare k j)
  greaterNat k j | LT = j
  greaterNat k j | EQ = k
  greaterNat k j | GT = k

-- Can construct all x with:
--   b > x >= 1
export
data Coefficient : (b : Nat) -> (n : Nat) -> Type where
  Coeff : (Fin (S b)) -> -- 0 - (b - 1) => 1 - b
          Vect n (Fin (S (S b))) ->
          Coefficient (S (S b)) n

export
Show (Coefficient 10 n) where
  show (Coeff x xs) =
    show (finToNat (weaken x)) ++ "." ++ concat (show . finToNat <$> xs)

private
eqDigits : Vect n (Fin (S (S b))) -> Vect m (Fin (S (S b))) -> Bool
eqDigits [] ys = all (== 0) ys
eqDigits xs [] = all (== 0) xs
eqDigits (x :: xs) (y :: ys) = x == y && eqDigits xs ys

private
eqCoeffs : Coefficient b n -> Coefficient b m -> Bool
eqCoeffs (Coeff x xs) (Coeff y ys) = x == y && eqDigits xs ys

private
compareDigits : Vect n (Fin (S (S b))) -> Vect m (Fin (S (S b))) -> Ordering
compareDigits [] ys =
  if all (== 0) ys
     then EQ
     else LT
compareDigits xs [] =
  if all (== 0) xs
     then EQ
     else GT
compareDigits (x :: xs) (y :: ys) =
  case compare x y of
       LT => LT
       EQ => compareDigits xs ys
       GT => GT

export
compareCoeffs : Coefficient b n -> Coefficient b m -> Ordering
compareCoeffs (Coeff x xs) (Coeff y ys) =
  case compare x y of
       LT => LT
       EQ => compareDigits xs ys
       GT => GT

private
plusCoeffs : Coefficient b n -> Coefficient b m -> (Coefficient b (greaterNat n m), Bool)

||| Can construct all x with:
|||   x > 0
public export
data Precision : (b : Nat) -> (n : Nat) -> Type where
  Prec : Coefficient b n -> Integer -> Precision b n

export
Show (Precision 10 n) where
  show (Prec coeff expon) = show coeff ++ "e" ++ show expon

-- TODO: export?
export
eqPrecs : Precision b n -> Precision b m -> Bool
eqPrecs (Prec coeff expon) (Prec coeff' expon') = expon == expon' && eqCoeffs coeff coeff'

-- TODO: export?
export
comparePrecs : Precision b n -> Precision b m -> Ordering
comparePrecs (Prec coeff expon) (Prec coeff' expon') =
  case compare expon expon' of
       LT => LT
       EQ => compareCoeffs coeff coeff'
       GT => GT

export
plusPrecs : Precision b n -> Precision b m -> Precision b (greaterNat n m)
plusPrecs (Prec x expon) (Prec y expon') with (compare expon expon')
  plusPrecs (Prec x expon) (Prec y expon') | LT = ?plusPrecs_rhs_1
  plusPrecs (Prec x expon) (Prec y expon') | EQ with (plusCoeffs x y)
    plusPrecs (Prec x expon) (Prec y expon') | EQ | (coeff, overhead) =
      Prec coeff $ if overhead
                      then expon + 1
                      else expon
  plusPrecs (Prec x expon) (Prec y expon') | GT = ?plusPrecs_rhs_3

export
multPrecs : Precision b n -> Precision b m -> Precision b (greaterNat n m)


record Person (age : Nat) where
  constructor MkPerson
  name : String

record Event where
  constructor MkEvent
  name : String
  organiser : Person a

record Meeting (year : Int) where
  constructor MkMeeting
  event : Event
  organiser : Person a

new_organiser : String -> List (Meeting x) -> List (Meeting x)
new_organiser n = map (record { event->organiser->name = n })

next_year : Meeting x -> Meeting (x+1)
next_year m = record { organiser->param_age
                          = record { organiser->param_age } m + 1,
                       event->organiser->param_age
                          = record { event->organiser->param_age } m + 1,
                       param_year = _ } m

fred : Person 20
fred = MkPerson "Fred"

jim : Person 29
jim = MkPerson {age=29} "Jim"

idm : Event
idm = MkEvent "Idris Developers Meeting" fred

idm_gbg : Meeting 2014
idm_gbg = MkMeeting idm jim

test : Meeting 2015
test = next_year idm_gbg

main : IO ()
main = do printLn (record { event->organiser->name } test)
          printLn (record { event->organiser->param_age } test)
          printLn (record { event->organiser->param_age } idm_gbg)
          printLn (record { organiser->param_age } test)
          printLn (record { organiser->param_age } idm_gbg)
          printLn (record { param_year } idm_gbg)


> module SequentialDecisionProblems.TabBackwardsInductionOptDefaults

> import Data.Vect

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.TabBackwardsInduction
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.CoreTheoryOptDefaults

> import Finite.Predicates
> import Finite.Operations
> import Opt.Operations
> import Rel.TotalPreorder

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

> SequentialDecisionProblems.TabBackwardsInduction.tcvalargmax {n} x r v ps =
>   Opt.Operations.argmax totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (tcval x r v ps)

> {-

> ---}


VendState : Type
VendState = (Nat, Nat)

data Input = COIN
           | VEND
           | CHANGE
           | REFILL Nat

data MachineCmd : Type ->
                  VendState ->
                  VendState ->
                  Type where
     InsertCoin : MachineCmd () (pounds, chocs) (S pounds, chocs)
     Vend       : MachineCmd () (S pounds, S chocs) (pounds, chocs)
     GetCoins   : MachineCmd () (pounds, chocs) (Z, chocs)
     Refill     : (bars : Nat) -> MachineCmd () (Z, chocs) (Z, bars + chocs)

     Display    : String -> MachineCmd () state state
     GetInput   : MachineCmd (Maybe Input) state state

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

data MachineIO : VendState -> Type where
  Do : MachineCmd a state1 state2 ->
       (a -> Inf (MachineIO state2)) -> MachineIO state1

namespace MachineDo
  (>>=) : MachineCmd a state1 state2 -> (a -> Inf (MachineIO state2)) ->
          MachineIO state1
  (>>=) = Do

mutual
  vend : MachineIO (pounds, chocs)
  vend {pounds = Z} = do Display "Insert a coin"
                         machineLoop
  vend {chocs = Z} = do Display "Out of stock"
                        machineLoop
  vend {pounds = (S k)} {chocs = (S j)} = do Vend
                                             Display "Enjoy!"
                                             machineLoop

  refill : (num : Nat) -> MachineIO (pounds, chocs)
  refill {pounds = Z} num =  do Refill num
                                machineLoop
  refill _ = do Display "Can't refill: Coins in machine"
                machineLoop

  machineLoop : MachineIO (pounds, chocs)
  machineLoop =
    do Just x <- GetInput
       | Nothing => do Display "Invalid input"
                       machineLoop
       case x of
            COIN => do InsertCoin
                       machineLoop
            VEND => vend
            CHANGE => do GetCoins
                         Display "Change returned"
                         machineLoop
            REFILL num => refill num


module Solver

import Decidable.Equality
import Control.Monad.State
import Data.Vect
import Data.Vect.Quantifiers
import System

-- %default total

-- Solver ----------------------------------------------------------------------

Cell : Nat -> Type
Cell n = Maybe (Fin n)

data Board : Nat -> Type where
  MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n

emptyBoard : Board n
emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing))

showElt : Cell n -> String
showElt Nothing = "."
showElt (Just x) = show (1 + (the Int (fromInteger (cast x))))

-- FIXME: Inline type decl should not be necessary here
showRow : Vect n (Cell n) -> String
showRow {n=n} xs = unwords (toList (the (Vect n String) (map showElt xs)))

unlines : Vect n String -> String
unlines Nil = ""
unlines (l::Nil) = l
unlines (l::ls) = pack (foldl addLine (unpack l) (map unpack ls))
  where
    addLine : List Char -> List Char -> List Char
    addLine w s = w ++ ('\n' :: s)

Show (Board n) where
  show (MkBoard rs) = unlines (map showRow rs)

updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a
updateAt FZ (x::xs) f = f x :: xs
updateAt (FS i) (x::xs) f = x :: updateAt i xs f

setCell : Board n -> (Fin n, Fin n) -> Fin n -> Board n
setCell (MkBoard b) (x, y) value = MkBoard (updateAt y b (\row => updateAt x row (const (Just value))))

getCell : Board n -> (Fin n, Fin n) -> Cell n
getCell (MkBoard b) (x, y) = index x (index y b)

anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b
anyElim _ f (Here p) = f p
anyElim f _ (There p) = f p

getRow : Fin n -> Board n -> Vect n (Cell n)
getRow i (MkBoard b) = index i b

getCol : Fin n -> Board n -> Vect n (Cell n)
getCol i (MkBoard b) = helper i b
  where
    helper : Fin n -> Vect m (Vect n a) -> Vect m a
    helper _ Nil = Nil
    helper i (xs::xss) = index i xs :: helper i xss

LegalNeighbors : Cell n -> Cell n -> Type
LegalNeighbors (Just x) (Just y) = Not (x = y)
LegalNeighbors _ _ = ()

legalNeighbors : (x : Cell n) -> (y : Cell n) -> Dec (LegalNeighbors x y)
legalNeighbors (Just x) (Just y) with (decEq x y)
  | Yes prf = No (\pf => pf prf)
  | No prf = Yes prf
legalNeighbors Nothing (Just _) = Yes ()
legalNeighbors (Just _) Nothing = Yes ()
legalNeighbors Nothing Nothing = Yes ()

rowSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getRow r b))
rowSafe b r v = all (legalNeighbors (Just v)) (getRow r b)

colSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getCol r b))
colSafe b r v = all (legalNeighbors (Just v)) (getCol r b)

Empty : Cell n -> Type
Empty {n=n} x = (the (Cell n) Nothing) = x

empty : (cell : Cell n) -> Dec (Empty cell)
empty Nothing = Yes Refl
empty (Just _) = No nothingNotJust

-- Predicate for legal cell assignments
LegalVal : Board n -> (Fin n, Fin n) -> Fin n -> Type
LegalVal b (x, y) val = (Empty (getCell b (x, y)), All (LegalNeighbors (Just val)) (getCol x b), All (LegalNeighbors (Just val)) (getRow y b))

legalVal : (b : Board n) -> (coord : (Fin n, Fin n)) -> (val : Fin n) -> Dec (LegalVal b coord val)
legalVal b (x, y) v =
  case rowSafe b y v of
    No prf => No (\(_, _, rf) => prf rf)
    Yes prf =>
      case colSafe b x v of
        No prf' => No (\(_, cf, _) => prf' cf)
        Yes prf' =>
          case Solver.empty (getCell b (x, y)) of
            No prf'' => No (\(ef, _, _) => prf'' ef)
            Yes prf'' => Yes (prf'', prf', prf)

Filled : Cell n -> Type
--Filled {n=n} x = Not (Empty x) -- TODO: Find out why this doesn't work
Filled {n=n} = (\x => Not (Empty x))
--Filled {n=n} x = the (Maybe (Fin n)) Nothing = x -> Void
--Filled {n=n} = \x => the (Maybe (Fin n)) Nothing = x -> Void

filled : (cell : Cell n) -> Dec (Filled cell)
filled Nothing = No (\f => f Refl)
filled (Just _) = Yes nothingNotJust

FullBoard : Board n -> Type
FullBoard (MkBoard b) = All (All Filled) b

fullBoard : (b : Board n) -> Dec (FullBoard b)
fullBoard (MkBoard b) = all (all filled) b

fins : Vect n (Fin n)
fins {n=Z} = Nil
fins {n=(S m)} = last :: map weaken fins

data LegalBoard : Board n -> Type where
  Base : LegalBoard (emptyBoard {n})
  Step : {b : Board n} -> {coords : (Fin n, Fin n)} -> {v : Fin n} -> LegalVal b coords v -> LegalBoard b -> LegalBoard (setCell b coords v)

CompleteBoard : Board n -> Type
CompleteBoard b = (LegalBoard b, FullBoard b)

indexStep : {i : Fin n} -> {xs : Vect n a} -> {x : a} -> index i xs = index (FS i) (x::xs)
indexStep = Refl

find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a)
       -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs)))
find _ Nil = Left Nil
find d (x::xs) with (d x)
  | Yes prf = Right (x ** (prf, (FZ ** Refl)))
  | No prf =
    case find d xs of
      Right (y ** (prf', (i ** prf''))) =>
        Right (y ** (prf', (FS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf'')))
      Left prf' => Left (prf::prf')

findEmptyInRow : (xs : Vect n (Cell n)) -> Either (All Filled xs) (i : Fin n ** Empty (index i xs))
findEmptyInRow xs =
  case find {P=Empty} empty xs of
    Right (_ ** (pempty, (i ** pidx))) => Right (i ** trans pempty pidx)
    Left p => Left p

emptyCell : (b : Board n) -> Either (FullBoard b) (c : (Fin n, Fin n) ** Empty (getCell b c))
emptyCell (MkBoard rs) =
  case helper rs of
    Left p => Left p
    Right (ri ** (ci ** pf)) => Right ((ci, ri) ** pf)
  where
    helper : (rs : Vect m (Vect n (Cell n)))
             -> Either (All (All Filled) rs) (r : Fin m ** (c : Fin n ** Empty (index c (index r rs))))
    helper Nil = Left Nil
    helper (r::rs) =
      case findEmptyInRow r of
        Right (ci ** pf) => Right (FZ ** (ci ** pf))
        Left prf =>
          case helper rs of
            Left prf' => Left (prf::prf')
            Right (ri ** (ci ** pf)) => Right (FS ri ** (ci ** pf))

tryValue : {b : Board (S n)} -> LegalBoard b -> (c : (Fin (S n), Fin (S n))) -> Empty (getCell b c) -> (v : Fin (S n))
           -> Either (Not (LegalVal b c v)) (b' : Board (S n) ** LegalBoard b')
tryValue {b=b} l c _ v =
  case legalVal b c v of
    No prf => Left prf
    Yes prf => Right (_ ** Step prf l)

nullBoardFull : (b : Board Z) -> FullBoard b
nullBoardFull (MkBoard Nil) = Nil

-- TODO: Prove complete by induction on illegal values wrt. some base state, e.g. every value is illegal for 123\21_\3_2
fillBoard : (b : Board n) -> LegalBoard b -> Maybe (b' : Board n ** CompleteBoard b')
fillBoard {n=Z} b l = Just (b ** (l, nullBoardFull b))
fillBoard {n=(S n)} b l with (emptyCell b)
  | Left full = Just (b ** (l, full))
  | Right (coords ** p) = recurse last
  where
    %assert_total
    tryAll : (v : Fin (S n)) -> (Fin (S n), Maybe (b' : Board (S n) ** LegalBoard b'))
    tryAll v = --trace ("Trying " ++ show (the Int (cast v))) $
      case tryValue l coords p v of
        Right success => (v, Just success)
        Left _ => -- TODO: Prove unsolvable
          case v of
            FS k => tryAll (weaken k)
            FZ => (v, Nothing)

    %assert_total
    recurse : Fin (S n) -> Maybe (b' : Board (S n) ** CompleteBoard b')
    recurse start =
      case tryAll start of
        (_, Nothing) => Nothing
        (FZ, Just (b' ** l')) => fillBoard b' l'
        (FS next, Just (b' ** l')) =>
          case fillBoard b' l' of
            Just solution => Just solution
            Nothing => recurse (weaken next)

-- Parser ----------------------------------------------------------------------

ParseErr : Type
ParseErr = String

Parser : Nat -> Type
Parser n = Either ParseErr (b : Board n ** LegalBoard b)

mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b)
mapM _ Nil = pure Vect.Nil
mapM f (x::xs) = do
  x' <- f x
  xs' <- mapM f xs
  pure (Vect.(::) x' xs')

parseToken : String -> Either String (Cell n)
parseToken "." = pure Nothing
parseToken "0" = Left "Got cell 0, expected 1-based numbering"
parseToken x = map Just (tryParseFin ((cast x) - 1))
  where
    tryParseFin : Int -> Either String (Fin n)
    tryParseFin {n=Z} _ = Left ("Given cell " ++ x ++ " out of range")
    tryParseFin {n=S k} 0 = pure FZ
    tryParseFin {n=S k} x =
      case tryParseFin {n=k} (x-1) of
        Left err => Left err
        Right fin => pure (FS fin)

length : Vect n a -> Nat
length {n=n} _ = n

parseCols : {b : Board n} -> Fin n -> LegalBoard b -> Vect n String -> Parser n
parseCols {n=Z} _ l _ = Right (_ ** l)
parseCols {n=S k} row l cs = helper last l
  where
    step : {b : Board (S k)} -> LegalBoard b -> Fin (S k) -> Parser (S k)
    step {b=b} l x = do
      let here = (x, row) -- TODO: Determine why naming this makes idris smarter
      tok <- parseToken {n=S k} (index x cs)
      case tok of
        Nothing => pure (_ ** l)
        Just t =>
           case legalVal b here t of
             Yes prf => Right (_ ** Step prf l)
             No _ => Left ("Illegal cell " ++ index x cs)

    helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)
    helper FZ l = step l FZ
    helper (FS k) l = do
      (_ ** next) <- step l (FS k)
      helper (weaken k) next

parseRows : (b : Board n) -> LegalBoard b -> Vect n String -> Parser n
parseRows {n=Z}   _ l _  = Right (_ ** l)
parseRows {n=S k} _ l rs = helper last l
  where
    step : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)
    step i l =
      let cs = fromList (words (index i rs)) in
      case decEq (Parser.length cs) (S k) of
        No _  => Left "Row length not equal to column height"
        Yes prf => parseCols i l (replace {P=\n => Vect n String} prf cs)

    helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)
    helper FZ l = step FZ l
    helper (FS k) l = do
      (_ ** next) <- step (FS k) l
      helper (weaken k) next

parse : String -> Either String (n : Nat ** (b : Board n ** LegalBoard b))
parse str =
  let rows = fromList (lines str) in
  case parseRows {n=length rows} emptyBoard Base rows of
    Left msg => Left msg
    Right board => pure (_ ** board)

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

main : IO ()
main = do
  args <- getArgs
  case args of
    [_, path] => do
      f <- readFile path
      case f of
        Left _err => putStrLn $ "Error reading file: " ++ path
        Right f' =>
          case parse f' of
            Left err => putStrLn err
            Right (_ ** (board ** legal)) => do
              putStrLn "Got board:"
              printLn board
              putStrLn "Solving..."
              case fillBoard board legal of
                Nothing => putStrLn "No solution found"
                Just (solved ** _) => do
                  putStrLn "Solution found:"
                  printLn solved
    [self] => putStrLn ("Usage: " ++ self ++ " <board file>")


-- ------------------------------------- [ Data.Functor.Foldable.Instances.idr ]
-- Module      : Data.Functor.Foldable.Internal.Instances
-- Description : Instances of 'Recursive' and 'Corecursive' for various
--               things.
-- --------------------------------------------------------------------- [ EOH ]
module Data.Functor.Foldable.Instances

import Control.Monad.Free
import Data.Functor.Foldable.Mod

%access public export

implementation Base Nat Maybe where

implementation Recursive Maybe Nat where
  project Z = Nothing
  project (S a) = Just a

implementation Corecursive Maybe Nat where
  embed Nothing = Z
  embed (Just a) = S a

||| Fix-point data type for exotic recursion schemes of various kinds
data Fix : (Type -> Type) -> Type where
  Fx : f (Fix f) -> Fix f

||| Nu fix-point functor for coinduction
codata Nu : (f : Type -> Type) -> Type -> Type where
  NuF : ((a -> f a) -> a) -> b -> Nu f b

||| Mu fix-point functor for induction
data Mu : (Type -> Type) -> Type where
  MuF : ({a : Type} -> (a -> f a) -> a) -> Mu f

implementation Functor (Nu f) where
  map g (NuF h a) = NuF h (g a)

implementation Base t (Nu f) where

implementation Base (Fix t) f where

implementation Base (Mu f) f where

||| Create a fix-point with a functor
fix : f (Fix f) -> Fix f
fix = Fx

||| Unfix a 'Fix f'
unfix : Fix f -> f (Fix f)
unfix (Fx x) = x

data ListF : Type -> Type -> Type where
  NilF : ListF _ _
  Cons : a -> b -> ListF a b

data StreamF : Type -> Type -> Type where
  Pipe : a -> b -> StreamF a b

implementation Functor (StreamF a) where
  map f (Pipe a b) = Pipe a (f b)

implementation Functor (ListF a) where
  map _ NilF       = NilF
  map f (Cons a b) = Cons a (f b)

implementation Base b (ListF a) where

implementation Base b (StreamF a) where

||| Lambek's lemma assures us this function always exists.
lambek : (Recursive f t, Corecursive f t) => (t -> f t)
lambek = cata (map embed)

||| The dual of Lambek's lemma.
colambek : (Recursive f t, Corecursive f t) => (f t -> t)
colambek = ana (map project)

implementation Recursive (StreamF a) (Stream a) where
  project (x::xs) = Pipe x xs

implementation Corecursive (StreamF a) (Stream a) where
  embed (Pipe x xs) = x::xs

implementation Recursive (ListF a) (List a) where
  project [] = NilF
  project (x::xs) = Cons x xs

implementation Corecursive (ListF a) (List a) where
  embed NilF = []
  embed (Cons x xs) = x::xs


module Data.Primitives.Views

-- We need all the believe_mes and asserts throughout this file because we're
-- working with primitive here! We also have separate implementations per
-- primitive, rather than using interfaces, because we're only going to trust
-- the primitive implementations.

namespace IntegerV
  ||| View for expressing a number as a multiplication + a remainder
  public export
  data Divides : Integer -> (d : Integer) -> Type where
       DivByZero : Divides x 0
       DivBy : (div, rem : _) ->
               (prf : rem >= 0 && rem < d = True) ->
               Divides ((d * div) + rem) d

  ||| Covering function for the `Divides` view
  public export
  divides : (val : Integer) -> (d : Integer) -> Divides val d
  divides val 0 = DivByZero
  divides val d
         = assert_total $
             let dividend = if d < 0 then -(val `div` abs d)
                                     else val `div` d
                 remainder = abs (val - dividend * d) in
                 believe_me (DivBy {d} dividend remainder
                            (believe_me (Refl {x = True})))

  ||| View for recursion over Integers
  public export
  data IntegerRec : Integer -> Type where
       IntegerZ : IntegerRec 0
       IntegerSucc : IntegerRec (n - 1) -> IntegerRec n
       IntegerPred : IntegerRec ((-n) + 1) -> IntegerRec (-n)

  ||| Covering function for `IntegerRec`
  public export
  integerRec : (x : Integer) -> IntegerRec x
  integerRec 0 = IntegerZ
  integerRec x = if x > 0 then IntegerSucc (assert_total (integerRec (x - 1)))
                      else believe_me (IntegerPred {n = -x}
                                (assert_total (believe_me (integerRec (x + 1)))))

namespace IntV
  ||| View for expressing a number as a multiplication + a remainder
  public export
  data Divides : Int -> (d : Int) -> Type where
       DivByZero : IntV.Divides x 0
       DivBy : (div, rem : _) ->
               (prf : rem >= 0 && rem < d = True) ->
               IntV.Divides ((d * div) + rem) d

  -- I have assumed, but not actually verified, that this will still
  -- give a right result (i.e. still adding up) when the Ints overflow.
  -- TODO: Someone please check this and fix if necessary...

  ||| Covering function for the `Divides` view
  public export
  divides : (val : Int) -> (d : Int) -> Divides val d
  divides val 0 = DivByZero
  divides val d
         = assert_total $
             let dividend = if d < 0 then -(val `div` abs d)
                                     else val `div` d
                 remainder = abs (val - dividend * d) in
                 believe_me (DivBy {d} dividend remainder
                            (believe_me (Refl {x = True})))

  ||| View for recursion over Ints
  public export
  data IntRec : Int -> Type where
       IntZ : IntRec 0
       IntSucc : IntRec (n - 1) -> IntRec n
       IntPred : IntRec ((-n) + 1) -> IntRec (-n)

  ||| Covering function for `IntRec`
  public export
  intRec : (x : Int) -> IntRec x
  intRec 0 = IntZ
  intRec x = if x > 0 then IntSucc (assert_total (intRec (x - 1)))
                      else believe_me (IntPred {n = -x}
                                (assert_total (believe_me (intRec (x + 1)))))


> module EscardoOliva.TestSelectionFunction

> import EscardoOliva.SelectionFunction

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

> xs : List Int
> xs = [0,3,2,-1,0,9,-7]

> min : Int
> min = arginf xs id

> max : Int
> max = argsup xs id


module Test.TestFixed

import Test.TestUtil
import Data.Time.Clock.Internal.Fixed

getDec : Integer -> Dec
getDec x = MkFixed x

getPico : Integer -> Pico
getPico x = MkFixed x

export
testAdd: IO ()
testAdd = do
  let a = getPico 1
  let b = getPico 1
  assertEq "testAdd" (a + b) 2 ""

export
testSub: IO ()
testSub = do
  let a = getPico 5
  let b = getPico 3
  assertEq "testSub" (a - b) 2 ""

export
testNegate: IO ()
testNegate = do
  let a = negate $ getPico 5
  assertEq "testNegate" a (-5) (show a)

export
testMultFixed: IO ()
testMultFixed = do
  let a = getDec 123
  let b = getDec 25
  let result = a * b
  assertEq "testMultFixed" result 30 (show result)

export
testFracDiv: IO ()
testFracDiv = do
  let a = getDec 3456
  let b = getDec 1234
  let result = a / b
  assertEq "testMultFixed" result 280 (show result)

export
testRecip: IO ()
testRecip = do
  let a = getDec 3456
  let result = recip a
  assertEq "testRecip" result 2 (show result)