module ListTk

import Tk

(&&) : So p -> So q -> So (p && q)
Oh && Oh = Oh

soSplit : So (p && q) -> (So p, So q)
soSplit {p=True} Oh = (Oh, Oh)

Equ a => Equ (List a) where
  []      ==. []      = True
  (x::xs) ==. (y::ys) = x ==. y && xs ==. ys
  _       ==. _       = False

  eqRefl []      = Oh
  eqRefl (x::xs) = eqRefl x && eqRefl xs

  eqSymm []      []      = Refl
  eqSymm []      (_::_)  = Refl
  eqSymm (_::_)  []      = Refl
  eqSymm (x::xs) (y::ys) = rewrite eqSymm x y in
                           rewrite eqSymm xs ys in
                           Refl

  eqTrans []      []       []     _ _ = Oh
  eqTrans (x::xs) (y::ys) (z::zs) p q with (soSplit p, soSplit q)
    | ((rxy, rxys), (ryz, ryzs)) = eqTrans x y z rxy ryz && eqTrans xs ys zs rxys ryzs

  neqIsNotEq xs ys with (xs ==. ys)
    | True  = Refl
    | False = Refl

Ordu a => Ordu (List a) where
  []     <. (_::_) = True
  _      <. []     = False
  (x::_) <. (y::_) = x <. y

  ltArefl []     = Oh
  ltArefl (x::_) = ltArefl x

  ltAsymm []     []     _ = Oh
  ltAsymm []     (_::_) _ = Oh
  ltAsymm (x::_) (y::_) p = ltAsymm x y p

  ltTrans []     (_::_) (_::_) _ _ = Oh
  ltTrans (x::_) (y::_) (z::_) p q = ltTrans x y z p q

  lteIsLtOrE _ _ = Refl

  gtInverseOfLt _ _ = Refl

  gteIsGtOrE n m = rewrite eqSymm n m in Refl


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

import Data.Vect

-- 6.1.1

Position : Type
Position = (Double, Double)

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

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

tri2 : Polygon 3
tri2 = [(0, 0), (0, 0), (0, 0)]

-- 6.1.2

StringOrInt : Bool -> Type
StringOrInt True = Int
StringOrInt False = String

valToString
  :   (isInt : Bool)
  ->  (case isInt of
        True => Int
        False => String)
  -> String
valToString False x = trim x
valToString True x = cast x

-- 6.2.1

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

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

adder1 : (numargs : Nat) -> (acc : Int) -> AdderType numargs Int
adder1 = adder

-- 6.2.2

data Format : Type where
  Number : Format -> Format
  Str    : Format -> Format
  Lit    : String -> Format -> Format
  End    : Format

PrintfType : Format -> Type
PrintfType (Number x) = Int -> PrintfType x
PrintfType (Str x) = String -> PrintfType x
PrintfType (Lit x y) = PrintfType y
PrintfType End = String

toFormat : List Char -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
  Lit l f => Lit (strCons c l) f
  fmt => Lit (strCons c "") fmt

printFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printFmt (Number x) acc = \num => printFmt x (acc ++ show num)
printFmt (Str x) acc = \str => printFmt x (acc ++ str)
printFmt (Lit x y) acc = printFmt y (acc ++ x)
printFmt End acc = acc

printf : (s : String) -> (PrintfType (toFormat (unpack s)))
printf fmt = printFmt (toFormat (unpack fmt)) ""

main : IO ()
main = do
  printLn tri
  printLn tri2
  printLn (valToString False "  string  ")
  printLn (valToString True 42)
  printLn (adder1 0 10)
  printLn (adder1 1 10 15)
  printLn (adder1 2 1 4 7)
  putStrLn (printf "Hello!")
  putStrLn (printf "Answer : %d" 42)
  putStrLn (printf "%s numner %d" "Page" 97)


module Data.List.Elem.Extra

import Data.List
import Data.List.Elem

%default total

||| Proof that an element is still inside a list if we append to it.
public export
elemAppLeft : (xs, ys : List a) -> (prf : Elem x xs) -> Elem x (xs ++ ys)
elemAppLeft (x :: xs) ys Here = Here
elemAppLeft (x :: xs) ys (There prf2) = There $ elemAppLeft xs ys prf2

||| Proof that an element is still inside a list if we prepend to it.
public export
elemAppRight :  (ys, xs : List a) -> (prf : Elem x xs) -> Elem x (ys ++ xs)
elemAppRight [] xs prf = prf
elemAppRight (y :: ys) xs prf = There $ elemAppRight ys xs prf

||| Proof that membership on append implies membership in left or right sublist.
public export
elemAppLorR : (xs, ys : List a)
           -> (prf : Elem k (xs ++ ys))
           -> Either (Elem k xs) (Elem k ys)
elemAppLorR [] [] prf = absurd prf
elemAppLorR [] _ prf = Right prf
elemAppLorR (x :: xs) [] prf =
  Left $ rewrite sym $ appendNilRightNeutral xs in prf
elemAppLorR (x :: xs) _ Here = Left Here
elemAppLorR (x :: xs) ys (There prf) = mapFst There $ elemAppLorR xs ys prf

||| Proof that x is not in (xs ++ ys) implies proof that x is not in xs.
public export
notElemAppLeft : (xs, ys : List a)
              -> (prf : Not (Elem x (xs ++ ys)))
              -> Not (Elem x xs)
notElemAppLeft xs ys prf = prf . elemAppLeft xs ys

||| Proof that x is not in (xs ++ ys) implies proof that x is not in ys.
public export
notElemAppRight : (ys, xs : List a)
               -> (prf : Not (Elem x (xs ++ ys)))
               -> Not (Elem x ys)
notElemAppRight ys xs prf = prf . elemAppRight xs ys


> module Functor.Properties

> import Functor.Predicates

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

* Monotonicity and naturality:

> ||| Composing a monotone measure with a natural transformation
> ||| yields a monotone measure
> monotoneNaturalLemma: {B, C : Type} -> {F : Type -> Type} -> (Functor F) =>
>                       (LTE_B : B -> B -> Type) ->
>                       (LTE_C : C -> C -> Type) ->
>                       (measure : F B -> C) ->
>                       Monotone LTE_B LTE_C measure ->
>                       (t : {A : Type} -> F A -> F A) ->
>                       Natural t ->
>                       Monotone LTE_B LTE_C (measure . t)
> monotoneNaturalLemma LTE_B LTE_C m mm t nt = mmt where
>   mmt f g p x = let s1 = mm f g p (t x) in
>                 let s2 = replace {P = \ X => m X `LTE_C` m (map g (t x))} (sym (nt f x)) s1 in
>                 let s3 = replace {P = \ X => m (t (map f x)) `LTE_C` m X} (sym (nt g x)) s2 in
>                 s3

> {-
> monotoneNaturalLemma {B} {C} {F} LTE_B LTE_C m mm t nt = mmt where
>   mmt : Monotone {B} {C} {F} LTE_B LTE_C (m . (t {A = B}))
>   mmt = ?lala
>   mmt A f g p x = s3 where
>     s1 : m (map f (t A x)) `LTE_C` m (map g (t A x))
>     s1 = mm A f g p (t A x)
>     s2 : m ((t B) (map f x)) `LTE_C` m (map g (t A x))
>     s2 = replace {P = \ X => m X `LTE_C` m (map g (t A x))} (sym (nt f x)) s1
>     s3 : m ((t B) (map f x)) `LTE_C` m ((t B) (map g x))
>     s3 = replace {P = \ X => m ((t B) (map f x)) `LTE_C` m X} (sym (nt g x)) s2
> ---}


> module Decidable.Predicates

> %default total
> %access public export

> Dec0 : Type -> Type
> Dec0 = Dec

> Dec1 : {A : Type} -> (P : A -> Type) -> Type
> Dec1 {A} P = (a : A) -> Dec0 (P a)

> DecEq0 : Type -> Type
> DecEq0 A = (a1 : A) -> (a2 : A) -> Dec (a1 = a2)

> DecEq1 : {A : Type} -> (P : A -> Type) -> Type
> DecEq1 {A} P = (a : A) -> DecEq0 (P a)


import Data.Vect

Position : Type
Position = (Double, Double)

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 chap06

import Data.Vect

N : (n : Nat) -> Type
N n = (n : Nat ** Vect n Double)

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

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

adder : (numargs : Nat) -> (acc : Int) -> AdderType numargs
adder Z acc = acc
adder (S k) acc = \next => adder k (next + acc)

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

genericAdder : Num numType => (numargs : Nat) -> numType -> GenericAdderType numargs numType
genericAdder Z acc = acc
genericAdder (S k) acc = \next => genericAdder k (next + acc)

Position : Type
Position = (Double, Double)

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

tri : Polygon 3
tri = [(0, 0), (1, 1), (-1, -1)]
-- tri = [(?tri_rhs1, ?tri_rhs2), (?tri_rhs3, ?tri_rhs4), (?tri_rhs5, ?tri_rhs6)]

IntOrString : Bool -> Type
IntOrString False = String
IntOrString True = Int

-- dependent pattern matching
getIntOrString : (isInt : Bool) -> IntOrString isInt
getIntOrString False = "zero"
getIntOrString True = 0

-- converts either a String or an Int to a canonical String representation
valToString : (isInt : Bool) -> IntOrString isInt -> String
valToString False x = trim x
valToString True x = cast x

valToString' : (isInt : Bool) -> (case isInt of
                                       False => String
                                       True => Int) -> String
valToString' False x = trim x
valToString' True x = cast x


module NonZeroInt

%access public export
%default total
%auto_implicits off

record NonZeroInt where
  constructor MkNonZeroInt
  num : Int
  nonZero : Not (num = 0)

postulate
zeroProductProperty : (a, b : Int) -> a * b = 0 -> Either (a = 0) (b = 0)

productOfNonZeroIsNonZero : NonZeroInt -> NonZeroInt -> NonZeroInt
productOfNonZeroIsNonZero (MkNonZeroInt num1 nonZero1) (MkNonZeroInt num2 nonZero2) = MkNonZeroInt (num1 * num2) prf
  where
    prf = \prodIsZero => case zeroProductProperty num1 num2 prodIsZero of
      Left  aIsZero => nonZero1 aIsZero
      Right bIsZero => nonZero2 bIsZero


-- DepPairs.idr

-- Demonstrates dependendent pairs by reading
-- 2 Vect of variable length
-- and zip them together

import Data.Vect

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

||| Zip to Vect of unknown length
zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
               (len1 ** vec1) <- readVect
               putStrLn "Enter second vector (blank line to end):"
               (len2 ** vec2) <- readVect
               case exactLength len1 vec2 of
                    Nothing => putStrLn "Vectors have different length"
                    Just vec2' => printLn (zip vec1 vec2')


data SnocList: List a -> Type where
  Empty: SnocList []
  Snoc: (rec: SnocList xs) -> SnocList (xs ++ [x])

snocListHelp: (snoc: SnocList input) -> (rest: List a) -> SnocList (input ++ rest)
snocListHelp {input} snoc [] = rewrite appendNilRightNeutral input in snoc
snocListHelp {input} snoc (x :: xs) =
  rewrite appendAssociative input [x] xs in
          snocListHelp (Snoc snoc) xs
-- snocListHelp {input} snoc [] = ?noRewrite1 snoc
-- snocListHelp {input} snoc (x :: xs) = ?noRewrite2 (snocListHelp (Snoc snoc {x}) xs)

snocList: (xs: List a) -> SnocList xs
snocList xs = snocListHelp Empty xs

total myReverseHelper: (input: List a) -> SnocList input -> List a
myReverseHelper []          Empty      = []
myReverseHelper (xs ++ [x]) (Snoc rec) = x :: myReverseHelper xs rec

total myReverse: List a -> List a
myReverse input with (snocList input)
  myReverse []          | Empty       = []
  myReverse (xs ++ [x]) | (Snoc rec)  = x :: myReverse xs | rec

total isSuffix: Eq a => List a -> List a -> Bool
isSuffix input1 input2 with (snocList input1)
  isSuffix []          input2 | Empty      = True
  isSuffix (xs ++ [x]) input2 | (Snoc xsrec) with (snocList input2)
    isSuffix (xs ++ [x]) []          | (Snoc xsrec) | Empty        = False
    isSuffix (xs ++ [x]) (ys ++ [y]) | (Snoc xsrec) | (Snoc ysrec) =
      if x == y
      then isSuffix xs ys | xsrec | ysrec
      else False

list100: List Int
list100 = [1..100]

suffix: List Int
suffix = [90..100]

notSuffix: List Int
notSuffix = [1..10]


> module GeenricSimpleProb.BasicOperations

> import Data.List
> import Syntax.PreorderReasoning

> import GenericSimpleProb.SimpleProb
> import Fun.Operations
> import List.Operations
> import List.Properties

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

> |||
> toList : {A, B : Type} -> SimpleProb A B -> List (A, B)
> toList (MkSimpleProb aps _) = aps

> |||
> normalize : {A, B : Type} -> DecEq B => SimpleProb A B -> SimpleProb A B
> normalize {A} (MkSimpleProb Nil sum) = MkSimpleProb Nil sum
> normalize {A} (MkSimpleProb (ap :: Nil) sum) = MkSimpleProb (ap :: Nil) sum
> normalize {A} {B} (MkSimpleProb (ap :: ap' :: aps) sum) = MkSimpleProb aps' sum' where
>   aps' : List (A, B)
>   aps' = discardBySndZero (ap :: ap' :: aps)
>   sum' : sumMapSnd aps' = 1
>   sum' = trans (discardBySndZeroLemma (ap :: ap' :: aps)) sum

> {-

> |||
> support : {A : Type} -> SimpleProb A -> List A
> support sp = map fst (toList (normalize sp))

> |||
> probs : {A : Type} -> SimpleProb A -> List NonNegRational
> probs sp = map snd (toList (normalize sp))

> ||| 'prob sp a' is the probability of 'a' according to 'sp'
> prob : {A : Type} -> (Eq A) => SimpleProb A -> A -> NonNegRational
> prob (MkSimpleProb aps _) a = foldr f 0 aps where
>   f : (A, NonNegRational) -> NonNegRational -> NonNegRational
>   f (a', p') p = if (a == a') then p + p' else p

> ||| Make a SimpleProb in which all elements of a list have the same
> ||| probablility. If the list has no duplicates, this results in a
> ||| uniform probability distribution
> mkSimpleProb : {A : Type} -> (as : List A) -> ListOperations.NonEmpty as -> SimpleProb A
> mkSimpleProb      Nil      prf = absurd prf
> mkSimpleProb {A} (a :: as) _   = MkSimpleProb aps s1p where
>   m : Nat
>   m = length as
>   ps : List NonNegRational
>   ps = replicate (S m) (fromFraction (1, Element (S m) MkPositive))
>   sps : sum ps = fromFraction (S m, Element (S m) MkPositive)
>   sps = sumLemma0 (S m) m
>   aps : List (A, NonNegRational)
>   aps = zip (a :: as) ps
>   leq : length (a :: as) = length ps
>   leq = ( length (a :: as) )
>       ={ Refl }=
>         ( S (length as) )
>       ={ Refl }=
>         ( S m )
>       ={ sym (lengthReplicateLemma (S m) (fromFraction (1, Element (S m) MkPositive))) }=
>         ( length (replicate (S m) (fromFraction (1, Element (S m) MkPositive))) )
>       ={ Refl }=
>         ( length ps )
>       QED
>   s1p : sumMapSnd aps = 1
>   s1p = ( sumMapSnd aps )
>       ={ sumMapSndUnzipLemma aps }=
>         ( sum (snd (unzip aps)) )
>       ={ Refl }=
>         ( sum (snd (unzip (zip (a :: as) ps))) )
>       ={ cong {f = sum . snd} (unzipZipLemma (a :: as) ps leq) }=
>         ( sum (snd ((a :: as), ps)) )
>       ={ cong {f = sum} Refl }=
>         ( sum ps )
>       ={ sps }=
>         ( fromFraction (S m, Element (S m) MkPositive) )
>       ={ fromFractionEqLemma (S m, Element (S m) MkPositive) (S Z, Element (S Z) MkPositive) (multCommutative (S m) (S Z)) }=
>         ( fromFraction (S Z, Element (S Z) MkPositive) )
>       ={ Refl }=
>         ( 1 )
>       QED

> ---}

> {-

> prob : {A : Type} -> (DecEq A) => SimpleProb A -> A -> NonNegRational
> prob {A} (MkSimpleProb aps _) a = foldr f 0 aps where
>   f : (A, NonNegRational) -> NonNegRational -> NonNegRational
>   f (a', p') p with (decEq a a')
>     | (Yes _) = p + p'
>     | (No _)  = p

> ---}


module Data.Time.Calendar.Julian

import Data.Time.Calendar.Days
import public Data.Time.Calendar.Types

%default total

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

||| Is this year a leap year according to the proleptic Julian calendar?
isJulianLeapYear : Year -> Bool
isJulianLeapYear y = (y `mod` 4 == 0) && ((y `mod` 400 == 0) || (y `mod` 100 /= 0))

||| Convert to proleptic Julian year and day format.
toJulianYearAndDay : Day -> (Year, DayOfYear)
toJulianYearAndDay (ModifiedJulianDay mjd) =
  let a    = mjd + 678577
      quad = a `div` 1461
      d    = a `mod` 1461
      y    = min (d `div` 365) 3
    in (quad * 4 + y + 1, fromInteger $ d - (y * 365) + 1)

||| Convert from proleptic Julian year and day format.
||| Invalid day numbers will be clipped to the correct range (1 to 365 or 366).
fromJulianYearAndDay : Year -> DayOfYear -> Day
fromJulianYearAndDay year day =
  let y = year - 1
      yd = if isJulianLeapYear year then 366 else 365
      mjd = cast (if day < 1 then 1
            else if day > yd then yd
            else day) + (365 * y) + (y `div` 4) - 678578
    in ModifiedJulianDay mjd

||| Convert from proleptic Julian year and day format.
||| Invalid day numbers will return Nothing
fromJulianYearAndDayValid : Year -> DayOfYear -> Maybe Day
fromJulianYearAndDayValid year day =
  let y = year - 1
      yd = if isJulianLeapYear year then 366 else 365
    in if day < 1 then Nothing
       else if day > yd then Nothing
       else Just $ ModifiedJulianDay $ cast day + (365 * y) + (y `div` 4) - 678578

{-  -- FIXME:
||| Show in proleptic Julian year and day format (yyyy-ddd)
showJulianYearAndDay : Day -> String
showJulianYearAndDay date =
  let (y, d) = toJulianYearAndDay
   in (show4 y) ++ "-" ++ (show3 d)
-}

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


module ExactLengthDec

import Data.Vect
import Decidable.Equality

%default total

{-
  interface DecEq ty where
    decEq : (val1 : ty) -> (val2 : ty) -> Dec (val1 = val2)

  data Dec: (prop : Type) -> Type where
    Yes : (prf : prop) -> Dec prop
    No : (contra : prop -> Void) -> Dec prop
-}

exactLength : { m : _ } -> (len : Nat) -> Vect m a -> Maybe (Vect len a)
exactLength len input = case decEq m len of
                          Yes Refl => Just input
                          No contra => Nothing


module RecRule

recNat : (x : Type) -> x -> (Nat -> x -> x) -> (Nat -> x)
recNat x base step Z = base
recNat x base step (S k) = step k (recNat x base step k)

fctl : Nat -> Nat
fctl = recNat Nat (S Z) step where
  step = \n: Nat => \y : Nat => (S n) * y

recListNat : (x: Type) -> x -> (Nat -> List Nat -> x -> x) -> (List Nat -> x)
recListNat x base step [] = base
recListNat x base step (y :: xs) = step y xs previous where
  previous = recListNat x base step xs

lsum : List Nat -> Nat
lsum = recListNat Nat base step where
  base = Z
  step = \h : Nat => \t : List Nat => \accum : Nat => h + accum


myReplace : forall p . (0 rule : x = y) -> (1 val : p y) -> p x
myReplace Refl prf = prf

bad : (0 x : Bool) -> Bool
bad False = True
bad True = False

data LT : Nat -> Nat -> Type where
     LeZ : LT Z (S k)
     LeS : LT j k -> LT (S j) (S k)

-- prf isn't used in the run time case tree, so erasure okay
minus : (x : Nat) -> (y : Nat) -> (0 prf : LT y x) -> Nat
minus (S k) Z LeZ = S k
minus (S k) (S j) (LeS p) = minus k j p

-- y is used in the run time case tree, so erasure not okay
minusBad : (x : Nat) -> (0 y : Nat) -> (0 prf : LT y x) -> Nat
minusBad (S k) Z LeZ = S k
minusBad (S k) (S j) (LeS p) = minusBad k j p

prf : {k : _} -> LT k (S (S k))
prf {k=Z} = LeZ
prf {k=S _} = LeS prf


module Datatypes

data Nat = Z | S Nat

data List a = Ni | (::) a (List a)

infixr 10 ::


-- Minimal implicational logic, PHOAS approach, final encoding

module Pf.ArrMp

%default total

-- Types

infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc a

-- Terms

TmRepr : Type
TmRepr = Cx -> Ty -> Type

infixl 1 :$
class ArrMpTm (tr : TmRepr) where
  var  : isTrue a tc                -> tr tc a
  lam' : (isTrue a tc -> tr tc b)   -> tr tc (a :=> b)
  (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b

lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

syntax "lam" {a} ":=>" [b] = lam'' (\a => b)

Thm : Ty -> Type
Thm a = {tr : TmRepr} -> {tc : Cx} -> ArrMpTm tr => tr tc a

-- Example theorems

aI : Thm (a :=> a)
aI =
  lam x :=> x

aK : Thm (a :=> b :=> a)
aK =
  lam x :=>
    lam y :=> x

aS : Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c)
aS =
  lam f :=>
    lam g :=>
      lam x :=> f :$ x :$ (g :$ x)

-- TODO:
-- ./src/Pf/ArrMp.idr:63:6:When checking right hand side of tSKK:
-- Can't resolve type class ArrMpTm tr
-- tSKK : Thm (a :=> a)
-- tSKK {a} =
--   aS {b = a :=> a} :$ aK :$ aK


module xquant.Core.Interpretation

import xquant.Core.Types

%default total

||| Represents a mapping of a model (vector space) to
||| a physical system. Denoted by descriptive strings
data Interpretation : Nat -> Type where
  Interpret : Vect n String -> Interpretation n

dim : Interpretation n -> Nat
dim {n} i = n

Interp : Type
Interp = (n : Nat ** Interpretation n)

{-}
||| Representation of a possibly-composite quantum system
||| @ n the dimensionality of the physical system
data System : (n : Nat) -> List Interp -> Type where
  ||| Representation of a quantum system with a distinct interpretation
  Single : (i : Interpretation n) -> System n [i]
  ||| Extend an quantum system by tensor multiplying by another hilbert space
  Extend : (i : Interpretation n) -> System m -> System (n * m)

-}

qubit : Interpretation 2
qubit = Interpret ["Spin up", "Spin down"]

||| Type-safe representation of choice combinatorics
||| @ n total objects
||| @ m remaining unchosen
|||
||| For example this works fine:
|||````idris example
|||Choose FZ . Choose (FS FZ) $ (ChZero 2)
|||````
||| However both of these do not:
|||````idris example
|||Choose FZ . Choose FZ . Choose FZ $ (ChZero 2)
|||````
|||````idris example
|||Choose (FS FZ) . Choose FZ $ (ChZero 2)
|||````
data Choice : (n : Nat) -> (m : Nat) -> Type where
  ||| No Choices yet
  ChZero : (n : Nat) -> Choice n n
  |||
  Choose : (f : Fin (S m)) -> Choice n (S m) -> Choice n m


module Data.Profunctor.Interface

import Control.Category
import public Control.Applicative.Const
import public Control.Monad.Identity
import public Data.Morphisms

--------------------------------------------------------------------------------
--          Forget
--------------------------------------------------------------------------------

public export
record Forget (r : Type) (a : Type) (b : Type) where
  constructor MkForget
  fun : a -> Maybe r

public export
Functor (Forget r a) where
  map _ (MkForget fun) = MkForget fun

--------------------------------------------------------------------------------
--          Profunctor
--------------------------------------------------------------------------------

||| A `Profunctor` is a `Functor` from the pair category `(Type^op, Type)`
||| to `Type`.
|||
||| In other words, a `Profunctor` is a type constructor of two type
||| arguments, which is contravariant in its first argument and covariant
||| in its second argument.
|||
||| The `dimap` function can be used to map functions over both arguments
||| simultaneously.
|||
||| A straightforward example of a profunctor is the function arrow `(->)`
||| (represented by `Morphism`).
|||
||| Laws:
|||
||| - Identity: `dimap identity identity = identity`
||| - Composition: `dimap f1 g1 <<< dimap f2 g2 = dimap (f1 >>> f2) (g1 <<< g2)`
public export
interface (forall a . Functor (p a)) => Profunctor (0 p : Type -> Type -> Type) where
  dimap : (i2 -> i1) -> (o1 -> o2) -> p i1 o1 -> p i2 o2

||| Map a function over the (contravariant) first type argument only.
public export
clmap : Profunctor p => (i2 -> i1) -> p i1 o -> p i2 o
clmap f = dimap f id

||| Map a function over the (covariant) second type argument only.
public export
rmap : Profunctor p => (o1 -> o2) -> p i o1 -> p i o2
rmap = dimap id

||| Lift a pure function into any `Profunctor` which is also a `Category`.
public export
arr : Category p => Profunctor p => (a -> b) -> p a b
arr f = rmap f id

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

public export
Profunctor Morphism where
  dimap f g (Mor fun) = Mor $ g . fun . f

public export
Profunctor (Forget r) where
  dimap f _ (MkForget fun) = MkForget (fun . f)

public export
Functor m => Profunctor (Kleislimorphism m) where
  dimap f g (Kleisli fun) = Kleisli (map g . fun . f)


module Data.Fin

import public Data.Maybe
import Data.Nat
import Decidable.Equality

%default total

||| Numbers strictly less than some bound.  The name comes from "finite sets".
|||
||| It's probably not a good idea to use `Fin` for arithmetic, and they will be
||| exceedingly inefficient at run time.
||| @ n the upper bound
public export
data Fin : (n : Nat) -> Type where
    FZ : Fin (S k)
    FS : Fin k -> Fin (S k)

export
Uninhabited (Fin Z) where
  uninhabited FZ impossible
  uninhabited (FS f) impossible

export
Uninhabited (FZ = FS k) where
  uninhabited Refl impossible

export
Uninhabited (FS k = FZ) where
  uninhabited Refl impossible

export
fsInjective : FS m = FS n -> m = n
fsInjective Refl = Refl

export
Eq (Fin n) where
    (==) FZ FZ = True
    (==) (FS k) (FS k') = k == k'
    (==) _ _ = False

||| Convert a Fin to a Nat
public export
finToNat : Fin n -> Nat
finToNat FZ = Z
finToNat (FS k) = S $ finToNat k

||| `finToNat` is injective
export
finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn
finToNatInjective FZ     FZ     _    = Refl
finToNatInjective (FS _) FZ     Refl impossible
finToNatInjective FZ     (FS _) Refl impossible
finToNatInjective (FS m) (FS n) prf  =
  cong FS $ finToNatInjective m n $ succInjective (finToNat m) (finToNat n) prf

export
Cast (Fin n) Nat where
    cast = finToNat

||| Convert a Fin to an Integer
public export
finToInteger : Fin n -> Integer
finToInteger FZ     = 0
finToInteger (FS k) = 1 + finToInteger k

export
Cast (Fin n) Integer where
    cast = finToInteger

||| Weaken the bound on a Fin by 1
public export
weaken : Fin n -> Fin (S n)
weaken FZ     = FZ
weaken (FS k) = FS $ weaken k

||| Weaken the bound on a Fin by some amount
public export
weakenN : (n : Nat) -> Fin m -> Fin (m + n)
weakenN n FZ = FZ
weakenN n (FS f) = FS $ weakenN n f

||| Weaken the bound on a Fin using a constructive comparison
public export
weakenLTE : Fin n -> LTE n m -> Fin m
weakenLTE  FZ     LTEZero impossible
weakenLTE (FS _)  LTEZero impossible
weakenLTE  FZ    (LTESucc _) = FZ
weakenLTE (FS x) (LTESucc y) = FS $ weakenLTE x y

||| Attempt to tighten the bound on a Fin.
||| Return `Left` if the bound could not be tightened, or `Right` if it could.
export
strengthen : {n : _} -> Fin (S n) -> Either (Fin (S n)) (Fin n)
strengthen {n = S _} FZ = Right FZ
strengthen {n = S _} (FS i) with (strengthen i)
  strengthen (FS _) | Left x  = Left $ FS x
  strengthen (FS _) | Right x = Right $ FS x
strengthen f = Left f

||| Add some natural number to a Fin, extending the bound accordingly
||| @ n the previous bound
||| @ m the number to increase the Fin by
public export
shift : (m : Nat) -> Fin n -> Fin (m + n)
shift Z f = f
shift (S m) f = FS $ shift m f

||| The largest element of some Fin type
public export
last : {n : _} -> Fin (S n)
last {n=Z} = FZ
last {n=S _} = FS last

export
Ord (Fin n) where
  compare  FZ     FZ    = EQ
  compare  FZ    (FS _) = LT
  compare (FS _)  FZ    = GT
  compare (FS x) (FS y) = compare x y

public export
natToFin : Nat -> (n : Nat) -> Maybe (Fin n)
natToFin Z     (S _) = Just FZ
natToFin (S k) (S j)
    = case natToFin k j of
           Just k' => Just (FS k')
           Nothing => Nothing
natToFin _ _ = Nothing

||| Convert an `Integer` to a `Fin`, provided the integer is within bounds.
||| @n The upper bound of the Fin
public export
integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)
integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction!
integerToFin x n = if x >= 0 then natToFin (fromInteger x) n else Nothing

||| Allow overloading of Integer literals for Fin.
||| @ x the Integer that the user typed
||| @ prf an automatically-constructed proof that `x` is in bounds
public export
fromInteger : (x : Integer) -> {n : Nat} ->
              {auto prf : (IsJust (integerToFin x n))} ->
              Fin n
fromInteger {n} x {prf} with (integerToFin x n)
  fromInteger {n} x {prf = ItIsJust} | Just y = y

||| Convert an Integer to a Fin in the required bounds/
||| This is essentially a composition of `mod` and `fromInteger`
public export
restrict : (n : Nat) -> Integer -> Fin (S n)
restrict n val = let val' = assert_total (abs (mod val (cast (S n)))) in
                     -- reasoning about primitives, so we need the
                     -- 'believe_me'. It's fine because val' must be
                     -- in the right range
                     fromInteger {n = S n} val'
                         {prf = believe_me {a=IsJust (Just val')} ItIsJust}

--------------------------------------------------------------------------------
-- DecEq
--------------------------------------------------------------------------------

export
DecEq (Fin n) where
  decEq FZ FZ = Yes Refl
  decEq FZ (FS f) = No absurd
  decEq (FS f) FZ = No absurd
  decEq (FS f) (FS f')
      = case decEq f f' of
             Yes p => Yes $ cong FS p
             No p => No $ p . fsInjective


module Data.Morphisms

public export
record Morphism a b where
  constructor Mor
  applyMor : a -> b

infixr 1 ~>

public export
(~>) : Type -> Type -> Type
(~>) = Morphism

public export
record Endomorphism a where
  constructor Endo
  applyEndo : a -> a

public export
record Kleislimorphism (f : Type -> Type) a b where
  constructor Kleisli
  applyKleisli : a -> f b

export
Functor (Morphism r) where
  map f (Mor a) = Mor $ f . a

export
Applicative (Morphism r) where
  pure a = Mor $ const a
  (Mor f) <*> (Mor a) = Mor $ \r => f r $ a r

export
Monad (Morphism r) where
  (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r

export
Semigroup a => Semigroup (Morphism r a) where
  f <+> g = Mor $ \r => (applyMor f) r <+> (applyMor g) r

export
Monoid a => Monoid (Morphism r a) where
  neutral = Mor \r => neutral

export
Semigroup (Endomorphism a) where
  (Endo f) <+> (Endo g) = Endo $ g . f

export
Monoid (Endomorphism a) where
  neutral = Endo id

export
Functor f => Functor (Kleislimorphism f a) where
  map f (Kleisli g) = Kleisli (map f . g)

export
Applicative f => Applicative (Kleislimorphism f a) where
  pure a = Kleisli $ const $ pure a
  (Kleisli f) <*> (Kleisli a) = Kleisli $ \r => f r <*> a r

export
Monad f => Monad (Kleislimorphism f a) where
  (Kleisli f) >>= g = Kleisli $ \r => do
    k1 <- f r
    applyKleisli (g k1) r

-- Applicative is a bit too strong, but there is no suitable superclass
export
(Semigroup a, Applicative f) => Semigroup (Kleislimorphism f r a) where
  f <+> g = Kleisli \r => (<+>) <$> (applyKleisli f) r <*> (applyKleisli g) r

export
(Monoid a, Applicative f) => Monoid (Kleislimorphism f r a) where
  neutral = Kleisli \r => pure neutral

export
Cast (Endomorphism a) (Morphism a a) where
  cast (Endo f) = Mor f

export
Cast (Morphism a a) (Endomorphism a) where
  cast (Mor f) = Endo f

export
Cast (Morphism a (f b)) (Kleislimorphism f a b) where
  cast (Mor f) = Kleisli f

export
Cast (Kleislimorphism f a b) (Morphism a (f b)) where
  cast (Kleisli f) = Mor f


module Exercises.Chapter7

import Exercises.Chapter4 -- For Shape

%access public export

-- Exercise 7.1.6.1

Eq Shape where
  (==) (Triangle  b1 h1) (Triangle  b2 h2) = b1 == b2 && h1 == h2
  (==) (Triangle  _  _)   _                = False
  (==) (Rectangle w1 h1) (Rectangle w2 h2) = w1 == w2 && h1 == h2
  (==) (Rectangle _  _)   _                = False
  (==) (Circle    r1)    (Circle r2)       = r1 == r2
  (==) (Circle    _)      _                = False

-- Exercise 7.1.6.2

Ord Shape where
 compare x y = compare (area x) (area y)

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 : (Integral num, Neg 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

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

-- Exercise 7.2.4.1

Show num => Show (Expr num) where
  show (Val x)   = show x
  show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"
  show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"
  show (Mul x y) = "(" ++ show x ++ " * " ++ show y ++ ")"
  show (Div x y) = "(" ++ show x ++ " / " ++ show y ++ ")"
  show (Abs x)   = "|" ++ show x ++ "|"

-- Exercise 7.2.4.2

(Eq num, Integral num, Neg num) => Eq (Expr num) where
  (==) x y = eval x == eval y

-- textExprEq1 : True  = the (Expr _) (2 + 4) == 3 + 3
-- textExprEq2 : False = the (Expr _) (2 + 4) == 3 + 4

-- Exercise 7.2.4.3

(Integral num, Neg num) => Cast (Expr num) num where
  cast = eval

-- Exercise 7.3.4.1

Functor Expr where
  map f (Val x)   = Val (f x)
  map f (Add x y) = Add (map f x) (map f y)
  map f (Sub x y) = Sub (map f x) (map f y)
  map f (Mul x y) = Mul (map f x) (map f y)
  map f (Div x y) = Div (map f x) (map f y)
  map f (Abs x)   = Abs (map f x)

-- Exercise 7.3.4.2

namespace MyVect
  data Vect : Nat -> Type -> Type where
    Nil  : Vect 0 a
    (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a

  Eq a => Eq (Vect n a) where
    (==) []      []      = True
    (==) (x::xs) (y::ys) = (x == y) && (xs == ys)

  Foldable (Vect n) where
    foldl _ z []      = z
    foldl f z (x::xs) = foldl f (f z x) xs
    foldr _ z []      = z
    foldr f z (x::xs) = f x $ foldr f z xs


module PLFI.Part1.Naturals

-- https://plfa.gihub.io/Naturals

data Vect : Nat -> (t : Type) -> Type where
  Nil  : Vect 0 t
  (::) : (x : t) -> Vect n t -> Vect (1 + n) t

replicate : Nat -> t -> List t

replicateV : (n : Nat) -> t -> Vect n t
replicateV 0 x = []
replicateV (S k) x = x :: replicateV k x

%hide (+)
%hide (*)

-- %default total

-- data N0 = Zero | Suc N0

{-
----------- Zero
  Zero : N

   m : N
----------- Suc
 Suc m : N
-}

public export
data N : Type where

  -- Base case
  Zero :
    --------
       N

  -- Inductive case
  Suc :
    (m : N) ->
    ----------
         N

export
Num N where
  (*) = ?m1
  (+) = ?a1
  fromInteger n with (compare n 0)
     fromInteger n | LT = Zero
     fromInteger n | EQ = Zero
     fromInteger n | GT = Suc (assert_total (fromInteger (n-1)))

ex1 : N
ex1 = Suc (Suc (Suc (Suc (Suc (Suc (Suc Zero))))))

test : N
test = (-7)

total
public export
(+) : N -> N -> N
Zero    + m = m
(Suc n) + m = Suc (n + m)

export
addEquation1 : {n : N} -> (Zero + n) = n -- Refl : Equal x x
addEquation1 = Refl

export
addEquation2 : (Suc m) + n = Suc (m + n)
addEquation2 = Refl

total
public export
(*) : N -> N -> N
Zero    * n = Zero
(Suc m) * n = n + (m * n)

-- N -> Zero * ? = Zero
multEquation0 : {n : N} -> Zero * n = Zero
-- test :: Maybe (Maybe Int)
-- test : Maybe $ Maybe Int
-- test : (n : Nat) -> let m = n + n in Vect m Int

export
multEquation1 : Zero * n = Zero
multEquation1 = Refl

export
multEquation2 : (Suc m) * n = n + (m * n)
multEquation2 = Refl

infixr 8 ^

-- Exercise: recommended

total
export
(^) : N -> N -> N
m ^ Zero    = Suc Zero
m ^ (Suc n) = m * (m ^ n)

-- m ^ 0        =  1
-- m ^ (1 + n)  =  m * (m ^ n)

export
expEquation1 : m ^ Zero = Suc Zero
expEquation1 = Refl

export
expEquation2 : m ^ (Suc n) = m * (m ^ n)
expEquation2 = Refl

-- monus

infixl 6 -*

total
export
(-*) : N -> N -> N
m       -* Zero     = m
Zero    -* (Suc n)  = Zero
(Suc m) -* (Suc n)  = m -* n

-- Exercise: strech

public export
data Bin : Type where
  E : Bin
  O : Bin -> Bin
  I : Bin -> Bin

-- 1101 is encoded as
-- IOIIE this needs to be read reversed:
-- EIIOI

export
inc : Bin -> Bin

export
to : N -> Bin

export
from : Bin -> N


module Data.VectorSpace

import Data.Vect

infixr 9 *^
infixl 9 ^/
infixl 6 ^+^, ^-^
infix 7 `dot`

public export
interface VectorSpace v where
  ||| Vector with no magnitude (unit for addition).
  zeroVector : v

  ||| Multiplication by a scalar.
  (*^) : Double -> v -> v

  ||| Division by a scalar.
  (^/) : v -> Double -> v

  ||| Vector addition
  (^+^) : v -> v -> v

  ||| Vector subtraction
  (^-^) : v -> v -> v

  ||| Vector negation. Addition with a negated vector should
  ||| be same as subtraction.
  negateVector : v -> v
  negateVector v = zeroVector ^-^ v

  ||| Dot product (also known as scalar or inner product).
  ||| For two vectors, mathematically represented as a = a1,a2,...,an and b = b1,b2,...,bn,
  ||| the dot product is a . b = a1*b1 + a2*b2 + ... + an*bn.
  dot : v -> v -> Double

  ||| Vector's norm (also known as magnitude).
  ||| For a vector represented mathematically
  ||| as a = a1,a2,...,an, the norm is the square root of a1^2 + a2^2 + ... + an^2.
  norm : v -> Double
  norm v = sqrt $ dot v v

  ||| Return a vector with the same origin and orientation (angle),
  ||| but such that the norm is one (the unit for multiplication by a scalar).
  normalize : v -> v
  normalize v = let n = norm v in if n == 0 then v else v ^/ n

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

public export
VectorSpace Double where
  zeroVector = 0.0
  (^-^) = (-)
  (^+^) = (+)
  (^/)  = (/)
  (*^)  = (*)
  dot   = (*)

public export
{n : _} -> VectorSpace (Vect n Double) where
  zeroVector = replicate n 0.0
  (^-^)   = zipWith (-)
  (^+^)   = zipWith (+)
  v ^/ s  = map (/ s) v
  s *^ v  = map (* s) v
  dot a b = sum $ zipWith (*) a b


-- exercises in "Type-Driven Development with Idris"
-- chapter 7

-- check that all functions are total
%default total

--
-- Expressions
--
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, Abs 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 num => Num (Expr num) where
  (+) = Add
  (*) = Mul
  fromInteger = Val . fromInteger

Neg num => Neg (Expr num) where
  negate x = 0 - x
  (-) = Sub

Abs num => Abs (Expr num) where
  abs = Abs

showHelper : Show a => String -> a -> a -> String
showHelper op x y = "(" ++ show x ++ op ++ show y ++ ")"

Show num => Show (Expr num) where
  show (Val x) = show x
  show (Add x y) = showHelper " + " x y
  show (Sub x y) = showHelper " - " x y
  show (Mul x y) = showHelper " * " x y
  show (Div x y) = showHelper " `div`" x y
  show (Abs x) = "(" ++ "abs " ++ show x ++ ")"

(Neg num, Integral num, Abs num, Eq num) => Eq (Expr num) where
  (==) x y = (eval x) == (eval y)

(Neg num, Integral num, Abs num) => Cast (Expr num) num where
  cast orig = eval orig

Functor Expr where
  map func (Val x) = Val $ func x
  map func (Add x y) = Add (map func x) (map func y)
  map func (Sub x y) = Sub (map func x) (map func y)
  map func (Mul x y) = Mul (map func x) (map func y)
  map func (Div x y) = Div (map func x) (map func y)
  map func (Abs x) = Abs $ map func x


module Test.Bits32

import Data.Prim.Bits32
import Data.SOP
import Hedgehog
import Test.RingLaws

allBits32 : Gen Bits32
allBits32 = bits32 (linear 0 0xffffffff)

gt0 : Gen Bits32
gt0 = bits32 (linear 1 MaxBits32)

gt1 : Gen Bits32
gt1 = bits32 (linear 2 MaxBits32)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allBits32
  (b8 <= MaxBits32) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allBits32
  (b8 >= MinBits32) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allBits32, allBits32]
  toOrdering (comp m n) === compare m n

prop_mod : Property
prop_mod = property $ do
  [n,d] <- forAll $ np [allBits32, gt0]
  compare (n `mod` d) d === LT

prop_div : Property
prop_div = property $ do
  [n,d] <- forAll $ np [gt0, gt1]
  compare (n `div` d) n === LT

prop_divMod : Property
prop_divMod = property $ do
  [n,d] <- forAll $ np [allBits32, gt0]
  let x = n `div` d
      r = n `mod` d
  n === x * d + r

export
props : Group
props = MkGroup "Bits32" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  , ("prop_mod",    prop_mod)
  , ("prop_div",    prop_div)
  , ("prop_divMod", prop_divMod)
  ] ++ ringProps allBits32


data BSTree : Type -> Type where
    Empty : Ord elem => BSTree elem
    Node : Ord elem => (left : BSTree elem) -> (val : elem) ->
                       (right : BSTree elem) -> BSTree elem

%name BSTree tree, tree1

insert : elem -> BSTree elem -> BSTree elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right) = case compare x val of
                                    LT => Node (insert x left) val right
                                    EQ => orig
                                    GT => Node left val (insert x right)

listToTree : Ord a => List a -> BSTree a
listToTree [] = Empty
listToTree (x :: xs) = insert x (listToTree xs)

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


module Vec3

%access export

public export
-- To RECORD ?
Vec3 : Type
Vec3 = (Double, Double, Double)

toColor : Int -> Int -> Double
toColor value size = 255.999 * (cast value / cast size)

getX : Vec3 -> Double
getX (x, _, _) = x

getY : Vec3 -> Double
getY (_, y, _) = y

getZ : Vec3 -> Double
getZ (_, _, z) = z

(+) : Vec3 -> Vec3 -> Vec3
(+) (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)

(-) : Vec3 -> Vec3 -> Vec3
(-) (x1, y1, z1) (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)

-- (*) : Vec3 -> Vec3 -> Vec3
-- (*) (x1, y1, z1) (x2, y2, z2) = (x1 * x2, y1 * y2, z1 * z2)

(*) : Double -> Vec3 -> Vec3
(*) t (x2, y2, z2) = (t * x2, t * y2, t * z2)

(/) : Vec3 -> Double -> Vec3
(/) v t = (1 / t) * v

dot : Vec3 -> Vec3 -> Double
dot (x1, y1, z1) (x2, y2, z2) = x1 * x2 + y1 * y2 + z1 * z2

length : Vec3 -> Double
length (x, y, z) = sqrt (x*x + y*y + z*z)

lengthSquared : Vec3 -> Double
lengthSquared (x, y, z) = x*x + y*y + z*z

unitVector : Vec3 -> Vec3
unitVector v = v / Vec3.length v

vecToStr : Vec3 -> String
vecToStr (x, y, z) = concat [show $ cast {to=Int} x, " ", show $ cast {to=Int} y, " ", show $ cast {to=Int} z]


module Graphics.Shape
import Data.Vect

%access public export
Point : Type
Point = (Double, Double)

data Path : (n : Nat) -> Type where
  Start  : Point -> Path Z
  Append : Path k -> Point -> Path (S k)

Line : Point -> Point -> Path 1
Line from to = (Start from) `Append` to

Triangle : Path 1 -> Point -> Path 3
Triangle (Append (Start x) y) z = ((Line x y) `Append` z) `Append` x

toPoints : Path n -> Vect (n+1) Point
toPoints (Start x)          = [x]
toPoints (Append path next) = let ps = next :: toPoints path
                              in reverse ps


module Average

||| Calculate the average length of words in a string
||| @str a string containing words separated by whitespace
export
average : (str : String) -> Double
average str =
  let num_words = word_count str
      total_length = sum (word_lengths (words str))
  in cast total_length / cast num_words

  where
    word_count : String -> Nat
    word_count str = length (words str)

    word_lengths : List String -> List Nat
    word_lengths = map length


> module Fraction.Normal

> import Fraction.Fraction
> import Fraction.BasicOperations
> import Nat.Coprime
> import Unique.Predicates
> import Nat.GCD
> import Nat.GCDEuclid
> import PNat.PNat
> import Nat.Positive
> import Pairs.Operations

> %default total

> %access public export

> |||
> data Normal : Fraction -> Type where
>   MkNormal  : {x : Fraction} -> Coprime (num x) (den x) -> Normal x

> |||
> NormalUnique : {x : Fraction} -> Unique (Normal x)
> NormalUnique {x} (MkNormal p) (MkNormal q) = cong (CoprimeUnique p q)


module Shape

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

private
rectangle_area : Double -> Double -> Double
rectangle_area width height = width * height

export
area : Shape -> Double
area (Triangle base height) = 0.5 * rectangle_area base height
area (Rectangle length height) = rectangle_area length height
area (Circle radius) = pi * radius * radius


import NewEden.Natural

{- Natural Theorems

   Basic theorems about the natural numbers expressed in
   terms of operations on Natural p.

-}

addToBothSides : (n : Natural p) -> a = b -> a + n = b + n
addToBothSides _ Refl = Refl

addRemoveBothSides : (n : Natural p) -> n + a = n + b -> a = b
addRemoveBothSides {a} {b} n prf =
  let (MkMonomorphicFunction _ mono) = plusMonomorphic p n in
  mono a b prf

multiplyBothSidesBy : (n : Natural p) -> a = b -> a * n = b * n
multiplyBothSidesBy _ Refl = Refl

multiplyRemoveBothSides : (n : Natural p) -> n * a = n * b -> a = b
multiplyRemoveBothSides {a} {b} n prf =
  let (MkMonomorphicFunction _ mono) = multiplyMonomorphic p n in
  mono a b prf

pluscom : {a:Natural p}
        -> a + b = c -> b + a = c
pluscom {p} {a} {b} given =
  let (MkCommutativeFunction _ prf) = plusCommutative p in
  let apply = prf b a in
  transitivity apply given

plusass : {a:Natural p}
        -> a + (b + c) = d -> a + b + c = d
plusass {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = plusAssociative p in
  let apply = prf a b c in
  transitivity (symmetric apply) given

plusass' : {a:Natural p}
         -> a + b + c = d -> a + (b + c) = d
plusass' {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = plusAssociative p in
  let apply = prf a b c in
  transitivity apply given

multcom : {a : Natural p}
        -> a * b = c -> b * a = c
multcom {p} {a} {b} given =
  let (MkCommutativeFunction _ prf) = multiplyCommutative p in
  let apply = prf b a in
  transitivity apply given

multass : {a : Natural p}
        -> a * (b * c) = d -> a * b * c = d
multass {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = multiplyAssociative p in
  let apply = prf a b c in
  transitivity (symmetric apply) given

multass' : {a : Natural p}
        -> a * b * c = d -> a * (b * c) = d
multass' {p} {a} {b} {c} given =
  let (MkAssociativeFunction _ prf) = multiplyAssociative p in
  let apply = prf a b c in
  transitivity apply given

nothingIsLessThanZero : (a:Natural p) -> LessThan a 0 -> Void
nothingIsLessThanZero {p} a (MkLessThan a (Z p) (c ** (prf,cNonZero))) =
  let (MkCommutativeFunction _ comm) = NewEden.Natural.plusCommutative p in
  let equation = symmetric $ comm a c in
  let cPlusAIsZero = transitivity equation prf in
  let (MkStrictMonoid _ noInverses) = NewEden.Natural.plusLacksInverses p in
  let cIsZero = noInverses c a cPlusAIsZero in
  cNonZero cIsZero

lessThanImpliesNotEqual : (a:Natural p) -> (b:Natural p) -> LessThan a b -> a = b -> Void
lessThanImpliesNotEqual a b (MkLessThan a b (c ** (aPlusCIsB,cNonZero))) aEqualsb =
  let step = symmetric aPlusCIsB in
  let step2 = transitivity aEqualsb step in
  let (MkMonoid _ _ mn _) = plusMonoid p in
  let step3 = mn a in
  let step4 = transitivity step3 step2 in
  let mono = plusMonomorphic p in
  let (MkMonomorphicFunction ((+) a) monoprf) = mono a in
  let fin = monoprf 0 c in
  let cIsZero = fin step4 in
  cNonZero $ symmetric cIsZero

lessThanNotSymmetric : {a:Natural p} -> {b:Natural p} -> LessThan a b -> LessThan b a -> Void
lessThanNotSymmetric {p} (MkLessThan a b (c1 ** (prf1,c1NonZero))) (MkLessThan b a (c2 ** (prf2,c2NonZero))) =
  let (MkCommutativeFunction _ comm) = plusCommutative p in
  let (MkMonoid _ _ mon _) = plusMonoid p in
  let (MkMonomorphicFunction _ mono) = plusMonomorphic p $ b in
  let (MkAssociativeFunction _ ass) = plusAssociative p in
  let comm' = symmetric $ comm a c1 in
  let s1 = substitution ((+) c1) (symmetric prf2) (transitivity comm' prf1) in
  let s2 = symmetric $ comm c1 (b + c2) in
  let s3 = transitivity s2 s1 in
  let but4 = mon b in
  let so5 = transitivity but4 $ symmetric s3 in
  let byMono = mono 0 (c2 + c1) in
  let ass' = ass b c2 c1 in
  let prepare = transitivity so5 (symmetric ass') in
  let therefore = byMono prepare in
  let but6 = mon c2 in
  let (MkMonomorphicFunction _ monoc2) = plusMonomorphic p $ c2 in
  let monoapp = monoc2 0 c1 in
  let (MkStrictMonoid _ noInverses) = plusLacksInverses p in
  let so6 = noInverses c2 c1 in
  let c2IsZero = so6 (symmetric therefore) in
  c2NonZero c2IsZero

lessThanIsTransitive : {x:Natural p} -> {y:Natural p} -> {z:Natural p} ->
                       LessThan x y -> LessThan y z -> LessThan x z
lessThanIsTransitive {p} (MkLessThan x y (c1 ** (eq1,c1NonZero))) (MkLessThan y z (c2 ** (eq2,c2NonZero)))=
  case compare x z of
    Left prf => prf
    Middle xIsZ =>
      let sub = pluscom $ substitution ((+) c1) xIsZ (pluscom eq1) in
      let zLessThany = MkLessThan z y (c1 ** (sub,c1NonZero)) in
      let yLessThanz = MkLessThan y z (c2 ** (eq2,c2NonZero)) in
      absurd $ lessThanNotSymmetric yLessThanz zLessThany
    Right (MkLessThan z x (c3 ** (eq3,c3NonZero))) =>
      let sub = substitution ((+) c1) (symmetric eq3) (pluscom eq1) in
      let s0 = pluscom sub in
      let c4 = c3 + c1 in
      let c4e:(c4 = c3 + c1) = Refl in
      let (MkStrictMonoid _ noInverses) = plusLacksInverses p in
      let c4nz = (\c4z => c3NonZero $ noInverses c3 c1 c4z) in
      let s1 = plusass' s0 in
      let zlty = MkLessThan z y ((c3+c1) ** (s1,c4nz)) in
      let yltz = MkLessThan y z (c2 ** (eq2,c2NonZero)) in
      absurd $ lessThanNotSymmetric zlty yltz

lessThanAdditionWeakened : LessThan x y -> (z : Natural p) -> LessThan x (y + z)
lessThanAdditionWeakened {p} {x} {y} (MkLessThan x y (c ** (xpyic,cNotZero))) z =
  let (MkStrictMonoid _ noinv) = plusLacksInverses p in
  let cPlusZIsZeroImpliesCIsZero = noinv c z in
  let cPlusZNotZero = (\sumZero => cNotZero $ cPlusZIsZeroImpliesCIsZero sumZero) in
  let target = addToBothSides z xpyic in
  let target' = plusass' target in
  MkLessThan x (y + z) ((c + z) ** (target',cPlusZNotZero))


-- exercises in "Type-Driven Development with Idris"
-- chapter 4

-- check that all functions are total
%default total

--
-- Binary Search Trees
--

||| A binary search tree.
data BST : Type -> Type where
  ||| An empty tree.
  Empty : Ord elem =>
          BST elem
  ||| A node with a value, a left subtree, and a right subtree.
  ||| Elements in the left subtree must be strictly lower than the value.
  ||| Elements in the right subtree must be strictly greater than the value.
  Node : Ord elem =>
         (left : BST elem) ->
         (val : elem) ->
         (right : BST elem) ->
         BST elem

||| insert a value in a binary search tree
insert : elem -> BST elem -> BST elem
insert x Empty = Node Empty x Empty
insert x orig@(Node left val right)
  = case compare x val of
      LT => Node (insert x left) val right
      EQ => orig
      GT => Node left val (insert x right)

listToTree : Ord a => List a -> BST a
listToTree [] = Empty
listToTree (x :: xs) = insert x $ listToTree xs

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


module Data.Vect.Extra

import Data.Vect

%access export
%default total

namespace Equality
   vecEq : Eq type => Vect n type -> Vect m type -> Bool
   vecEq [] [] = True
   vecEq [] (x :: xs) = False
   vecEq (x :: xs) [] = False
   vecEq (x :: xs) (y :: ys) = x == y && vecEq xs ys

namespace Decidable
  namespace SameLength
    decEq : DecEq type
          => (n = m)
          -> (xs : Vect n type)
          -> (ys : Vect m type)
          -> Dec (xs = ys)
    decEq Refl xs ys with (decEq xs ys)
      decEq Refl ys ys | (Yes Refl) = Yes Refl
      decEq Refl xs ys | (No contra) = No contra

  namespace DiffLength

    vectorsDiffLength : DecEq type
                      => (contra : (n = m) -> Void)
                      -> {xs : Vect n type}
                      -> {ys : Vect m type}
                      -> (xs = ys) -> Void
    vectorsDiffLength contra Refl = contra Refl

    decEq : DecEq type
         => (xs : Vect n type)
         -> (ys : Vect m type)
         -> Dec (xs = ys)
    decEq xs ys {n} {m} with (decEq n m)
      decEq xs ys {n = m} {m = m} | (Yes Refl) = decEq Refl xs ys
      decEq xs ys {n = n} {m = m} | (No contra) = No (vectorsDiffLength contra)


module TwoVarDiophEq
import ZZ
import ZZUtils
import Divisors
import GCDZZ
import decDivZ
%access public export
%default total

|||Any integer is a solution for c=xa+yb when a=b=c=0
zeroLinCombZeroZero:a=0->b=0->c=0->(x:ZZ)->(y:ZZ)->c=x*a+y*b
zeroLinCombZeroZero az bz cz x y = rewrite az in
                                       rewrite bz in
                                       rewrite cz in
                                       rewrite multZeroRightZeroZ x in
                                       rewrite multZeroRightZeroZ y in
                                       Refl

|||If a=b=0 and c is not zero, it is impossible that c = xa +yb
notZeroNotLinCombZeroZero:a=0->b=0->NotZero c ->
   (x:ZZ)->(y:ZZ)->c=x*a+y*b->Void
notZeroNotLinCombZeroZero aZ bZ cnotz x y =
  rewrite aZ in
  rewrite bZ in
  rewrite multZeroRightZeroZ x in
  rewrite multZeroRightZeroZ y in
  (notZeroNonZero cnotz)

|||Proves that if d = gcd (a,b) and c= xa +yb , then d|c
gcdDivLinComb:GCDZ a b d->c=x*a+y*b -> IsDivisibleZ c d
gcdDivLinComb (dPos,dcommonfactab,fd)  prf =
  linCombDivLeftWithProof prf dcommonfactab

gcdDivLinCombContra:GCDZ a b d ->((IsDivisibleZ c d) ->Void)->(x:ZZ)->(y:ZZ)->c=x*a+y*b->Void
gcdDivLinCombContra gcdpf f x y prf =
  f (gcdDivLinComb gcdpf prf)

|||Proves that if d = gcd (a,b) and d|c, then there exists integers x and y
|||such that c = xa +yb
multipleOfGcdLinComb:GCDZ a b d -> IsDivisibleZ c d ->
    (x:ZZ**y:ZZ** (c = x*a + y*b))
multipleOfGcdLinComb{a} {d}{b} gcdpf (n**eqpf) =
  (case checkNotBothZero a b of
        (Left (aZ, bZ)) => void (gcdZeroZeroContra (gcdzReplace aZ bZ gcdpf))
        (Right r) =>
          (case gcdIsLinComb gcdpf of
                (j**l**gcdlc) => ((n*j)**(n*l)**
                    (rewrite sym $multAssociativeZ n j a in
                     rewrite sym $multAssociativeZ n l b in
                     rewrite sym $ multDistributesOverPlusRightZ n (j*a) (l*b) in
                     rewrite eqpf in
                     rewrite multCommutativeZ d n in
                     cong gcdlc) )))

|||Extracts a/gcd(a,b) from the definition of GCDZ
aByd:GCDZ a b d ->ZZ
aByd dGcdab = (fst (fst (fst (snd dGcdab))))
|||Extracts b/gcd(a,b) from the definition of GCDZ
bByd:GCDZ a b d ->ZZ
bByd dGcdab = (fst (snd (fst (snd dGcdab))))

|||Proves that (b/gcd(a,b))*a = (a/gcd(a,b))*b
divByGcdMultByOtherIsSame:(gcdpf:GCDZ a b d) ->(bByd gcdpf)*a =(aByd gcdpf)*b
divByGcdMultByOtherIsSame {a}{b}{d} (dPos, ((abyd**apf),(bbyd**bpf)),fd) =
  multLeftCancelZ d (bbyd*a) (abyd *b) (posThenNotZero dPos)
    (rewrite multAssociativeZ d bbyd a in
     rewrite multAssociativeZ d abyd b in
     rewrite  sym $ bpf in
     rewrite sym $ apf in
     rewrite multCommutativeZ b a in
     Refl)

|||Proves that for any integer k, k*(-b/(gcd(a,b))) and  k*(a/(gcd(a,b)))
|||are solutions of 0 = xa + yb
homoSolution:(gcdpf:GCDZ a b d)->{k:ZZ}->
   (0 = (k*(-(bByd gcdpf)))*a + (k*((aByd gcdpf)))*b)
homoSolution {a}{b}{d}{k} (dPos, ((abyd**apf),(bbyd**bpf)),fd)  =
  rewrite sym $ multAssociativeZ k (-bbyd) a in
  rewrite sym $ multAssociativeZ k (abyd) b in
  rewrite sym $ multDistributesOverPlusRightZ k ((-bbyd)*a) ((abyd)*b) in
  rewrite multNegateLeftZ bbyd a in
  rewrite divByGcdMultByOtherIsSame (dPos, ((abyd**apf),(bbyd**bpf)),fd) in
  rewrite plusNegateInverseRZ (abyd*b) in
  rewrite multZeroRightZeroZ k in
  Refl

|||Proves that if 0 = xa +yb, then (-b/gcd(a,b)))*y = (a/(gcd(a,b)))*x
divHomoEqByGcd:(gcdpf:GCDZ a b d)->(0 = x*a + y*b)->((-(bByd gcdpf))*y = (aByd gcdpf)*x)
divHomoEqByGcd {x}{y}{a}{b}{d}(dPos, ((abyd**apf),(bbyd**bpf)),fd) prf =
  rewrite sym $plusZeroLeftNeutralZ ((-bbyd)*y) in
  rewrite multNegateLeftZ bbyd y in
  subOnBothSides 0 (abyd*x) ((bbyd)*y)
    (multLeftCancelZ d 0 ((abyd*x)+(bbyd*y)) (posThenNotZero dPos)
     (rewrite multZeroRightZeroZ d in
      rewrite multDistributesOverPlusRightZ d (abyd*x) (bbyd*y) in
      rewrite multAssociativeZ d abyd x in
      rewrite multAssociativeZ d bbyd y in
      rewrite sym $ apf in
      rewrite sym $ bpf in
      rewrite multCommutativeZ a x in
      rewrite multCommutativeZ b y in
      prf))

|||Proves that if  0 = xa + yb then there exists an integer k such that
||| y = k* (a/(gcd(a,b)))
homoOnlySolnForY:(gcdpf:GCDZ a b d)->(0 = x*a + y*b) ->
   (k:ZZ**(y = k * (aByd gcdpf)))
homoOnlySolnForY{a}{b}{d}{x}{y} (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf  =
  (case divHomoEqByGcd (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf  of
    eqpf  =>
     (case caCoprimeThencDivb (x**eqpf) (negatingPreservesGcdLeft1
         (gcdSymZ (divideByGcdThenGcdOne (dPos, ((abyd**apf),(bbyd**bpf)),fd)))) of
           (quot**divpf) => (quot** (rewrite multCommutativeZ quot abyd in divpf))))

|||Proves that if a is not zero then a/(gcd(a,b)) is not zero
divByGcdNotZero:(gcdpf:(GCDZ a b d))->NotZero a ->NotZero (aByd gcdpf)
divByGcdNotZero {a = (Pos (S k))}{b = b}{d = d} (dPos, ((abyd**apf),(bbyd**bpf)),fd)
    PositiveZ = posThenNotZero (posDivByPosIsPos{c=(Pos (S k))} Positive dPos apf)
divByGcdNotZero {a = (NegS k)}{b = b}{d = d} (dPos, ((abyd**apf),(bbyd**bpf)),fd)
NegativeZ = NegSThenNotZero (negDivByPosIsNeg Negative dPos apf)

-- The arguments to the function homoOnlySoln need to be explicit because Idris will not
-- infer the correct arguments in the functions below.

|||Proves that if a is not zero and 0 =xa + yb, then there exists an integer k such that
||| x = k* (-b/(gcd(a,b))) and y = k* (a/(gcd(a,b)))
homoOnlySoln:(x: ZZ) -> (y: ZZ) -> (gcdpf:GCDZ a b d)->(0 = x*a + y*b) ->NotZero a->
   (k:ZZ**((x = k * (-(bByd gcdpf))),(y = k * (aByd gcdpf))))
homoOnlySoln {a}{b}{d} x y (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf anotz =
   (case divHomoEqByGcd (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf of
        divgpf =>
          (case homoOnlySolnForY (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf of
            (k**adivy) => (k**((multLeftCancelZ abyd x (k*(-bbyd))
              (divByGcdNotZero (dPos, ((abyd**apf),(bbyd**bpf)),fd) anotz)
                (rewrite multAssociativeZ abyd k (-bbyd) in
                 rewrite multCommutativeZ abyd k in
                 rewrite sym $ adivy in
                 rewrite multCommutativeZ y (-bbyd) in
                 sym $ divgpf)),adivy))))

gcdSymZwithproof:(gcdpf:GCDZ a b d)->(gcdpf2:(GCDZ b a d)**((aByd gcdpf)=(bByd gcdpf2),(bByd gcdpf)=(aByd gcdpf2)))
gcdSymZwithproof (dPos, ((abyd**apf),(bbyd**bpf)),fd) =
  ((dPos, ((bbyd**bpf),(abyd**apf)),(genFunctionForGcdSym fd))**(Refl,Refl))

|||Same as homoOnlySolution, NotZero a is replaced with NotBothZeroZ a b
homoOnlySolnGen:(x: ZZ) -> (y: ZZ) -> (gcdpf:GCDZ a b d)->(0 = x*a + y*b) ->NotBothZeroZ a b->
   (k:ZZ**((x = k * (-(bByd gcdpf))),(y = k * (aByd gcdpf))))
homoOnlySolnGen {a = (Pos (S k))}{b = b}{d = d} x y gcdpf prf LeftPositive =
  homoOnlySoln x y gcdpf prf PositiveZ
homoOnlySolnGen {a = (NegS k)}{b = b}{d = d} x y gcdpf prf LeftNegative =
  homoOnlySoln x y gcdpf prf NegativeZ
homoOnlySolnGen {a = a}{b = (Pos (S k))}{d = d} x y (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf RightPositive =
  (case gcdSymZwithproof ((dPos, ((abyd**apf),(bbyd**bpf)),fd)) of
    (gcdpf2**(eqpf1,eqpf2)) =>
      (case homoOnlySoln {a=(Pos (S k))}{b=a} {d=d} y x gcdpf2 (rewrite plusCommutativeZ (y*(Pos (S k))) (x*a) in prf )  PositiveZ of
            (j**(ypf,xpf)) => ((-j)**((rewrite multNegNegNeutralZ j bbyd in
                                       rewrite eqpf2 in
                                       xpf ),(rewrite multNegateLeftZ j abyd in
                                              rewrite sym $ multNegateRightZ j abyd in
                                              rewrite eqpf1 in
                                              ypf)))))
homoOnlySolnGen {a = a}{b = (NegS k)}{d = d} x y (dPos, ((abyd**apf),(bbyd**bpf)),fd) prf RightNegative =
    (case gcdSymZwithproof ((dPos, ((abyd**apf),(bbyd**bpf)),fd)) of
      (gcdpf2**(eqpf1,eqpf2)) =>
        (case homoOnlySoln {a=(NegS k)}{b=a} {d=d} y x gcdpf2 (rewrite plusCommutativeZ (y*(NegS k)) (x*a) in prf )  NegativeZ of
              (j**(ypf,xpf)) => ((-j)**((rewrite multNegNegNeutralZ j bbyd in
                                         rewrite eqpf2 in
                                         xpf ),(rewrite multNegateLeftZ j abyd in
                                                rewrite sym $ multNegateRightZ j abyd in
                                                rewrite eqpf1 in
                                                ypf)))))

-- The goal of the following section is to show that the non-homogeneous equation is uniquely solved by the family of
-- solutions ((x_p+k*x_0), (y_p+k*y_0)).

||| Produces the difference of two solutions. It will used to show that the difference of two particular
||| solutions satisfies the homogeneous equation.
solDifference: (a: ZZ) -> (b: ZZ) -> (c: ZZ) -> (x1: ZZ) -> (y1: ZZ) -> (x2: ZZ) ->
(y2: ZZ) -> (c=(x1*a+y1*b)) -> (c=(x2*a+y2*b)) -> ( 0= ( ((x1-x2)*a) + ((y1-y2)*b) ))
solDifference a b c x1 y1 x2 y2 prf prf1 = rewrite (multDistributesOverPlusLeftZ (x1) (-x2) (a)) in
                                           rewrite (multDistributesOverPlusLeftZ (y1) (-y2) (b)) in
                                           rewrite sym (plusAssociativeZ (x1*a) ((-x2)*a) (y1*b+((-y2)*b)) ) in
                                           rewrite (plusCommutativeZ (y1*b) ((-y2)*b)) in
                                           rewrite (plusAssociativeZ ((-x2)*a) ((-y2)*b) (y1*b)) in
                                           rewrite (plusCommutativeZ (((-x2)*a) + ((-y2)*b)) (y1*b)) in
                                           rewrite (plusAssociativeZ (x1*a) (y1*b) (((-x2)*a) + ((-y2)*b))) in
                                           rewrite (multNegateLeftZ (x2) (a)) in
                                           rewrite (multNegateLeftZ (y2) (b)) in
                                           rewrite sym (negateDistributesPlus (x2*a) (y2*b)) in
                                           rewrite sym (plusNegateInverseLZ (x2*a+y2*b)) in
                                           rewrite sym prf in
                                           rewrite sym prf1 in
                                           rewrite (plusNegateInverseLZ c) in
                                           Refl

||| Adding x2 to both sides of the equation:
addToSol: (x1: ZZ) -> (x2: ZZ) -> (x1-x2=d) -> (x1=x2+d)
addToSol x1 x2 prf = rewrite sym prf in
                       rewrite (plusCommutativeZ (x1) (-x2)) in
                       rewrite (plusAssociativeZ (x2) (-x2) (x1)) in
                       rewrite (plusNegateInverseLZ (x2)) in
                       rewrite (plusZeroLeftNeutralZ (x1)) in
                       Refl

||| Proves that two particular solutions differ by a solution of the homogeneous equation.
diffIsHomogeneous: {a: ZZ} -> {b: ZZ} -> {c: ZZ} -> {d: ZZ} ->  {x1: ZZ} -> {y1: ZZ} -> {x2: ZZ} ->
{y2: ZZ} -> (IsDivisibleZ c d) -> (gcdpf:GCDZ a b d) -> NotBothZeroZ a b  ->
    (c=x1*a+y1*b) -> (c=x2*a+y2*b) ->
       (k:ZZ** (( (x1-x2) = (k * (-(bByd gcdpf)))),( (y1-y2) = (k * (aByd gcdpf)))))
diffIsHomogeneous {a}{b}{c}{d}{x1}{y1}{x2}{y2} x gcdpf abnotZ  prf prf1 =
 homoOnlySolnGen {a}{b}{d} (x1-x2) (y1-y2) (gcdpf) (solDifference a b c x1 y1 x2 y2 prf prf1) abnotZ

||| Proves that any solution is a particular solution plus a constant multiple of the solution of
||| the homogeneous equation.
differByHomogeneous: {a: ZZ} -> {b: ZZ} -> {c: ZZ} -> {d: ZZ} ->  {x1: ZZ} -> {y1: ZZ} ->
 (IsDivisibleZ c d) -> (gcdpf:GCDZ a b d) -> NotBothZeroZ a b  ->
   (c=x1*a+y1*b) ->(x2:ZZ)->(y2:ZZ)-> (c=x2*a+y2*b) ->
      (k:ZZ** (( x2 = x1 + (k * (-(bByd gcdpf)))),( y2 = y1 + (k * (aByd gcdpf)))))
differByHomogeneous {x1}{y1} x gcdpf y  prf x2 y2 prf1 =
  (case diffIsHomogeneous x gcdpf y prf1 prf of
        (k**(xpf,ypf)) => (k**((addToSol x2 x1 xpf),(addToSol y2 y1 ypf))))

|||A helper function for allsolutions.
|||It proves that all x and y of the given form satisfies the equation.
helpallsolutions:(gcdpf:(GCDZ a b d))->(bbyd*a=abyd*b)->c = x1*a+y1*b->{k:ZZ}->
   (x3:ZZ)->(y3:ZZ)->(x3=x1+k*(-bbyd))->(y3=y1+k*abyd)->(c=(x3)*a+(y3)*b)
helpallsolutions{bbyd}{abyd} {x1}{y1}{a}{b}{d}{c}{k} gcdpf bydpf eqpf x3 y3 xpf ypf =
  rewrite xpf in
  rewrite ypf in
  rewrite multDistributesOverPlusLeftZ x1 (k*(-bbyd)) a in
  rewrite sym $ plusAssociativeZ (x1*a) ((k*(-bbyd))*a) (multZ (plusZ y1 (multZ k abyd)) b) in
  rewrite plusCommutativeZ ((k*(-bbyd))*a) ((y1+ (k*abyd))*b) in
  rewrite plusAssociativeZ (x1*a) ((y1+ (k*abyd))*b) ((k*(-bbyd))*a) in
  rewrite multDistributesOverPlusLeftZ y1 (k*abyd) b in
  rewrite plusAssociativeZ (x1*a) (y1*b) ((k*abyd)*b) in
  rewrite sym $ eqpf in
  rewrite sym $ plusAssociativeZ c ((k*abyd)*b) ((k*(-bbyd))*a) in
  rewrite sym $ multAssociativeZ k abyd b in
  rewrite sym $ multAssociativeZ k (-bbyd) a in
  rewrite sym $ bydpf in
  rewrite sym $ multDistributesOverPlusRightZ k (bbyd*a) ((-bbyd)*a) in
  rewrite multNegateLeftZ bbyd a in
  rewrite plusNegateInverseLZ (bbyd*a) in
  rewrite multZeroRightZeroZ k in
  rewrite plusZeroRightNeutralZ c in
  Refl

|||The function that generates the third case in findAllSolutions function.
allSolutions:(gcdpf:(GCDZ a b d)) -> IsDivisibleZ c d ->NotBothZeroZ a b ->
   (x1:ZZ**y1:ZZ**pa:ZZ**pb:ZZ**(({k:ZZ}->(x3:ZZ)->(y3:ZZ)->(x3=x1+k*pa)->(y3=y1+k*pb)->(c=x3*a+y3*b)),
     ((x2:ZZ)->(y2:ZZ)->(c=x2*a+y2*b)->(k**((x2=x1+k*pa),(y2=y1+k*pb))))))
allSolutions{a}{b}{d} (dPos, ((abyd**apf),(bbyd**bpf)),fd) dDivc abnotZ =
  (case ((multipleOfGcdLinComb (dPos, ((abyd**apf),(bbyd**bpf)),fd) dDivc),
  (divByGcdMultByOtherIsSame (dPos, ((abyd**apf),(bbyd**bpf)),fd))) of
    ((x1**y1**eqpf),bydpf) =>(x1**y1**(-bbyd)**abyd**(
     (helpallsolutions (dPos, ((abyd**apf),(bbyd**bpf)),fd) bydpf eqpf ),
        ( (differByHomogeneous  dDivc (dPos, ((abyd**apf),(bbyd**bpf)),fd) abnotZ eqpf  ) ))))

|||Given three integers a, b and c, it outputs either
|||a proof that c = xa +yb is impossible or
|||a proof that all integers x and y satisfy the equation (this happens when a=b=c=0)
|||or 4 integers x1 , y1 , pa and pb such that for any integer k,
|||x=x1+k*pa  y=y1+k*pb is a solution of c=xa+yb
|||and whenever c=xa+yb ,there exists an integer, k such that
||| x=x1+k*pa  y=y1+k*pb
findAllSolutions: (a:ZZ)->(b:ZZ)->(c:ZZ)->
  Either ((x:ZZ)->(y:ZZ)->c=x*a+y*b->Void)
  (Either ((x:ZZ)->(y:ZZ)->c=x*a+y*b)
    (x1:ZZ**y1:ZZ**pa:ZZ**pb:ZZ**(({k:ZZ}->(x:ZZ)->(y:ZZ)->(x=x1+k*pa)->(y=y1+k*pb)->(c=x*a+y*b)),
      ((x:ZZ)->(y:ZZ)->(c=x*a+y*b)->(k**((x=x1+k*pa),(y=y1+k*pb)))))))
findAllSolutions a b c =
  (case checkNotBothZero a b of
        (Left (aZ,bZ)) =>
           (case decZero c of
                 (Yes cnotz) => Left (notZeroNotLinCombZeroZero aZ bZ cnotz)
                 (No ciszero) => Right (Left (zeroLinCombZeroZero aZ bZ
                    (notNotZeroThenZero ciszero))))
        (Right abnotZ) =>
          (case gcdZZ a b abnotZ of
            (g**gcdpf) =>
             (case decDivisibleZ c g of
                   (Yes prf) => Right (Right (allSolutions gcdpf prf abnotZ ))
                   (No contra) => Left (gcdDivLinCombContra gcdpf contra ))))


module Numeric
import Data.Nat

%default total

-- Well-founded Integer
-- All Integers are either a natural number
-- or the inversion of a positive number.
public export
data WFInt : Type where
     Nat : (n : Nat) -> WFInt
     Neg : (n : Nat) -> WFInt --Note: In the negative case, n=Z represents -1.

-- Magnitude of an integer
public export
mag : WFInt -> Nat
mag (Nat n) = n
mag (Neg n) = (S n)

-- Implement casting back and forth from normal Integer type
public export
Cast WFInt Integer where
     cast (Nat n) = cast n
     cast (Neg n) = negate $ cast (S n)

public export
Cast Integer WFInt where
     cast n = case (compare n 0) of
           EQ => Nat (fromInteger n)
           GT => Nat (fromInteger n)
           LT => Neg (fromInteger $ negate $ n + 1)

-- For arithmetic operations, cast to Integer and then cast back
public export
Num WFInt where
   (+) a b = cast $ (cast a) + (cast b)
   (*) a b = cast $ (cast a) * (cast b)
   fromInteger a = cast a

public export
Neg WFInt where
    negate a = cast $ negate $ (the Integer $ cast a)
    (-) a b = cast $ (the Integer $ cast a) - (the Integer $ cast b)

public export
partial
Integral WFInt where
         div a b = cast $ the Integer $ div (cast a) (cast b)
         mod a b = cast $ the Integer $ mod (cast a) (cast b)

-- n-parity, i.e. proof that an integer a is evenly divisible by n (or not).
public export
data Parity : (a : WFInt) -> (n : WFInt) -> Type where
     -- a has even n-parity if there exists an integer multiple x s.t. x*n = a.
     Factor    : (x : WFInt ** (x * n) = a) -> Parity a n
     ModIsZero : (mod n a = 0) -> Parity a n

public export
data OddParity : (a : WFInt) -> (n : WFInt) -> Type where
     -- a has odd n-parity if there exists
     Odd : (b : WFInt ** LT = compare (mag b) (mag n)) -> (Parity (a + b) n) ->  OddParity a n


module Algebra.Semiring

%default total

infixl 8 |+|
infixl 9 |*|

||| A Semiring has two binary operations and an identity for each
public export
interface Semiring a where
  (|+|) : a -> a -> a
  plusNeutral : a
  (|*|) : a -> a -> a
  timesNeutral : a

||| Erased linearity corresponds to the neutral for |+|
public export
erased : Semiring a => a
erased = plusNeutral

||| Purely linear corresponds to the neutral for |*|
public export
linear : Semiring a => a
linear = timesNeutral

||| A semiring eliminator
public export
elimSemi : (Semiring a, Eq a) => (zero : b) -> (one : b) -> (a -> b) -> a -> b
elimSemi zero one other r {a} =
  if r == Semiring.plusNeutral {a}
     then zero
     else if r == Semiring.timesNeutral {a}
             then one
             else other r

export
isErased : (Semiring a, Eq a) => a -> Bool
isErased = elimSemi True False (const False)

export
isLinear : (Semiring a, Eq a) => a -> Bool
isLinear = elimSemi False True (const False)

export
isRigOther : (Semiring a, Eq a) => a -> Bool
isRigOther = elimSemi False False (const True)

export
branchZero : (Semiring a, Eq a) => Lazy b -> Lazy b -> a -> b
branchZero yes no rig = if isErased rig then yes else no

export
branchOne : (Semiring a, Eq a) => Lazy b -> Lazy b -> a -> b
branchOne yes no rig = if isLinear rig then yes else no

export
branchVal : (Semiring a, Eq a) => Lazy b -> Lazy b -> a -> b
branchVal yes no rig = if isRigOther rig then yes else no


module Specifications.TranslationInvariance

import public Specifications.Group
import public Specifications.Order

%default total
%access public export

infixl 8 #

||| specification
isTranslationInvariantL : Binop s -> Binrel s -> Type
isTranslationInvariantL (#) rel = (x,y,a : _) -> rel x y -> rel (a # x) (a # y)

||| specification
isTranslationInvariantR : Binop s -> Binrel s -> Type
isTranslationInvariantR (#) rel = (x,y,a : _) -> rel x y -> rel (x # a) (y # a)

||| composed specification
data PartiallyOrderedMagmaSpec : Binop s -> Binrel s -> Type where
  MkPartiallyOrderedMagma :
    PartialOrderSpec leq ->
    isTranslationInvariantL op leq ->
    isTranslationInvariantR op leq ->
    PartiallyOrderedMagmaSpec op leq

||| forget
order : PartiallyOrderedMagmaSpec _ leq -> PartialOrderSpec leq
order (MkPartiallyOrderedMagma o _ _) = o

||| forget
translationInvariantL : PartiallyOrderedMagmaSpec op leq ->
  isTranslationInvariantL op leq
translationInvariantL (MkPartiallyOrderedMagma _ l _) = l

||| forget
translationInvariantR : PartiallyOrderedMagmaSpec op leq ->
  isTranslationInvariantR op leq
translationInvariantR (MkPartiallyOrderedMagma _ _ r) = r

||| composed specification
data PartiallyOrderedGroupSpec :
       Binop s -> s -> (s -> s) -> Binrel s -> Type where
  MkPartiallyOrderedGroup :
    GroupSpec op e inv ->
    PartiallyOrderedMagmaSpec op leq ->
    PartiallyOrderedGroupSpec op e inv leq

||| forget
invariantOrder : PartiallyOrderedGroupSpec op _ _ leq ->
  PartiallyOrderedMagmaSpec op leq
invariantOrder (MkPartiallyOrderedGroup _ m) = m

||| forget
group : PartiallyOrderedGroupSpec op e inv _ -> GroupSpec op e inv
group (MkPartiallyOrderedGroup g _) = g

namespace ForgetGroup
  order : PartiallyOrderedGroupSpec _ _ _ leq -> PartialOrderSpec leq
  order = order . invariantOrder

||| A symmetric interval [-u, u]
InSymRange : Binrel s -> (s -> s) -> s -> s -> Type
InSymRange rel inv u = Between rel (inv u, u)


module Main

import Data.Fin

data Direction = North | South | East | West

Position : Type
Position = (Nat, Nat)

record MarsRover where
       constructor MkRover
       upperBound : Position
       currentPosition : (Fin (fst upperBound), Fin (snd upperBound))
       direction : Direction
%name MarsRover rover, rover1, rover2

turnRight : MarsRover -> MarsRover
turnRight rover = MkRover (upperBound rover) (currentPosition rover) newDirection
          where newDirection = case direction rover of
                                    North => East
                                    South => West
                                    East  => South
                                    West  => North

turnLeft : MarsRover -> MarsRover
turnLeft rover = MkRover (upperBound rover) (currentPosition rover) newDirection
          where newDirection = case direction rover of
                                    North => West
                                    South => East
                                    East  => North
                                    West  => South

getPosition : MarsRover -> (Integer, Integer)
getPosition rover = let pos = currentPosition rover in (finToInteger (fst pos), finToInteger (snd pos))

move : MarsRover -> MarsRover
move = ?todo


module ExpressionParser
{- As an illustration to show interpreters are not hard to write, we make
an interpreter for a tiny language with:
  * a single data type: `Nat`
  * arithmetic expressions can have `+`, `*` and parenthesis.
  * assignment statements of the form `let variable = expression`, with variable names being a single character.
-}

import Parsers

-- Statements in our language, these are either expressions or definitions.
data Statement : Type where
  Expression: (n: Nat) -> Statement
  Definition: (var: Char) -> (value: Nat) -> Statement

-- A block (also called context) which is a list of statements but with the last statement the head of the list.
Block : Type
Block = List Statement

-- Getting a variable from a block; if it is defined more than once the last definition is used.
getVar : Block -> Char -> Maybe Nat
getVar [] c = Nothing
getVar ((Expression n) :: xs) c = getVar xs c
getVar ((Definition var value) :: xs) c =
  if var == c then Just value else getVar xs c

-- Parser for a variable name in a context
var : Block -> Parser Nat
var bl s = mapMaybe(letter)(getVar bl)(s)

-- Parsing a block of statements recursively
mutual
  -- A simple term in context: a literal natural number, a variable defined in the context or an expression in parenthesis
  simpleTerm : Block -> Parser Nat
  simpleTerm bl = nat || ((SS "(") <+ (expression bl) +> (SS ")")) || (var bl)

  -- A product of simple terms in context, possibly with just one simple term
  term : Block -> Parser Nat
  term bl = map(repSepTrim (simpleTerm bl) '*')(foldl(*)(1))

  -- A sum of terms in context, possibly with just one term
  expression: Block -> Parser Nat
  expression bl = map(repSepTrim (term bl) '+')(foldl(+)(0))

  -- An arithmetic expression as a statement parsed in context
  expr : Block -> Parser Statement
  expr bl = map(expression bl)(Expression)

  -- Parser for LHS and RHS of a definition in context
  defSides: Block -> Parser (Char, Nat)
  defSides bl = ((SS "let ") <+ letter +> (SS "=")) ++ (expression bl)

  -- Parser for a definition in a context
  defn : Block -> Parser Statement
  defn bl = map(defSides bl)(\p => (case p of
                                         (name, value) => Definition name value))

  -- Parser for a statement in context
  stat : Block -> Parser Statement
  stat bl = ((defn bl) || (expr bl)) +> ((SS ";") || map(eof)(\u => ";"))

  -- Parser for an empty block in context, returns the given context
  emptyBlock : Block -> Parser Block
  emptyBlock bl = map(rep(SS " ") <+ eof)(\u => bl)

  -- Recursively parsing a block given a context
  blockRec : Block -> Parser Block
  blockRec bl =
    (emptyBlock bl) ||
    flatMapWithNext(stat bl)(
      \s => blockRec (s :: bl))

-- Parser for a block, starting with the empty context
block: Parser Block
block = blockRec []

-- The value of a block: the value/rhs of the last statment, defaulting to 0
blockValue: Block -> Nat
blockValue [] = Z
blockValue ((Expression n) :: xs) = n
blockValue ((Definition var value) :: xs) = value

-- Interpret a string and getting the value of the result
interpret : String -> ParseResult Nat
interpret s = parse(map(block)(blockValue)) s

-- An example
eg: ParseResult Nat
eg = interpret "let a = (1 + 2 * (3 + 1)); let b = a + 3 ; a * (b + 1)"


-- Shamelessly stolen from Edwin Brady
module Main

pythag : Int -> List (Int, Int, Int)
pythag max = [
    (x, y, z)
    | z <- [1..max]
    , y <- [1..z]
    , x <- [1..y]
    , x * x + y * y == z * z
  ]

main : IO ()
main = do
  printLn $ pythag 100
  printLn $ sort ["foo", "bar", "baz"]


module Addition.Carry

import Common.Util
import Common.Interfaces
import Specifications.DiscreteOrderedGroup
import Proofs.GroupCancelationLemmas
import Proofs.Interval
import Addition.CarryLemmas

%default total
%access public export

data Carry = M | O | P

implementation Show Carry where
  show M = "M"
  show O = "O"
  show P = "P"

public export
value : Ringops s => Carry -> s
value P = One
value O = Zero
value M = Ng One

||| multiply by Carry
scale : s -> (s -> s) -> s -> Carry -> s
scale zero neg x M = neg x
scale zero neg x O = zero
scale zero neg x P = x

||| u = radix - 1
||| radix = u + 1
||| carry * radix + output = input
||| output in [-v..v] where v = u - 1
data Reduction :
  Binop s -> s -> (s -> s) -> Binrel s -> s -> s -> s -> {input : s} -> Type
  where MkReduction :
    .(input : s) -> (carry : Carry) -> (output : s) ->
    scale zero neg radix carry `add` output = input ->
    InSymRange leq neg (add u (neg unit)) output ->
    Reduction add zero neg leq unit u radix {input}

input : Reduction {s} _ _ _ _ _ _ _ {input = x} -> s
input _ = x

carry : Reduction _ _ _ _ _ _ _ -> Carry
carry (MkReduction _ c _ _ _) = c

output : Reduction {s} _ _ _ _ _ _ _ -> s
output (MkReduction _ _ o _ _) = o

result : Reduction {s} _ _ _ _ _ _ _ -> (Carry, s)
result (MkReduction _ c o _ _) = (c, o)

||| See README for a brief introduction.
||| 1 <= u - 1 means radix >= 3.
computeCarry : (Ringops s, Decidable [s,s] leq) =>
  DiscreteOrderedGroupSpec (+) Zero Ng leq One ->
  (u : s) -> leq One (u + Ng One) ->
  (x : s) -> InSymRange leq Ng (u + u) x ->
  Reduction (+) Zero Ng leq One u (One + u) {input = x}

computeCarry spec u bound x range =
  let pog = partiallyOrderedGroup spec
      grp = group (partiallyOrderedGroup spec)
      abel = abelian spec in
  case decidePartition3 spec (Ng u) u x range of
    Left prf
      => MkReduction x M (One + u + x)
           (groupCancel1bis grp _ x)
           (shiftLeftToSymRange pog u One x bound prf)
    Middle prf
      => MkReduction x O x
           (neutralL (monoid grp) _)
           (toSymRange pog abel prf)
    Right prf
      => MkReduction x P (x + Ng (One + u))
           (groupCancelAbelian grp abel _ x)
           (shiftRightToSymRange pog u One x bound prf)


module Utils.Matrix

import Utils.Conjugate

%default total
%access public export

Vector : Type -> Type
Vector = List
%name Vector xv, yv, zv

Matrix : Type -> Type
Matrix = Vector . Vector
%name Matrix xm, ym, zm

apply : Num a => Matrix a -> Vector a -> Vector a
apply xm xv = map (\row => sum (zipWith (*) row xv)) xm

transpose : Matrix a -> Matrix a
transpose [] = []
transpose (x :: xs) = zipWith (::) x xs

mmap : (a -> b) -> Matrix a -> Matrix b
mmap f = map (map f)

implementation Conjugate space coSpace => Conjugate (Matrix space) (Matrix coSpace) where
  conjug = Utils.Matrix.transpose . mmap conjug


import Language.Reflection

%language ElabReflection

data NatExpr : Nat -> Type where
     Plus : NatExpr x -> NatExpr y -> NatExpr (plus x y)
     Mult : NatExpr x -> NatExpr y -> NatExpr (mult x y)
     Dbl : NatExpr x -> NatExpr (mult 2 x)
     Val : (val : Nat) -> NatExpr val

getNatExpr : TTImp -> Elab (n ** NatExpr n)
getNatExpr `(Prelude.Types.plus ~(x) ~(y))
   = do (_ ** xval) <- getNatExpr x
        (_ ** yval) <- getNatExpr y
        pure (_ ** Plus xval yval)
getNatExpr `(Prelude.Types.mult (Prelude.Types.S (Prelude.Types.S Prelude.Types.Z)) ~(y))
   = do (y ** yval) <- getNatExpr y
        pure (_ ** Dbl yval)
getNatExpr `(Prelude.Types.mult ~(x) ~(y))
   = do (_ ** xval) <- getNatExpr x
        (_ ** yval) <- getNatExpr y
        pure (_ ** Mult xval yval)
getNatExpr x = pure (_ ** Val !(check x))

%macro
mkNatExpr : (n : Nat) -> Elab (NatExpr n)
mkNatExpr n
    = do Just `(Main.NatExpr ~(expr)) <- goal
              | _ => fail "Goal is not a NatExpr"
         (n' ** expr') <- getNatExpr expr
         check !(quote expr')

test1 : (x : Nat) -> (y : Nat) -> NatExpr (plus x (plus y x))
test1 x y = mkNatExpr _ -- yes, auto implicits can do this too :)

test2 : (x : Nat) -> (y : Nat) -> NatExpr (plus x (mult y x))
test2 x y = mkNatExpr _

test3 : (x : Nat) -> (y : Nat) -> NatExpr (plus x (mult 2 x))
test3 x y = mkNatExpr _ -- auto implicit search gets something different


module Tricho

data Trichotomy : (eq, lt : a -> a -> Type) -> (a -> a -> Type) where
  LT : {0 x, y : a} -> lt x y -> Trichotomy eq lt x y
  EQ : {0 x, y : a} -> eq x y -> Trichotomy eq lt x x
  GT : {0 x, y : a} -> lt y x -> Trichotomy eq lt x y

interface Trichotomous (a : Type) (eq, lt : a -> a -> Type) where

  trichotomy : (x, y : a) -> Trichotomy eq lt x y


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

%name Vect xs, ys, zs

append : Vect n a -> Vect m a -> Vect (n + m) a
append {n} xs ys = ?foo

vadd : Num a => Vect n a -> Vect n a -> Vect n a
vadd [] ys = ?bar
vadd (x :: xs) ys = ?baz

suc : (x : Nat) -> (y : Nat) -> x = y -> S x = S y
suc x y prf = ?quux

suc' : x = y -> S x = S y
suc' {x} {y} prf = ?quuz


module SizedStrings

import Data.Fin
import MaybeFin

%default total
%access public

||| A string with length encoded in the type
||| Need to investigate this PR:
||| https://github.com/idris-lang/Idris-dev/pull/2628
||| It may be that his work, if completed, would make this module obsolete!!
abstract data SizedString : Nat -> Type where
  SizedString' : (n : Nat) -> (s : String) -> SizedString n

%name SizedString str

||| This is the only was to create a SizedString
sizeString : (s : String) -> SizedString (length s)
sizeString s = SizedString' (length s) s

empty : SizedString Z
empty = sizeString ""

||| Length of the string, equal to the Nat carried in the type
length : SizedString n -> Nat
length {n} _ = n

length_is_embedded_in_type : (str : SizedString n) -> length str = n
length_is_embedded_in_type str = Refl

||| Typesafe way to get a character from a string at the specified index.
||| The order of arguments is patterned after Strings.strIndex, not, say, List.index.
||| Under the covers it does an assert_total call because the underlying
||| String.strIndex function is partial. However, we know this is safe as long
||| as SizedString is only created via the sizeString function from this module.
strIndex : SizedString n -> Fin n -> Char
strIndex (SizedString' _ s) x =
  assert_total $ strIndex s $ cast $ finToNat x

maybeStrIndex : SizedString n -> MaybeFin n -> Maybe Char
maybeStrIndex str NoFin = Nothing
maybeStrIndex str (SomeFin x) = Just $ strIndex str x

instance Cast (SizedString n) String where
  cast (SizedString' _ s) = s

replaceAt : Fin (S n) -> Char -> SizedString (S n) -> SizedString (S n)
replaceAt {n} i c (SizedString' _ str) =
  let charsBefore = finToNat i
      indexAfter = S charsBefore
      size = S n
      firstChunk = substr 0 charsBefore str
      secondChunk = substr indexAfter size str
  in SizedString' size $ firstChunk ++ (strCons c $ secondChunk)

maybeReplaceAt : MaybeFin n -> Char -> SizedString n -> SizedString n
maybeReplaceAt NoFin _ str = str
maybeReplaceAt (SomeFin x) c str = replaceAt x c str

(++) : SizedString n -> SizedString m -> SizedString (n + m)
(SizedString' _ str1) ++ (SizedString' _ str2) = SizedString' _ $ str1 ++ str2

private
splitAt : Nat -> SizedString n -> (String, String)
splitAt idx (SizedString' n str) =
  (substr 0 idx str, substr idx n str)

insertAfter : SizedString n -> (idx : MaybeFin n) -> SizedString m -> SizedString (n + m)
insertAfter str1 NoFin str2 = str1 ++ str2
insertAfter str (SomeFin x) (SizedString' _ infixStr) =
  let idx = S $ finToNat x
      splitStr = splitAt idx str
  in SizedString' _ $ (fst splitStr) ++ infixStr ++ (snd splitStr)

insertBefore : SizedString n -> (idx : MaybeFin n) -> SizedString m -> SizedString (m + n)
insertBefore str1 NoFin str2 = str2 ++ str1
insertBefore str (SomeFin x) (SizedString' _ infixStr) =
  let idx = finToNat x
      splitStr = splitAt idx str
  in SizedString' _ $ (fst splitStr) ++ infixStr ++ (snd splitStr)

deleteAt : MaybeFin n -> SizedString n -> SizedString (pred n)
deleteAt NoFin str = str
deleteAt (SomeFin x) (SizedString' (S k) str) =
  let idx = finToNat x
  in SizedString' k $ (substr 0 idx str) ++ (substr (S idx) (S k) str)


> module Sigma.Operations

> import Data.Fin
> import Data.Vect

> import Sigma.Sigma
> import Finite.Predicates
> import Decidable.Predicates
> import Finite.Operations
> import Vect.Operations

> %default total

> %access public export

> |||
> outl : {A : Type} -> {P : A -> Type} -> Sigma A P -> A
> outl (MkSigma a _) = a

> |||
> outr : {A : Type} -> {P : A -> Type} -> (s : Sigma A P) -> P (outl s)
> outr (MkSigma _ p) = p

> ||| Maps a finite type |A| and a decidable predicate |P| to a vector |Sigma A P| values
> toVectSigma : {A : Type} ->
>               {P : A -> Type} ->
>               Finite A ->
>               Dec1 P ->
>               Sigma Nat (\ n => Vect n (Sigma A P))
> toVectSigma fA d1P = filterTagSigma d1P (toVect fA)

> {-

> ---}


> module FastSimpleProb.Operations

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.MonadicProperties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.BasicOperations
> import Rel.TotalPreorder
> import NonNegDouble.LTEProperties
> import List.Operations
> import List.Properties
> import Fun.Operations
> import Double.Predicates

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

> |||
> mostProbableProb : {A : Type} -> (Eq A) => SimpleProb A -> (A, NonNegDouble)
> mostProbableProb {A} sp = argmaxMax totalPreorderLTE aps neaps where
>   aps   : List (A, NonNegDouble)
>   aps   = map (pair (id, (prob sp))) (nub (support sp))
>   nes   : List.Operations.NonEmpty (support sp)
>   nes   = mapPreservesNonEmpty fst (toList sp) (nonEmptyLemma1 sp)
>   nens  : List.Operations.NonEmpty (nub (support sp))
>   nens  = nubPreservesNonEmpty (support sp) nes
>   neaps : List.Operations.NonEmpty aps
>   neaps = mapPreservesNonEmpty (pair (id, (prob sp))) (nub (support sp)) nens

> |||
> mostProbable : {A : Type} -> (Eq A) => SimpleProb A -> A
> mostProbable = fst . mostProbableProb

> |||
> maxProbability : {A : Type} -> (Eq A) => SimpleProb A -> NonNegDouble
> maxProbability = snd . mostProbableProb

> |||
> sortToList : {A : Type} -> (Eq A) => SimpleProb A -> List (A, NonNegDouble)
> sortToList {A} sp = sortBy ord aps where
>   aps : List (A, NonNegDouble)
>   aps = map (pair (id, (prob sp))) (nub (support sp))
>   ord : (A, NonNegDouble) -> (A, NonNegDouble) -> Ordering
>   ord (a1, pa1) (a2, pa2) = compare (toDouble pa1) (toDouble pa2)

> |||
> naiveMostProbableProb : {A : Type} -> SimpleProb A -> (A, NonNegDouble)
> naiveMostProbableProb sp = argmaxMax totalPreorderLTE (toList sp) (nonEmptyLemma1 sp)

> |||
> naiveMostProbable : {A : Type} -> SimpleProb A -> A
> naiveMostProbable = fst . naiveMostProbableProb

> |||
> naiveMaxProbability : {A : Type} -> SimpleProb A -> NonNegDouble
> naiveMaxProbability = snd . naiveMostProbableProb

> |||
> naiveSortToList : {A : Type} -> SimpleProb A -> List (A, NonNegDouble)
> naiveSortToList {A} sp = sortBy ord (toList sp) where
>   ord : (A, NonNegDouble) -> (A, NonNegDouble) -> Ordering
>   ord (a1, pa1) (a2, pa2) = if (toDouble pa1) == (toDouble pa2)
>                             then EQ
>                             else if (toDouble pa1) < (toDouble pa2)
>                                  then GT
>                                  else LT

> {-

> ---}


-- Classical propositional logic, PHOAS approach, final encoding

module Pf.Cp

%default total

-- Types

infixl 2 :&&
infixl 1 :||
infixr 0 :=>
data Ty : Type where
  UNIT  :             Ty
  (:=>) : Ty -> Ty -> Ty
  (:&&) : Ty -> Ty -> Ty
  (:||) : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 :<=>
(:<=>) : Ty -> Ty -> Ty
(:<=>) a b = (a :=> b) :&& (b :=> a)

NOT : Ty -> Ty
NOT a = a :=> FALSE

TRUE : Ty
TRUE = FALSE :=> FALSE

-- Context and truth judgement

Cx : Type
Cx = Ty -> Type

isTrue : Ty -> Cx -> Type
isTrue a tc = tc a

-- Terms

TmRepr : Type
TmRepr = Cx -> Ty -> Type

infixl 1 :$
class ArrMpTm (tr : TmRepr) where
  var  : isTrue a tc                -> tr tc a
  lam' : (isTrue a tc -> tr tc b)   -> tr tc (a :=> b)
  (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b

lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b)
lam'' f = lam' $ \x => f (var x)

syntax "lam" {a} ":=>" [b] = lam'' (\a => b)

class ArrMpTm tr => MpTm (tr : TmRepr) where
  pair  : tr tc a         -> tr tc b -> tr tc (a :&& b)
  fst   : tr tc (a :&& b)            -> tr tc a
  snd   : tr tc (a :&& b)            -> tr tc b
  left  : tr tc a                    -> tr tc (a :|| b)
  right : tr tc b                    -> tr tc (a :|| b)
  case' : tr tc (a :|| b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c

case'' : {tr : TmRepr} -> MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c
case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y))

syntax "["    [a]  ","  [b] "]" = pair a b
syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2)

class MpTm tr => CpTm (tr : TmRepr) where
  abort' : (isTrue (NOT a) tc -> tr tc FALSE) -> tr tc a

abort'' : {tr : TmRepr} -> CpTm tr => (tr tc (NOT a) -> tr tc FALSE) -> tr tc a
abort'' f = abort' $ \na => f (var na)

syntax "abort" {a} ":=>" [b] = abort'' (\a => b)

Thm : Ty -> Type
Thm a = {tr : TmRepr} -> {tc : Cx} -> CpTm tr => tr tc a


module WTypes

data W : (t : Type) -> (p : t -> Type) -> Type where
  Sup : (x : t) -> (p x -> W t p) -> W t p

ind : {t : Type} -> {p : t -> Type} -> (pred : W t p -> Type) ->
      ((v : t) -> (f : p v -> W t p) -> ((t' : p v) -> pred (f t')) -> pred (Sup v f)) ->
      (w : W t p) -> pred w
ind _ p (Sup x f) = p x f (\t => ind _ p (f t))

efq : {a : Type} -> Void -> a

-- Nat encoding
N : Type
N = W Bool (\b => if b then () else Void)

zero : N
zero = Sup False efq

succ : N -> N
succ n = Sup True (const n)

plus : N -> N -> N
plus (Sup False f) b = b
plus (Sup True f) b = Sup True (\() => plus (f ()) b)

-- Tree encoding
Tree : Type
Tree = W Bool (\b => if b then Bool else Void)

leaf : Tree
leaf = Sup False efq

branch : Tree -> Tree -> Tree
branch l r = Sup True (\b => if b then l else r)

size : Tree -> N
size (Sup False f) = zero
size (Sup True f) = plus (size (f True)) (size (f False))


module Data.Stream

import Data.List
import Data.List1
import public Data.Zippable

%default total

||| Drop the first n elements from the stream
||| @ n how many elements to drop
public export
drop : (n : Nat) -> Stream a -> Stream a
drop Z     xs = xs
drop (S k) (x::xs) = drop k xs

||| An infinite stream of repetitions of the same thing
public export
repeat : a -> Stream a
repeat x = x :: repeat x

||| Generate an infinite stream by repeatedly applying a function
||| @ f the function to iterate
||| @ x the initial value that will be the head of the stream
public export
iterate : (f : a -> a) -> (x : a) -> Stream a
iterate f x = x :: iterate f (f x)

public export
unfoldr : (b -> (a, b)) -> b -> Stream a
unfoldr f c = let (a, n) = f c in a :: unfoldr f n

||| All of the natural numbers, in order
public export
nats : Stream Nat
nats = iterate S Z

||| Get the nth element of a stream
public export
index : Nat -> Stream a -> a
index Z     (x::xs) = x
index (S k) (x::xs) = index k xs

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

public export
Zippable Stream where
  zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

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

  unzipWith f xs = unzip (map f xs)

  unzip xs = (map fst xs, map snd xs)

  unzipWith3 f xs = unzip3 (map f xs)

  unzip3 xs = (map (\(x, _, _) => x) xs, map (\(_, x, _) => x) xs, map (\(_, _, x) => x) xs)

export
zipWithIndexLinear : (0 f : _) -> (xs, ys : Stream a) -> (i : Nat) -> index i (zipWith f xs ys) = f (index i xs) (index i ys)
zipWithIndexLinear f (_::xs) (_::ys) Z     = Refl
zipWithIndexLinear f (_::xs) (_::ys) (S k) = zipWithIndexLinear f xs ys k

export
zipWith3IndexLinear : (0 f : _) -> (xs, ys, zs : Stream a) -> (i : Nat) -> index i (zipWith3 f xs ys zs) = f (index i xs) (index i ys) (index i zs)
zipWith3IndexLinear f (_::xs) (_::ys) (_::zs) Z     = Refl
zipWith3IndexLinear f (_::xs) (_::ys) (_::zs) (S k) = zipWith3IndexLinear f xs ys zs k

||| Return the diagonal elements of a stream of streams
export
diag : Stream (Stream a) -> Stream a
diag ((x::xs)::xss) = x :: diag (map tail xss)

||| Produce a Stream of left folds of prefixes of the given Stream
||| @ f the combining function
||| @ acc the initial value
||| @ xs the Stream to process
export
scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Stream b) -> Stream a
scanl f acc (x :: xs) = acc :: scanl f (f acc x) xs

||| Produce a Stream repeating a sequence
||| @ xs the sequence to repeat
||| @ ok proof that the list is non-empty
export
cycle : (xs : List a) -> {auto 0 ok : NonEmpty xs} -> Stream a
cycle (x :: xs) = x :: cycle' xs
  where cycle' : List a -> Stream a
        cycle' []        = x :: cycle' xs
        cycle' (y :: ys) = y :: cycle' ys

--------------------------------------------------------------------------------
-- Interleavings
--------------------------------------------------------------------------------

-- zig, zag, and cantor are taken from the paper
-- Applications of Applicative Proof Search
-- by Liam O'Connor

public export
zig : List1 (Stream a) -> Stream (Stream a) -> Stream a

public export
zag : List1 a -> List1 (Stream a) -> Stream (Stream a) -> Stream a

zig xs = zag (head <$> xs) (tail <$> xs)

zag (x ::: []) zs (l :: ls) = x :: zig (l ::: forget zs) ls
zag (x ::: (y :: xs)) zs ls = x :: zag (y ::: xs) zs ls

public export
cantor : Stream (Stream a) -> Stream a
cantor (l :: ls) = zig (l ::: []) ls

-- Exploring the Nat*Nat top right quadrant of the plane
-- using Cantor's zig-zag traversal:
example :
  let quadrant : Stream (Stream (Nat, Nat))
      quadrant = map (\ i => map (i,) Stream.nats) Stream.nats
  in
     take 10 (cantor quadrant)
     === [ (0, 0)
         , (1, 0), (0, 1)
         , (2, 0), (1, 1), (0, 2)
         , (3, 0), (2, 1), (1, 2), (0, 3)
         ]
example = Refl

namespace DPair

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  planeWith : {0 p : a -> Type} ->
              ((x : a) -> p x -> c) ->
              Stream a -> ((x : a) -> Stream (p x)) ->
              Stream c
  planeWith k as f = cantor (map (\ x => map (k x) (f x)) as)

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  plane : {0 p : a -> Type} ->
          Stream a -> ((x : a) -> Stream (p x)) ->
          Stream (x : a ** p x)
  plane = planeWith (\ x, prf => (x ** prf))

namespace Pair

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  planeWith : (a -> b -> c) ->
              Stream a -> (a -> Stream b) ->
              Stream c
  planeWith k as f = cantor (map (\ x => map (k x) (f x)) as)

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  plane : Stream a -> (a -> Stream b) -> Stream (a, b)
  plane = Pair.planeWith (,)

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

export
Applicative Stream where
  pure = repeat
  (<*>) = zipWith apply

export
Monad Stream where
  s >>= f = diag (map f s)

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

lengthTake : (n : Nat) -> (xs : Stream a) -> length (take n xs) = n
lengthTake Z _ = Refl
lengthTake (S n) (x :: xs) = cong S (lengthTake n xs)


module BTree

%default total

public export
data BTree : Type -> Type where
  Leaf : BTree a
  Node : BTree a -> a -> BTree a -> BTree a

export
insert : Ord a => a -> BTree a -> BTree a
insert x Leaf = Node Leaf x Leaf
insert x tree@(Node l v r) = case compare x v of
                              LT => Node (insert x l) v r
                              GT => Node l v (insert x r)
                              EQ => tree

export
toList : BTree a -> List a
toList Leaf = []
toList (Node l v r) = toList l ++ [v] ++ toList r

export
toTree : Ord a => List a -> BTree a
toTree [] = Leaf
toTree (x :: xs) = insert x (toTree xs)


||| Show sum of the numbers from input
module NumbersSum

import Data.String

sumNums : List (Maybe Integer) -> Maybe Integer
sumNums [] = Just 0
sumNums (x :: xs) = case (x, sumNums xs) of
                      (Just num1, Just num2) => Just(num1 + num2)
                      (_, _) => Nothing
main : IO ()
main = do
  putStr "Enter numbers separated by a space: "
  x <- getLine
  case sumNums (map parseInteger (words x)) of
    Just sum => putStrLn ("Sum is " ++ show sum)
    Nothing => putStrLn "Invalid input"