module Physics.Vector2D

public export
Vector2D : Type
Vector2D = (Double, Double)

export
Num Vector2D where
  (a1, b1) + (a2, b2) = (a1+a2, b1+b2)
  (a1, b1) * (a2, b2) = (a1*a2, b1*b2)
  fromInteger a = (cast a, cast a)

export
Neg Vector2D where
  negate (x, y) = (-x, -y)
  (x2, y2) - (x1, y1) = (x2-x1, y2-y1)

export
Abs Vector2D where
  abs (x, y) = (abs x, abs y)

export
norm : Vector2D -> Double
norm (x, y) = sqrt $ x*x + y*y

export
scale : Double -> Vector2D -> Vector2D
scale a (x, y) = (a*x, a*y)

infix 7 `scale`

public export
Cast (Integer, Integer) Vector2D where
  cast (x, y) = (the Double (cast x), the Double (cast y))

public export
Cast Vector2D (Int, Int) where
  cast (x, y) = (cast x, cast y)

export
nullVector : Vector2D
nullVector = (0, 0)

export
magnitude : Vector2D -> Double
magnitude (a, b) = sqrt(a*a + b*b)

export
normed : Vector2D -> Vector2D
normed x = let magnitude' = 1.0/(magnitude x) in magnitude' `scale` x

export
angle : Vector2D -> Double
angle (x, y) = atan2 y x


data EqNat : Nat -> Nat -> Type where
     Same : (x : Nat) -> EqNat x x

total
sameS : (k : Nat) -> (j : Nat) -> (eq : EqNat k j) -> EqNat (S k) (S j)
sameS k k (Same k) = Same (S k)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z (S k) = Nothing
checkEqNat (S k) Z = Nothing
checkEqNat (S k) (S j) = case checkEqNat k j of
                              Nothing => Nothing
                              Just eq => Just (sameS _ _ eq)


twoplustwo_not_five : 2 + 2 = 5 -> Void
twoplustwo_not_five Refl impossible

value_not_suc : (x : Nat) -> x = S x -> Void
value_not_suc _ Refl impossible

zero_not_succ : (0 = S k) -> Void
zero_not_succ Refl impossible

succ_not_zero : (S k = 0) -> Void
succ_not_zero Refl impossible

no_rec : (contra : (k = j) -> Void) -> (S k = S j) -> Void
no_rec contra Refl = contra Refl

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Dec (num1 = num2)
checkEqNat Z Z = Yes Refl
checkEqNat Z (S k) = No zero_not_succ
checkEqNat (S k) Z = No succ_not_zero
checkEqNat (S k) (S j) = case checkEqNat k j of
                              (Yes prf) => Yes (cong prf)
                              (No contra) => No (no_rec contra)


module Prelude.Types

import Builtin
import PrimIO
import Prelude.Basics
import Prelude.EqOrd
import Prelude.Interfaces
import Prelude.Num
import Prelude.Uninhabited

%default total

-----------
-- NATS ---
-----------

||| Natural numbers: unbounded, unsigned integers which can be pattern matched.
public export
data Nat =
  ||| Zero.
    Z
  | ||| Successor.
  S Nat

%name Nat k, j, i

-- This is used in the compiler as an efficient substitute for integerToNat.
prim__integerToNat : Integer -> Nat
prim__integerToNat i
  = if intToBool (prim__lte_Integer 0 i)
      then believe_me i
      else Z

public export
integerToNat : Integer -> Nat
integerToNat 0 = Z -- Force evaluation and hence caching of x at compile time
integerToNat x
  = if intToBool (prim__lte_Integer x 0)
       then Z
       else S (assert_total (integerToNat (prim__sub_Integer x 1)))

-- %builtin IntegerToNatural Prelude.Types.integerToNat

-- Define separately so we can spot the name when optimising Nats
||| Add two natural numbers.
||| @ x the number to case-split on
||| @ y the other numberpublic export
public export
plus : (x : Nat) -> (y : Nat) -> Nat
plus Z y = y
plus (S k) y = S (plus k y)

||| Subtract natural numbers.  If the second number is larger than the first,
||| return 0.
public export
minus : (left : Nat) -> Nat -> Nat
minus Z        right     = Z
minus left     Z         = left
minus (S left) (S right) = minus left right

||| Multiply natural numbers.
public export
mult : (x : Nat) -> Nat -> Nat
mult Z y = Z
mult (S k) y = plus y (mult k y)

public export
Num Nat where
  (+) = plus
  (*) = mult

  fromInteger x = integerToNat x

-- used for nat hack
public export
equalNat : (m, n : Nat) -> Bool
equalNat Z Z = True
equalNat (S j) (S k) = equalNat j k
equalNat _ _ = False

public export
Eq Nat where
  (==) = equalNat

-- used for nat hack
public export
compareNat : (m, n : Nat) -> Ordering
compareNat Z Z = EQ
compareNat Z (S k) = LT
compareNat (S k) Z = GT
compareNat (S j) (S k) = compareNat j k

public export
Ord Nat where
  compare = compareNat

public export
natToInteger : Nat -> Integer
natToInteger Z = 0
natToInteger (S k) = 1 + natToInteger k
                         -- integer (+) may be non-linear in second
                         -- argument

-- %builtin NaturalToInteger Prelude.Types.natToInteger

||| Counts the number of elements that satify a predicate.
public export
count : (Foldable t) => (predicate : a -> Bool) -> (t a) -> Nat
count predicate = foldMap @{%search} @{Additive} (\x => if predicate x then 1 else 0)

-----------
-- PAIRS --
-----------

%inline
public export
Bifunctor Pair where
  bimap f g (x, y) = (f x, g y)

%inline
public export
Bifoldable Pair where
  bifoldr f g acc (x, y) = f x (g y acc)
  bifoldl f g acc (x, y) = g (f acc x) y
  binull _ = False

%inline
public export
Bitraversable Pair where
  bitraverse f g (a,b) = [| (,) (f a) (g b) |]

%inline
public export
Functor (Pair a) where
  map = mapSnd

%inline
public export
Monoid a => Applicative (Pair a) where
  pure = (neutral,)
  (a1,f) <*> (a2,v) = (a1 <+> a2, f v)

%inline
public export
Monoid a => Monad (Pair a) where
  (a1,a) >>= f = let (a2,b) = f a in (a1 <+> a2, b)

-----------
-- MAYBE --
-----------

||| An optional value.  This can be used to represent the possibility of
||| failure, where a function may return a value, or not.
public export
data Maybe : (ty : Type) -> Type where
  ||| No value stored
  Nothing : Maybe ty

  ||| A value of type `ty` is stored
  Just : (x : ty) -> Maybe ty

public export
Uninhabited (Nothing = Just x) where
  uninhabited Refl impossible

public export
Uninhabited (Just x = Nothing) where
  uninhabited Refl impossible

public export
maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b
maybe n j Nothing  = n
maybe n j (Just x) = j x

||| Execute an applicative expression when the Maybe is Just
%inline public export
whenJust : Applicative f => Maybe a -> (a -> f ()) -> f ()
whenJust (Just a) k = k a
whenJust Nothing k = pure ()

public export
Eq a => Eq (Maybe a) where
  Nothing  == Nothing  = True
  Nothing  == (Just _) = False
  (Just _) == Nothing  = False
  (Just a) == (Just b) = a == b

public export
Ord a => Ord (Maybe a) where
  compare Nothing  Nothing  = EQ
  compare Nothing  (Just _) = LT
  compare (Just _) Nothing  = GT
  compare (Just a) (Just b) = compare a b

public export
Semigroup (Maybe a) where
  Nothing   <+> m = m
  (Just x)  <+> _ = Just x

public export
Monoid (Maybe a) where
  neutral = Nothing

public export
Functor Maybe where
  map f (Just x) = Just (f x)
  map f Nothing  = Nothing

public export
Applicative Maybe where
  pure = Just

  Just f <*> Just a = Just (f a)
  _      <*> _      = Nothing

public export
Alternative Maybe where
  empty = Nothing

  (Just x) <|> _ = Just x
  Nothing  <|> v = v

public export
Monad Maybe where
  Nothing  >>= k = Nothing
  (Just x) >>= k = k x

public export
Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = f x z
  null Nothing = True
  null (Just _) = False

public export
Traversable Maybe where
  traverse f Nothing = pure Nothing
  traverse f (Just x) = Just <$> f x

---------
-- DEC --
---------

||| Decidability.  A decidable property either holds or is a contradiction.
public export
data Dec : Type -> Type where
  ||| The case where the property holds.
  ||| @ prf the proof
  Yes : (prf : prop) -> Dec prop

  ||| The case where the property holding would be a contradiction.
  ||| @ contra a demonstration that prop would be a contradiction
  No  : (contra : Not prop) -> Dec prop

export Uninhabited (Yes p === No q) where uninhabited eq impossible
export Uninhabited (No p === Yes q) where uninhabited eq impossible

------------
-- EITHER --
------------

||| A sum type.
public export
data Either : (a : Type) -> (b : Type) -> Type where
  ||| One possibility of the sum, conventionally used to represent errors.
  Left : forall a, b. (x : a) -> Either a b

  ||| The other possibility, conventionally used to represent success.
  Right : forall a, b. (x : b) -> Either a b

export Uninhabited (Left p === Right q) where uninhabited eq impossible
export Uninhabited (Right p === Left q) where uninhabited eq impossible

export
Either (Uninhabited a) (Uninhabited b) => Uninhabited (a, b) where
  uninhabited (x, _) @{Left  _} = uninhabited x
  uninhabited (_, y) @{Right _} = uninhabited y

export
Uninhabited a => Uninhabited b => Uninhabited (Either a b) where
  uninhabited (Left l)  = uninhabited l
  uninhabited (Right r) = uninhabited r

||| Simply-typed eliminator for Either.
||| @ f the action to take on Left
||| @ g the action to take on Right
||| @ e the sum to analyze
public export
either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c
either l r (Left x) = l x
either l r (Right x) = r x

public export
(Eq a, Eq b) => Eq (Either a b) where
  Left x == Left x' = x == x'
  Right x == Right x' = x == x'
  _ == _ = False

public export
(Ord a, Ord b) => Ord (Either a b) where
  compare (Left x) (Left x') = compare x x'
  compare (Left _) (Right _) = LT
  compare (Right _) (Left _) = GT
  compare (Right x) (Right x') = compare x x'

%inline
public export
Functor (Either e) where
  map f (Left x) = Left x
  map f (Right x) = Right (f x)

%inline
public export
Bifunctor Either where
  bimap f _ (Left x) = Left (f x)
  bimap _ g (Right y) = Right (g y)

%inline
public export
Bifoldable Either where
  bifoldr f _ acc (Left a)  = f a acc
  bifoldr _ g acc (Right b) = g b acc

  bifoldl f _ acc (Left a)  = f acc a
  bifoldl _ g acc (Right b) = g acc b

  binull _ = False

%inline
public export
Bitraversable Either where
  bitraverse f _ (Left a)  = Left <$> f a
  bitraverse _ g (Right b) = Right <$> g b

%inline
public export
Applicative (Either e) where
  pure = Right

  (Left a) <*> _          = Left a
  (Right f) <*> (Right r) = Right (f r)
  (Right _) <*> (Left l)  = Left l

public export
Monad (Either e) where
  (Left n) >>= _ = Left n
  (Right r) >>= f = f r

public export
Foldable (Either e) where
  foldr f acc (Left _) = acc
  foldr f acc (Right x) = f x acc
  null (Left _) = True
  null (Right _) = False

public export
Traversable (Either e) where
  traverse f (Left x)  = pure (Left x)
  traverse f (Right x) = Right <$> f x

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

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

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

namespace List
  public export
  (++) : (xs, ys : List a) -> List a
  [] ++ ys = ys
  (x :: xs) ++ ys = x :: xs ++ ys

  public export
  length : List a -> Nat
  length []        = Z
  length (x :: xs) = S (length xs)

  public export
  reverseOnto : List a -> List a -> List a
  reverseOnto acc [] = acc
  reverseOnto acc (x::xs) = reverseOnto (x::acc) xs

  public export
  reverse : List a -> List a
  reverse = reverseOnto []

  ||| Tail-recursive append. Uses of (++) are automatically transformed to
  ||| this. The only reason this is exported is that the proof of equivalence
  ||| lives in a different module.
  public export
  tailRecAppend : (xs, ys : List a) -> List a
  tailRecAppend xs ys = reverseOnto ys (reverse xs)

  -- Always use tailRecAppend at runtime. Data.List.tailRecAppendIsAppend
  -- proves these are equivalent.
  %transform "tailRecAppend" (++) = tailRecAppend

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

public export
Semigroup (List a) where
  (<+>) = (++)

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

public export
Foldable List where
  foldr c n [] = n
  foldr c n (x::xs) = c x (foldr c n xs)

  foldl f q [] = q
  foldl f q (x::xs) = foldl f (f q x) xs

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

  toList = id

  foldMap f = foldl (\acc, elem => acc <+> f elem) neutral

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

public export
Alternative List where
  empty = []
  xs <|> ys = xs ++ ys

public export
Monad List where
  m >>= f = concatMap f m

public export
Traversable List where
  traverse f [] = pure []
  traverse f (x::xs) = [| f x :: traverse f xs |]

-- This works quickly because when string-concat builds the result, it allocates
-- enough room in advance so there's only one allocation, rather than lots!
--
-- Like fastUnpack, this function won't reduce at compile time.
-- If you need to concatenate strings at compile time, use Prelude.concat.
%foreign
  "scheme:string-concat"
  "RefC:fastConcat"
  "javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
  "jvm:concat(io/github/mmhelloworld/idrisjvm/runtime/IdrisList java/lang/String),io/github/mmhelloworld/idrisjvm/runtime/Strings"
export
fastConcat : List String -> String

%transform "fastConcat" concat {t = List} {a = String} = fastConcat

||| Check if something is a member of a list using the default Boolean equality.
public export
elem : Eq a => a -> List a -> Bool
x `elem` [] = False
x `elem` (y :: ys) = x == y ||  elem x ys

||| Lookup a value at a given position
export
getAt : Nat -> List a -> Maybe a
getAt Z     (x :: xs) = Just x
getAt (S k) (x :: xs) = getAt k xs
getAt _     []        = Nothing

-------------
-- STREAMS --
-------------

namespace Stream
  ||| An infinite stream.
  public export
  data Stream : Type -> Type where
       (::) : a -> Inf (Stream a) -> Stream a

%name Stream xs, ys, zs

public export
Functor Stream where
  map f (x :: xs) = f x :: map f xs

||| The first element of an infinite stream.
public export
head : Stream a -> a
head (x :: xs) = x

||| All but the first element.
public export
tail : Stream a -> Stream a
tail (x :: xs) = xs

||| Take precisely n elements from the stream.
||| @ n how many elements to take
||| @ xs the stream
public export
take : (n : Nat) -> (xs : Stream a) -> List a
take Z xs = []
take (S k) (x :: xs) = x :: take k xs

-------------
-- STRINGS --
-------------

namespace String
  public export
  (++) : (x : String) -> (y : String) -> String
  x ++ y = prim__strAppend x y

  ||| Returns the length of the string.
  |||
  ||| ```idris example
  ||| length ""
  ||| ```
  ||| ```idris example
  ||| length "ABC"
  ||| ```
  public export
  length : String -> Nat
  length str = fromInteger (prim__cast_IntInteger (prim__strLength str))

||| Reverses the elements within a string.
|||
||| ```idris example
||| reverse "ABC"
||| ```
||| ```idris example
||| reverse ""
||| ```
public export
reverse : String -> String
reverse = prim__strReverse

||| Returns a substring of a given string
|||
||| @ index The (zero based) index of the string to extract.  If this is beyond
|||         the end of the string, the function returns the empty string.
||| @ len The desired length of the substring.  Truncated if this exceeds the
|||       length of the input
||| @ subject The string to return a portion of
public export
substr : (index : Nat) -> (len : Nat) -> (subject : String) -> String
substr s e subj
    = if natToInteger s < natToInteger (length subj)
         then prim__strSubstr (prim__cast_IntegerInt (natToInteger s))
                              (prim__cast_IntegerInt (natToInteger e))
                              subj
         else ""

||| Adds a character to the front of the specified string.
|||
||| ```idris example
||| strCons 'A' "B"
||| ```
||| ```idris example
||| strCons 'A' ""
||| ```
public export
strCons : Char -> String -> String
strCons = prim__strCons

public export
strUncons : String -> Maybe (Char, String)
strUncons "" = Nothing
strUncons str = assert_total $ Just (prim__strHead str, prim__strTail str)

||| Turns a list of characters into a string.
public export
pack : List Char -> String
pack [] = ""
pack (x :: xs) = strCons x (pack xs)

%foreign
    "scheme:string-pack"
    "RefC:fastPack"
    "javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
    "jvm:pack(io/github/mmhelloworld/idrisjvm/runtime/IdrisList java/lang/String),io/github/mmhelloworld/idrisjvm/runtime/Strings"
export
fastPack : List Char -> String

-- always use 'fastPack' at run time
%transform "fastPack" pack = fastPack

||| Turns a string into a list of characters.
|||
||| ```idris example
||| unpack "ABC"
||| ```
public export
unpack : String -> List Char
unpack str = unpack' (prim__cast_IntegerInt (natToInteger (length str)) - 1) str []
  where
    unpack' : Int -> String -> List Char -> List Char
    unpack' pos str acc
        = if pos < 0
             then acc
             else unpack' (assert_smaller pos (pos - 1)) str $ (assert_total $ prim__strIndex str pos) :: acc

-- This function runs fast when compiled but won't compute at compile time.
-- If you need to unpack strings at compile time, use Prelude.unpack.
%foreign
  "scheme:string-unpack"
  "RefC:fastUnpack"
  "javascript:lambda:(str)=>__prim_js2idris_array(Array.from(str))"
  "jvm:unpack(java/lang/String io/github/mmhelloworld/idrisjvm/runtime/IdrisList),io/github/mmhelloworld/idrisjvm/runtime/Strings"
export
fastUnpack : String -> List Char

-- always use 'fastPack' at run time
%transform "fastUnpack" unpack = fastUnpack

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

public export
Monoid String where
  neutral = ""

----------------
-- CHARACTERS --
----------------

||| Returns true if the character is in the range [A-Z].
public export
isUpper : Char -> Bool
isUpper x = x >= 'A' && x <= 'Z'

||| Returns true if the character is in the range [a-z].
public export
isLower : Char -> Bool
isLower x = x >= 'a' && x <= 'z'

||| Returns true if the character is in the ranges [A-Z][a-z].
public export
isAlpha : Char -> Bool
isAlpha x = isUpper x || isLower x

||| Returns true if the character is in the range [0-9].
public export
isDigit : Char -> Bool
isDigit x = (x >= '0' && x <= '9')

||| Returns true if the character is in the ranges [A-Z][a-z][0-9].
public export
isAlphaNum : Char -> Bool
isAlphaNum x = isDigit x || isAlpha x

||| Returns true if the character is a whitespace character.
public export
isSpace : Char -> Bool
isSpace x
    = x == ' '  || x == '\t' || x == '\r' ||
      x == '\n' || x == '\f' || x == '\v' ||
      x == '\xa0'

||| Returns true if the character represents a new line.
public export
isNL : Char -> Bool
isNL x = x == '\r' || x == '\n'

||| Convert a letter to the corresponding upper-case letter, if any.
||| Non-letters are ignored.
public export
toUpper : Char -> Char
toUpper x
    = if (isLower x)
         then prim__cast_IntChar (prim__cast_CharInt x - 32)
         else x

||| Convert a letter to the corresponding lower-case letter, if any.
||| Non-letters are ignored.
public export
toLower : Char -> Char
toLower x
    = if (isUpper x)
         then prim__cast_IntChar (prim__cast_CharInt x + 32)
         else x

||| Returns true if the character is a hexadecimal digit i.e. in the range
||| [0-9][a-f][A-F].
public export
isHexDigit : Char -> Bool
isHexDigit x = elem (toUpper x) hexChars where
  hexChars : List Char
  hexChars
      = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
         'A', 'B', 'C', 'D', 'E', 'F']

||| Returns true if the character is an octal digit.
public export
isOctDigit : Char -> Bool
isOctDigit x = (x >= '0' && x <= '7')

||| Returns true if the character is a control character.
public export
isControl : Char -> Bool
isControl x
    = (x >= '\x0000' && x <= '\x001f')
       || (x >= '\x007f' && x <= '\x009f')

||| Convert the number to its backend dependent (usually Unicode) Char
||| equivalent.
public export
chr : Int -> Char
chr = prim__cast_IntChar

||| Return the backend dependent (usually Unicode) numerical equivalent of the Char.
public export
ord : Char -> Int
ord = prim__cast_CharInt

-----------------------
-- DOUBLE PRIMITIVES --
-----------------------

public export
pi : Double
pi = 3.14159265358979323846

public export
euler : Double
euler = 2.7182818284590452354

public export
exp : Double -> Double
exp x = prim__doubleExp x

public export
log : Double -> Double
log x = prim__doubleLog x

public export
pow : Double -> Double -> Double
pow x y = exp (y * log x) -- prim__doublePow x y

public export
sin : Double -> Double
sin x = prim__doubleSin x

public export
cos : Double -> Double
cos x = prim__doubleCos x

public export
tan : Double -> Double
tan x = prim__doubleTan x

public export
asin : Double -> Double
asin x = prim__doubleASin x

public export
acos : Double -> Double
acos x = prim__doubleACos x

public export
atan : Double -> Double
atan x = prim__doubleATan x

public export
sinh : Double -> Double
sinh x = (exp x - exp (-x)) / 2

public export
cosh : Double -> Double
cosh x = (exp x + exp (-x)) / 2

public export
tanh : Double -> Double
tanh x = sinh x / cosh x

public export
sqrt : Double -> Double
sqrt x = prim__doubleSqrt x

public export
floor : Double -> Double
floor x = prim__doubleFloor x

public export
ceiling : Double -> Double
ceiling x = prim__doubleCeiling x

------------
-- RANGES --
------------

-- These functions are here to support the range syntax:
-- range expressions like `[a..b]` are desugared to `rangeFromXXX` calls.

public export
countFrom : n -> (n -> n) -> Stream n
countFrom start diff = start :: countFrom (diff start) diff

public export
covering
takeUntil : (n -> Bool) -> Stream n -> List n
takeUntil p (x :: xs)
    = if p x
         then [x]
         else x :: takeUntil p xs

public export
covering
takeBefore : (n -> Bool) -> Stream n -> List n
takeBefore p (x :: xs)
    = if p x
         then []
         else x :: takeBefore p xs

public export
interface Range a where
  constructor MkRange
  rangeFromTo : a -> a -> List a
  rangeFromThenTo : a -> a -> a -> List a

  rangeFrom : a -> Stream a
  rangeFromThen : a -> a -> Stream a

-- Idris 1 went to great lengths to prove that these were total. I don't really
-- think it's worth going to those lengths! Let's keep it simple and assert.
public export
Range Nat where
  rangeFromTo x y = case compare x y of
    LT => assert_total $ takeUntil (>= y) (countFrom x S)
    EQ => pure x
    GT => assert_total $ takeUntil (<= y) (countFrom x (\n => minus n 1))
  rangeFromThenTo x y z = case compare x y of
    LT => if z >= x
             then assert_total $ takeBefore (> z) (countFrom x (plus (minus y x)))
             else Nil
    EQ => if x == z then pure x else Nil
    GT => assert_total $ takeBefore (< z) (countFrom x (\n => minus n (minus x y)))
  rangeFrom x = countFrom x S
  rangeFromThen x y
      = if y > x
           then countFrom x (plus (minus y x))
           else countFrom x (\n => minus n (minus x y))

public export
(Integral a, Ord a, Neg a) => Range a where
  rangeFromTo x y = case compare x y of
    LT => assert_total $ takeUntil (>= y) (countFrom x (+1))
    EQ => pure x
    GT => assert_total $ takeUntil (<= y) (countFrom x (\x => x-1))
  rangeFromThenTo x y z = case compare (z - x) (z - y) of
    -- Go down
    LT => assert_total $ takeBefore (< z) (countFrom x (\n => n - (x - y)))
    -- Meaningless
    EQ => if x == y && y == z then pure x else Nil
    -- Go up
    GT => assert_total $ takeBefore (> z) (countFrom x (+ (y-x)))
  rangeFrom x = countFrom x (1+)
  rangeFromThen x y
      = if y > x
           then countFrom x (+ (y - x))
           else countFrom x (\n => n - (x - y))


import Data.Vect

my_length : List a -> Nat
my_length [] = 0
my_length (x :: xs) = 1 + my_length xs

my_reverse : List a -> List a
my_reverse [] = []
my_reverse (x :: xs) = reverse xs ++ [x]

my_map : (a -> b) -> List a -> List b
my_map f [] = []
my_map f (x :: xs) = f x :: map f xs

my_vect_map : (a -> b) -> Vect k a -> Vect k b
my_vect_map f [] = []
my_vect_map f (x :: xs) = f x :: map f xs

createEmpties : Vect n (Vect 0 elem)
createEmpties = replicate _ []

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xsTrans = transposeMat xs in
                         zipWith (\x, y => x :: y) x xsTrans

addMatrix : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix [] [] = []
addMatrix (x :: xs) (y :: ys) = zipWith (\x, y => x + y) x y :: addMatrix xs ys

multMatrix : Num a => Vect n (Vect m a) ->
                      Vect m (Vect p a) ->
                      Vect n (Vect p a)
multMatrix xs ys = multHelper xs (transposeMat ys)
  where
        dot : Num a => Vect k a -> Vect k a -> a
        dot xs ys = sum $ map (\ (s1, s2) => s1 * s2) (zip xs ys)

        multHelper : Num a => Vect n (Vect m a) ->
                              Vect p (Vect m a) ->
                              Vect n (Vect p a)
        multHelper [] _ = []
        multHelper (x :: xs) ys = map (dot x) ys :: multHelper xs ys


> module Isomorphism.Properties

> import Control.Isomorphism

> -- import Isomorphism.Operations
> import Fun.Properties
> import Basic.Operations

> %default total
> %access public export

> |||
> isoEq : {A, B : Type} -> A = B -> Iso A B
> isoEq Refl = isoRefl
> %freeze isoEq

> |||
> isoCong : {A : Type} -> {x : A} -> {y : A} -> {P : A -> Type} -> x = y -> Iso (P x) (P y)
> isoCong {x} {P} prf = replace {P = \ z => Iso (P x) (P z)} prf isoRefl
> %freeze isoCong

Injectivity of to and from

> injectiveFrom : {A, B : Type} -> (iso : Iso A B) -> Injective1 (from iso)
> injectiveFrom {A} {B} (MkIso to from toFrom fromTo) b1 b2 p = s3 where
>   s1 : from b1 = from b2
>   s1 = p
>   s2 : to (from b1) = to (from b2)
>   s2 = cong s1
>   s3 : b1 = b2
>   s3 = replace2 {a = B} {a1 = to (from b1)} {a2 = b1}
>                 {b = B} {b1 = to (from b2)} {b2 = b2}
>                 {P = \ a => \b => a = b}
>                 (toFrom b1) (toFrom b2) s2
> %freeze injectiveFrom

> {-

> ---}


import Data.Vect
import Data.Vect.Elem
import Decidable.Equality

removeElem_v1 : DecEq a => (value : a) -> (xs : Vect (S n) a) -> Vect n a
removeElem_v1 value (x :: xs) = case decEq value x of
                                     Yes prf => xs
                                     No contra => ?removeElem_v1_rhs -- x :: removeElem_v1 value xs

Uninhabited (2 + 2 = 5) where
    uninhabited Refl impossible

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

removeElem_auto : (value : a) -> (xs : Vect (S n) a) ->
                  {auto prf : Elem value xs} -> Vect n a
removeElem_auto value xs {prf} = removeElem value xs prf
-}

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

my_elem : Eq a => (value : a) -> (xs : Vect n a) -> Bool
my_elem value [] = False
my_elem value (x :: xs) = case value == x of
                               False => my_elem value xs
                               True => True

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

not_in_tail : (contra1 : Elem value xs -> Void) -> (contra : (value = x) -> Void) -> Elem value (x :: xs) -> Void
not_in_tail contra1 contra Here = contra Refl
not_in_tail contra1 contra (There later) = contra1 later

my_decElem : DecEq a => (value : a) -> (xs : Vect n a) -> Dec (Elem value xs)
my_decElem value [] = No not_in_nil
my_decElem value (x :: xs)
      = case decEq value x of
            (Yes Refl) => Yes Here
            (No contra) => case my_decElem value xs of
                                (Yes prf) => Yes (There prf)
                                (No contra1) => No (not_in_tail contra1 contra)


module Lists

%elim data NatPair = MkPair Nat Nat

natFst : NatPair -> Nat
natFst (MkPair a b) = a

natSnd : NatPair -> Nat
natSnd (MkPair a b) = b

pairIsSurjective : (a:Nat) -> (b:Nat) -> (MkPair a b) = (MkPair (natFst (MkPair a b)) (natSnd (MkPair a b)))
pairIsSurjective = ?pairIsSurjectiveCase

pairIsSurjective2 : (p:NatPair) -> p = MkPair (natFst p) (natSnd p)
pairIsSurjective2 = ?pairSurCase

Lists.pairSurCase = proof
  intro
  induction p
  intros
  compute
  trivial

mkNatPair : NatPair -> (Nat,Nat)
mkNatPair (MkPair a b) = (a,b)

surjectivePairingStuck : (a:NatPair) -> a = (MkPair (natFst a) (natSnd a))
surjectivePairingStuck = ?surjectivePairingStuckCase

Lists.surjectivePairingStuckCase = proof
  intros
  induction a
  compute
  intros
  trivial

%elim data NatList =
  Nil
  | Cons Nat NatList

repeat : (n:Nat) -> (count:Nat) -> NatList
repeat n Z = Nil
repeat n (S k) = Cons n (repeat n k)

length : (n:NatList) -> Nat
length Nil = Z
length (Cons x xs) = S (length xs)

app : (a:NatList) -> (b:NatList) -> NatList
app Nil b = b
app (Cons x xs) b = Cons x (app xs b)

syntax [x] "::" [xs] = Cons x xs
syntax "[ ]" = Nil
syntax "[" [x] "]" = (Cons x Nil)
syntax "[" [x] "," rem "," [y] "]" = (Cons x (app rem (Cons y Nil)))
syntax [a] "++" [b] = app a b

head : (default:Nat) -> NatList -> Nat
head n Nil = n
head n (Cons x xs) = x

tail : NatList -> NatList
tail Nil = Nil
tail (Cons x xs) = xs

filterZeros : NatList -> NatList
filterZeros Nil = Nil
filterZeros (Cons Z xs) = filterZeros xs
filterZeros (Cons n xs) = Cons n (filterZeros xs)

testFilterZeros : filterZeros $ Cons 0 (Cons 1 Nil) = (Cons 1 Nil)
testFilterZeros  = refl

oddMembers : NatList -> NatList
oddMembers Nil = Nil
oddMembers (Cons Z xs) = oddMembers xs
oddMembers (Cons x xs) = if (mod x 2) == 1
                            then Cons x (oddMembers xs)
                            else oddMembers xs

testOddMembers : oddMembers $ Cons Z (Cons 1 (Cons 2 Nil)) = (Cons 1 Nil)
testOddMembers = refl

countOddMembers : NatList -> Nat
countOddMembers xs = Lists.length $ oddMembers xs

testCountOddMembers : countOddMembers (Cons Z (Cons 1 (Cons 2 Nil))) = (S Z)
testCountOddMembers = refl

appNilEnd : (xs:NatList) -> app xs Lists.Nil = xs
appNilEnd xs = ?appNilProof

Lists.appNilProof = proof
  intro
  induction xs
  trivial
  intros
  compute
  rewrite ihn__1
  trivial

rCons : (xs:NatList) -> (i:Nat) -> NatList
rCons Nil i = Cons i Lists.Nil
rCons (Cons x xs) i = Cons x (rCons xs i)

rev : NatList -> NatList
rev Nil = Nil
rev (Cons x xs) = rCons xs x

lengthRCons : (n:Nat) -> (xs:NatList) -> length (rCons xs n) = S (length xs)
lengthRCons n xs = ?lengthRConsProof

Lists.lengthRConsProof = proof
  intros
  induction xs
  trivial
  intros
  compute
  rewrite ihn__1
  trivial

revLengthRefl : (xs:NatList) -> length (rev xs) = length xs
revLengthRefl = ?revLengthReflProof

Lists.revLengthReflProof = proof
  intros
  induction xs
  trivial
  intros
  compute
  rewrite (lengthRCons n__0 n__1)
  trivial

revRCons : (xs:NatList) -> (n:Nat) -> rev (rCons xs n) = Cons n (rev xs)
revRCons Lists.Nil n = ?revRConsBaseProof
revRCons xs n = ?revRConsSuccProof

Lists.revRConsBaseProof = proof
  intros
  trivial

revInvolutive : rev $ rev xs = xs
revInvolutive = ?revInvolutiveProof


module OfficialCrashCourse.DepTypes

import Data.Vect

-- isSingle : Type
isSingleton : Bool -> Type
isSingleton True = Nat
isSingleton False = List Nat

mkSingle : (x : Bool) -> isSingleton x
mkSingle True = 0
mkSingle False = []

-- Vect is like a List having length Nat elements
data Vector : Nat -> Type -> Type where
    NilVec  : Vector Z a
    (::) : a -> Vector k a -> Vector (S k) a

-- Defining a set of Nat many elems like above
data FinSet : Nat -> Type where
    FZ : FinSet (S k) -- zeroth element
    FS : FinSet k -> FinSet (S k) -- k + 1 th element from k th element

-- using implicit arguments and proofs
appVec: Ord a => Vector n a -> Vector m a -> Vector (n + m) a
appVec NilVec vecm = vecm -- 0 + left  = left
appVec {n} vecn NilVec = rewrite plusZeroRightNeutral n in vecn -- left + 0 = left
appVec {n=(S n)} {m=(S m)} ( x :: xs) (y :: ys) =
    rewrite sym $ plusSuccRightSucc n m in -- using sym to flip args, S (left + right) = left + S right
    x :: y :: (appVec xs ys)

-- what is the i th element in a n sized Vector with i <= n?
indexer : Fin n -> Vect n a -> a
indexer FZ (x :: _) = x
indexer (FS i) (_ :: xs) = indexer i xs

isEmpty : {n: Nat} -> Vect n a -> Bool
isEmpty {n = Z} _ = True
isEmpty _ = False


module Universality

import public Category
import public Isomorphism

%default total

public export
IsUnique : {cat : Category} -> {a, b : Object cat} ->
  (property : Morphism cat a b -> Type) -> (f : Morphism cat a b) -> Type
IsUnique {cat} {a} {b} property f =
    (property f, (g : Morphism cat a b) -> property g -> g = f)

public export
IsOnlyMorphism : {cat : Category} -> {a, b : Object cat} ->
    Morphism cat a b -> Type
IsOnlyMorphism f = IsUnique (\_ => ()) f

public export
OnlyMorphismIsUnique : {cat : Category} -> {a, b : Object cat} ->
    {f : Morphism cat a b} -> IsOnlyMorphism {cat} {a} {b} f ->
    (g, h : Morphism cat a b) -> g = h
OnlyMorphismIsUnique (_, onlyAB) g h = rewrite (onlyAB h ()) in (onlyAB g ())

public export
IsTerminal : {cat : Category} -> (a : Object cat) -> Type
IsTerminal {cat} a = (b : Object cat) -> DPair (Morphism cat b a) IsOnlyMorphism

public export
IdOnlyTerminalEndomorphism : {cat : Category} -> {a : Object cat} ->
  (aIsTerminal : IsTerminal {cat} a) -> (f : Morphism cat a a) ->
  f = Identity cat a
IdOnlyTerminalEndomorphism {cat} {a} aIsTerminal f =
  OnlyMorphismIsUnique (snd (aIsTerminal a)) f (Identity cat a)

public export
IsInitial : {cat : Category} -> (a : Object cat) -> Type
IsInitial {cat} a = (b : Object cat) -> DPair (Morphism cat a b) IsOnlyMorphism

public export
IdOnlyInitialEndomorphism : {cat : Category} -> {a : Object cat} ->
  (aIsInitial : IsInitial {cat} a) -> (f : Morphism cat a a) ->
  f = Identity cat a
IdOnlyInitialEndomorphism {cat} {a} aIsInitial f =
  OnlyMorphismIsUnique (snd (aIsInitial a)) f (Identity cat a)

public export
IsUniqueMorphismWithProperty : {cat : Category} -> {a, b : Object cat} ->
  (property : Morphism cat a b -> Type) -> (m : Morphism cat a b) -> Type
IsUniqueMorphismWithProperty property m =
  (property m, (m' : Morphism cat a b) -> property m' -> m' = m)

public export
AreUniquelyIsomorphic : {cat : Category} -> (a, b : Object cat) -> Type
AreUniquelyIsomorphic {cat} a b =
  (iso : Isomorphic a b **
   IsUniqueMorphismWithProperty IsIsomorphism (fst iso))

public export
IsUniqueUpToUniqueIsomorphism : {cat : Category} ->
  (property : Object cat -> Type) -> Object cat -> Type
IsUniqueUpToUniqueIsomorphism {cat} property a =
  (property a,
   (b : Object cat) -> property b -> AreUniquelyIsomorphic a b)


import InfList
import Data.Primitives.Views
import Data.Nat.Views

-- exercise #1
every_other : Stream a -> Stream a
every_other (first :: second :: tail) = second :: every_other tail

-- Exercise #2
Functor InfList where
  map func (value :: tail) = (func value) :: (map func tail)

infListFunctorTest: List Integer
infListFunctorTest = getPrefix 10 (map (*2) (countFrom 1))

-- Exercise #3
data Face = Heads | Tails

getFace : Int -> Face
getFace number with (divides number 2)
  getFace ((2 * div) + rem) | (DivBy prf) = if rem <= 0 then Heads else Tails

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

coinFlips : Nat -> Stream Int -> List Face
coinFlips count stream = map getFace (take count stream)

flipsTest : List Face
flipsTest = coinFlips 6 (randoms 12345)

-- Exercise #4
calcNext: (number: Double) -> (approx: Double) -> Double
calcNext number approx = (approx + (number / approx)) / 2

square_root_approx : (number: Double) -> (approx: Double) -> Stream Double
square_root_approx number approx = approx :: square_root_approx number (calcNext number approx)

sqrtTest1 : List Double
sqrtTest1 = take 3 $ square_root_approx 10 10

sqrtTest2 : List Double
sqrtTest2 = take 10 $ square_root_approx 100 25

-- Exercise #5
square_root_bound : (max: Nat) -> (number: Double) -> (bound : Double) -> (approxs: Stream Double) -> Double
square_root_bound  Z    number bound (value :: xs) = value
square_root_bound (S k) number bound (apprx :: xs) =
  if isBoundReached
  then apprx
  else square_root_bound k number bound xs
  where
    isBoundReached : Bool
    isBoundReached = (apprx * apprx - number) < bound

square_root : Double -> Double
square_root value = square_root_bound 100 value 0.00000000001 (square_root_approx value value)

boundedSqrtTest1: Double
boundedSqrtTest1 = square_root 6

boundedSqrtTest2: Double
boundedSqrtTest2 = square_root 2500

boundedSqrtTest3: Double
boundedSqrtTest3 = square_root 2501


module Solutions.Dependent

%default total

--------------------------------------------------------------------------------
--          Length-Indexed Lists
--------------------------------------------------------------------------------

data Vect : (len : Nat) -> Type -> Type where
  Nil  : Vect 0 a
  (::) : a -> Vect n a -> Vect (S n) a

-- 1
head : Vect (S n) a -> a
head (x :: _) = x
head Nil impossible

-- 2
tail : Vect (S n) a -> Vect n a
tail (_ :: xs) = xs
tail Nil impossible

-- 3
zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d
zipWith3 f []        []        []        = []
zipWith3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: zipWith3 f xs ys zs

-- 4
-- Since we only have a `Semigroup` constraint, we can't conjure
-- a value of type `a` out of nothing in case of an empty list.
-- We therefore have to return a `Nothing` in case of an empty list.
foldSemi : Semigroup a => List a -> Maybe a
foldSemi []        = Nothing
foldSemi (x :: xs) = Just . maybe x (x <+>) $ foldSemi xs

-- 5
-- the `Nil` case is impossible here, so unlike in Exercise 4,
-- we don't need to wrap the result in a `Maybe`.
-- However, we need to pattern match on the tail of the Vect to
-- decide whether to invoke `foldSemiVect` recursively ore not
foldSemiVect : Semigroup a => Vect (S n) a -> a
foldSemiVect (x :: [])         = x
foldSemiVect (x :: t@(_ :: _)) = x <+> foldSemiVect t

-- 6
iterate : (n : Nat) -> (a -> a) -> a -> Vect n a
iterate 0     _ _ = Nil
iterate (S k) f v = v :: iterate k f (f v)

-- 7
generate : (n : Nat) -> (s -> (s,a)) -> s -> Vect n a
generate 0     _ _ = Nil
generate (S k) f v =
  let (v', va) = f v
   in va :: generate k f v'

-- 8
fromList : (as : List a) -> Vect (length as) a
fromList []        = []
fromList (x :: xs) = x :: fromList xs

-- 9
-- Lookup the type and implementation of functions `maybe` `const` and
-- try figuring out, what's going on here. An alternative implementation
-- would of course just pattern match on the argument.
maybeSize : Maybe a -> Nat
maybeSize = maybe 0 (const 1)

fromMaybe : (m : Maybe a) -> Vect (maybeSize m) a
fromMaybe Nothing  = []
fromMaybe (Just x) = [x]

--------------------------------------------------------------------------------
--          Fin: Safe Indexing into Vectors
--------------------------------------------------------------------------------

data Fin : (n : Nat) -> Type where
  FZ : {0 n : Nat} -> Fin (S n)
  FS : (k : Fin n) -> Fin (S n)

(++) : Vect m a -> Vect n a -> Vect (m + n) a
(++) []        ys = ys
(++) (x :: xs) ys = x :: (xs ++ ys)

replicate : (n : Nat) -> a -> Vect n a
replicate 0     _ = []
replicate (S k) x = x :: replicate k x

zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c
zipWith _ []        []        = []
zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

-- 1
update : (a -> a) -> Fin n -> Vect n a -> Vect n a
update f FZ     (x :: xs) = f x :: xs
update f (FS k) (x :: xs) = x :: update f k xs

-- 2
insert : a -> Fin (S n) -> Vect n a -> Vect (S n) a
insert v FZ     xs         = v :: xs
insert v (FS k) (x :: xs)  = x :: insert v k xs
insert v (FS k) []  impossible

-- 3
-- The trick here is to pattern match on the tail of the
-- vector in the `FS k` case and realize that an empty
-- tail is impossible. Otherwise we won't be able to
-- convince the type checker, that the vector's tail is
-- non-empty in the recursive case.
delete : Fin (S n) -> Vect (S n) a -> Vect n a
delete FZ     (_ :: xs)          = xs
delete (FS k) (x :: xs@(_ :: _)) = x :: delete k xs
delete (FS k) (x :: []) impossible

-- 4
safeIndexList : (xs : List a) -> Fin (length xs) -> a
safeIndexList (x :: _)  FZ     = x
safeIndexList (x :: xs) (FS k) = safeIndexList xs k
safeIndexList Nil _ impossible

-- 5
finToNat : Fin n -> Nat
finToNat FZ     = Z
finToNat (FS k) = S $ finToNat k

take : (k : Fin (S n)) -> Vect n a -> Vect (finToNat k) a
take FZ     x         = []
take (FS k) (x :: xs) = x :: take k xs

-- 6
minus : (n : Nat) -> Fin (S n) -> Nat
minus n FZ         = n
minus (S j) (FS k) = minus j k
minus 0 (FS k) impossible

-- 7
drop : (k : Fin (S n)) -> Vect n a -> Vect (minus n k) a
drop FZ     xs        = xs
drop (FS k) (_ :: xs) = drop k xs

-- 8
splitAt :  (k : Fin (S n))
        -> Vect n a
        -> (Vect (finToNat k) a, Vect (minus n k) a)
splitAt k xs = (take k xs, drop k xs)

--------------------------------------------------------------------------------
--          Compile-Time Computations
--------------------------------------------------------------------------------

-- 1
flattenList : List (List a) -> List a
flattenList []          = []
flattenList (xs :: xss) = xs ++ flattenList xss

flattenVect : Vect m (Vect n a) -> Vect (m * n) a
flattenVect []          = []
flattenVect (xs :: xss) = xs ++ flattenVect xss

-- 2
take' : (m : Nat) -> Vect (m + n) a -> Vect m a
take' 0     _         = []
take' (S k) (x :: xs) = x :: take' k xs
take' (S k) Nil impossible

drop' : (m : Nat) -> Vect (m + n) a -> Vect n a
drop' 0     xs        = xs
drop' (S k) (x :: xs) = drop' k xs
drop' (S k) Nil impossible

splitAt' : (m : Nat) -> Vect (m + n) a -> (Vect m a, Vect n a)
splitAt' m xs = (take' m xs, drop' m xs)

-- 3
-- Since we must call `replicate` in the `Nil` case, `k`
-- must be a non-erased argument. I used an implicit argument here,
-- since this reflects the type of the mathematical function
-- more closely.
--
-- Empty matrices probably don't make too much sense,
-- so we could also request at the type-level that `k` and `m`
-- are non-zero, in which case both values could be derived
-- by pattern matching on the vectors.
transpose : {k : _} -> Vect m (Vect k a) -> Vect k (Vect m a)
transpose []          = replicate k []
transpose (xs :: xss) = zipWith (::) xs (transpose xss)


module ExVectDecEq

import Decidable.Equality

%default total

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

{-
  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
-}

headUnequal : DecEq a => { xs: Vect n a } -> { ys : Vect n a } ->
                       (contra : (x = y) -> Void) -> ((x :: xs) = (y :: ys)) -> Void
headUnequal contra Refl = contra Refl

tailUnequal : DecEq a => { xs : Vect n a } -> { ys : Vect n a } ->
                         (contra : (xs = ys) -> Void) -> ((x :: xs) = (y:: ys)) -> Void
tailUnequal contra Refl = contra Refl

DecEq a => DecEq (Vect n a) where
  decEq [] [] = Yes Refl
  decEq [] _ = No ?nilNotEqualToCons
  decEq _ [] = No ?consNotEqualToNil
  decEq (x :: xs) (y :: ys) = case decEq x y of
                                   No contra => No (headUnequal contra)
                                   Yes Refl => case decEq xs ys of
                                                    No contra => No (tailUnequal contra)
                                                    Yes Refl => Yes Refl


module Basen

import Data.Fin

--Defines a data type Base that behaves like a list
data Base: (n: Nat) -> Type where
  Ones: (n: Nat) -> (Fin n) -> Base n
  Next: (n: Nat) -> (Fin n) -> (Base n) -> (Base n)

--Auxiliary function that reverses a Base (S n) onto anpther given Base (S n)
Revonto: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
Revonto n accum (Ones (S n) x) = Next (S n) x accum
Revonto n accum (Next (S n) x y) = Revonto n (Next (S n) x accum) y

--Reverses a Base (S n)
Rev: (n: Nat) -> (Base (S n)) -> (Base (S n))
Rev n (Ones (S n) x) = Ones (S n) x
Rev n (Next (S n) x y) = Revonto n (Ones (S n) x) y

concat: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
concat n (Ones (S n) x) y = Next (S n) x y
concat n (Next (S n) x z) y = Next (S n) x (concat n z y)

--Fin to Nat
tonatFin: (n: Nat) -> Fin(n) -> Nat
tonatFin (S k) FZ = Z
tonatFin (S k) (FS x) = S (tonatFin k x)

--List Fin to Nat
tonat: (n: Nat) -> Base (S n) -> Nat
tonat n (Ones (S n) FZ) = Z
tonat Z (Ones (S Z) (FS x)) impossible
tonat (S k) (Ones (S (S k)) (FS x)) = S(tonat k (Ones (S k) x))
tonat n (Next (S n) x y) = (tonat n (Ones (S n) x)) + (tonat n y)

--Euclid's div
Eucl: (a: Nat) -> (b: Nat) -> (Nat, Nat)
Eucl Z b = (0,0)
Eucl a Z = (0, a)
Eucl (S k) b = case (lte (S (S k)) b) of
                    False => (S(fst(Eucl (minus (S k) b) b)), snd(Eucl (minus (S k) b) b))
                    True => (0, S k)

--Nat to Fin (modular values)
tofinNat: (a: Nat) -> (n: Nat) -> Fin n
tofinNat Z (S j) = FZ
tofinNat (S k) (S j) = case lte (S k) (S j) of
                True => FS (tofinNat k j)
                False =>  (tofinNat (snd(Eucl (S k) (S j))) (S j))

strp: (Base (S n)) -> (Base (S n))
strp (Ones (S n) x) = (Ones (S n) x)
strp (Next (S n) x y) = case x of
                  FZ => strp(y)
                  FS z => Next (S n) x y

-- Nat to List Fin n (base n representation)
tofin: Nat -> (n: Nat) -> Base (S n)
tofin Z n = Ones (S n) FZ
tofin (S k) n = strp(concat n (tofin q n) (Ones (S n) rem)) where
                    rem: Fin (S n)
                    rem = tofinNat (snd(Eucl (S k) (S n))) (S n)
                    q: Nat
                    q = fst(Eucl (S k) (S n))

--embedding Fin n in Fin S n vertically
embn: (n: Nat) -> Fin n -> Fin (S n)
embn (S k) FZ = FZ
embn (S k) (FS x) = FS (embn k x)

--Generates n in (Fin (S n))
Genn: (n: Nat) -> (Fin (S n))
Genn Z = FZ
Genn (S k) = FS (Genn k)

--Checks if a given element of Fin (S n) is in fact n
Isn: (n: Nat) -> (p: Fin (S n)) -> Bool
Isn Z x = True
Isn (S k) FZ = False
Isn (S k) (FS x) = Isn k x

--Proves that the definitional equality for Isn holds
IsnisIsn: (n: Nat) -> (p: Fin (S n)) -> (Isn (S n) (FS p)) = (Isn n p)
IsnisIsn n p = Refl

--Proves that if a given (FS x) is not n in (Fin (S n)), then x is not n-1 in (Fin n)
IsNotnPf:  (n: Nat) -> (p: Fin (S n)) ->  ((Isn (S n) (FS p)) = False) -> ((Isn n p) = False)
IsNotnPf Z _ Refl impossible
IsNotnPf (S k) FZ prf = Refl
IsNotnPf (S k) (FS x) prf = trans (sym (IsnisIsn (S k) (FS x))) prf

--Gives a back embedding whenever the value is not Genn
Predec: (n: Nat) -> (p: Fin (S n)) -> ((Isn n p) = False) -> (Fin n)
Predec Z _ Refl impossible
Predec (S k) FZ Refl = FZ
Predec (S k) (FS x) prf = FS (Predec k x (IsNotnPf (S k) (FS x) prf))

--Decidable type for Isn
DecIsn: (n: Nat) -> (p: (Fin (S n))) -> Either (Isn n p = True) (Isn n p = False)
DecIsn Z p = Left Refl
DecIsn (S k) FZ = Right Refl
DecIsn (S k) (FS x) = case (DecIsn k x) of
                        Left l => Left (trans (IsnisIsn k x) l)
                        Right r => Right (trans (IsnisIsn k x) r)

--adding two Fin n's
addfin: (n: Nat) -> Fin (S n) -> Fin (S n) -> (Fin (S n), Fin (S n))
addfin Z x y = (FZ,  FZ)
addfin (S k) FZ y = (FZ, y)
addfin (S k) (FS x) y = let
                    a = Genn (S k)
                    b = the (Fin (S (S k))) FZ
                    c = the (Fin (S k)) FZ
                    w = fst(addfin (S k) (embn (S k) x) y)
                    z = snd(addfin (S k) (embn (S k) x) y)
                    in
                    case (DecIsn (S k) z) of
                             Left l => (FS c, b)
                             Right r => (w, FS(Predec (S k) z r))

--adding two reversed lists as specified
addfinl: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinl n (Ones (S n) x) (Ones (S n) y) = case (addfin n x y) of
                              (FZ, a) => Ones (S n) a
                              (FS c, a) => Next (S n) a (Ones (S n) (FS c))
addfinl n (Ones (S n) x) (Next (S n) y z) = Next (S n) (snd (addfin n x y)) (addfinl n (Ones (S n) (fst (addfin n x y))) z)
addfinl n (Next (S n) x z) (Ones (S n) y) = Next (S n) (snd (addfin n x y)) (addfinl n (Ones (S n) (fst (addfin n x y))) z)
addfinl n (Next (S n) x z) (Next (S n) y w) = Next (S n) (snd (addfin n x y)) (addfinl n (Ones (S n) (fst (addfin n x y))) (addfinl n z w))

--adding two lists
addfinlist: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
addfinlist n xs ys = (Rev n (addfinl n (Rev n xs) (Rev n ys)))

--multiply two reversed lists in Fin S n
mulfinl: (n: Nat) -> Base (S n) -> Base (S n) -> Base (S n)
mulfinl n (Ones (S n) FZ) y = Ones (S n) FZ
mulfinl n (Ones (S n) (FS x)) y = addfinl n y (mulfinl n (Ones (S n) (embn n x)) y)
mulfinl n (Next (S n) FZ z) y = Next (S n) FZ (mulfinl n z y)
mulfinl n (Next (S n) (FS x) z) y = addfinl n y (mulfinl n (Next (S n) (embn n x) z) y)

--multiply two lists
mulfinList: (n: Nat) -> (Base (S n)) -> (Base (S n)) -> (Base (S n))
mulfinList n xs ys = Rev n (mulfinl n (Rev n xs) (Rev n ys))

--Custom "functions are functors" function
ap: (x: Type) -> (y: Type) -> (f: x->y) -> (n = m) -> (f n = f m)
ap x y f Refl = Refl


-- ------------------------------------------------------------- [ Metrics.idr ]
-- Module    : Metrics.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Readability Metrics
|||
||| http://www.editcentral.com/gwt1/EditCentral.html
module Readability.Metrics

%access export

public export
data RMetricTy = FLESCH | ARI | KINCAID | COLEMAN | FOG | SMOG

||| Flesch reading ease score
|||
||| ```java
||| 206.835 - (1.015 * wordCount) / sentenceCount - (84.6 * syllableCount) / wordCount;
||| ```
||| @wcount Number of words
||| @scount Number of sentences.
||| @sycount Number of syllables.
flesch : (wcount : Double) -> (scount : Double) -> (sycount : Double) -> Double
flesch ws ss sys = 206.835 - (1.015 * ws) / ss - (84.6 * sys) / ws

||| Automated readability index
|||
||| ```java
||| (4.71 * letterNumberCount) / wordCount + (0.5 * wordCount) / sentenceCount -21.43;
||| ```
||| @ccount Number of Characters
||| @wcount Number of words.
||| @scount Number of sentences.
ari : (ccount : Double) -> (wcount : Double) -> (scount : Double) -> Double
ari as ws ss = (4.71 * as) / ws + (0.5 * ws) / ss - 21.43

||| Flesch-Kincaid grade level
|||
||| ```java
||| (0.39 * wordCount) / sentenceCount + (11.8 * syllableCount) / wordCount - 15.59;
||| ```
||| @wcount The number of words
||| @scount Number of sentences
||| @sycount Number of syllables.
kincaid : (wcount : Double) -> (scount : Double) -> (sycount : Double) -> Double
kincaid ws ss sys = (0.39 * ws) / ss + (11.8 * sys) / ws - 15.59

||| Coleman-Liau index
|||
||| ```java
||| (5.89 * letterNumberCount) / wordCount - (30.0 * sentenceCount) / wordCount - 15.8;
||| ```
||| @ccount Number of letters and digits.
||| @wcount The number of words.
||| @scount The number of sentences.
coleman : (ccount : Double) -> (wcount : Double) -> (scount : Double) -> Double
coleman as ws ss = (5.89 * as) / ws - (30.0 * ss) / ws - 15.8

||| Gunning fog index
|||
||| ```java
|||  0.4 * ( (double)wordCount / sentenceCount + (100.0 * complexCount) / wordCount );
||| ```
||| @wcount Number of Words
||| @scount Number of sentences
||| @bwcount Number of words with three plus syllables.
fog : (wcount : Double) -> (scount : Double) -> (bwcount : Double) -> Double
fog ws ss bs = 0.4 * ( ws / ss + (100.0 * bs) / ws)

||| SMOG index
|||
||| ```java
||| Math.sqrt( complexCount * 30.0 / sentenceCount ) + 3.0;
||| ```
||| @bwcount The number of word with three plus syllables.
||| @scount The number of sentences.
smog : (bwcount : Double) -> (scount : Double) -> Double
smog bs ss = 3.0 + sqrt (bs * (30 / ss))

Show RMetricTy where
  show FLESCH  = "FLESCH"
  show ARI     = "ARI"
  show KINCAID = "KINCAID"
  show COLEMAN = "COLEMAN"
  show FOG     = "FOG"
  show SMOG    = "SMOG"

Eq RMetricTy where
  (==) FLESCH  FLESCH  = True
  (==) ARI     ARI     = True
  (==) KINCAID KINCAID = True
  (==) COLEMAN COLEMAN = True
  (==) FOG     FOG     = True
  (==) SMOG    SMOG    = True
  (==) _        _      = False

readRMetricTy : String -> Maybe RMetricTy
readRMetricTy s =
  case toLower s of
    "flesch"  => Just FLESCH
    "ari"     => Just ARI
    "kincaid" => Just KINCAID
    "coleman" => Just COLEMAN
    "fog"     => Just FOG
    "smog"    => Just SMOG
    otherwise  => Nothing

public export
record ReadResult where
  constructor MkReadResult
  flesch  : Double
  ari     : Double
  kincaid : Double
  coleman : Double
  fog     : Double
  smog    : Double

toList : ReadResult -> List (RMetricTy, Double)
toList (MkReadResult a b c d e f) =
    [ (FLESCH,  a)
    , (ARI,     b)
    , (KINCAID, c)
    , (COLEMAN, d)
    , (FOG,     e)
    , (SMOG,    f)]

Show ReadResult where
  show rslt = show (Metrics.toList rslt)
-- --------------------------------------------------------------------- [ EOF ]


module TakeN

data TakeN : List a -> Type where
     Fewer : TakeN xs
     Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

-- Ex. 10.1 # 1
total
takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
                             Fewer => Fewer
                             (Exact n_xs) => Exact $ x :: n_xs

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

-- Ex. 10.1 # 2
halves : List a -> (List a, List a)
halves xs = splitHalf (div (length xs) 2) xs
  where
  splitHalf : Nat -> List a -> (List a, List a)
  splitHalf n xs with (takeN n xs)
    splitHalf n xs | Fewer = ([], xs)
    splitHalf n (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)


> module So.Properties

> import Data.So

> import Decidable.Predicates
> import Unique.Predicates

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

* Introduction and elimination rules

> |||
> soIntro : (b : Bool) -> b = True -> So b
> soIntro True  Refl   = Oh
> soIntro False contra = void (trueNotFalse (sym contra))

> |||
> soElim : (b : Bool) -> So b -> b = True
> soElim True  Oh = Refl
> soElim False Oh impossible

** Or

> |||
> soOrIntro1 : (b1 : Bool) -> (b2 : Bool) -> So b1 -> So (b1 || b2)
> soOrIntro1 True _  Oh = Oh

> |||
> soOrIntro2 : (b1 : Bool) -> (b2 : Bool) -> So b2 -> So (b1 || b2)
> soOrIntro2 True  True Oh = Oh
> soOrIntro2 False True Oh = Oh

> |||
> soOrElim : (b1 : Bool) -> (b2 : Bool) -> So (b1 || b2) -> Either (So b1) (So b2)
> soOrElim True  True  Oh = Left Oh
> soOrElim True  False Oh = Left Oh
> soOrElim False True  Oh = Right Oh
> soOrElim False False Oh impossible

> |||
> soOrElim1 : (b1 : Bool) -> (b2 : Bool) -> So (b1 || b2) -> So (not b1) -> So b2
> soOrElim1 True  True  Oh Oh impossible
> soOrElim1 True  False Oh Oh impossible
> soOrElim1 False True  Oh Oh = Oh
> soOrElim1 False False Oh Oh impossible

> |||
> soOrElim2 : (b1 : Bool) -> (b2 : Bool) -> So (b1 || b2) -> So (not b2) -> So b1
> soOrElim2 True  True  Oh Oh impossible
> soOrElim2 True  False Oh Oh = Oh
> soOrElim2 False True  Oh Oh impossible
> soOrElim2 False False Oh Oh impossible

** And

> |||
> soAndElim1 : (b1 : Bool) -> (b2 : Bool) -> So (b1 && b2) -> So b1
> soAndElim1 True  True  Oh = Oh
> soAndElim1 True  False Oh impossible
> soAndElim1 False True  Oh impossible
> soAndElim1 False False Oh impossible

> |||
> soAndElim2 : (b1 : Bool) -> (b2 : Bool) -> So (b1 && b2) -> So b2
> soAndElim2 True  True  Oh = Oh
> soAndElim2 True  False Oh impossible
> soAndElim2 False True  Oh impossible
> soAndElim2 False False Oh impossible

* Counter factuals

> |||
> contra : {b : Bool} -> b = False -> So b -> Void
> contra {b} p q = trueNotFalse (trans (sym (soElim b q)) p)

* Decidability

> ||| Lifted Booleans are decidable
> decSo : (b : Bool) -> Dec (So b)
> decSo True  = Yes Oh
> decSo False = No (\ oh => absurd oh)

> ||| Lifted Boolean functions are decidable
> dec1So : {A : Type} -> (p : A -> Bool) -> Dec1 (\ a => So (p a))
> dec1So p a = decSo (p a)

* Uniqueness

> ||| Lifted Booleans are unique
> uniqueSo : (b : Bool) -> Unique (So b)
> uniqueSo True  Oh Oh = Refl
> uniqueSo False Oh Oh impossible

> ||| Lifted Boolean functions are unique
> unique1So : {A : Type} -> (p : A -> Bool) -> Unique1 (\ a => So (p a))
> unique1So p a = uniqueSo (p a)

> {-

> ---}


module NatTree

import Data.Fin

data NatTree : Type where
  Leaf : Nat -> NatTree
  Node : NatTree -> NatTree -> NatTree

tsum : NatTree -> Nat
tsum (Leaf k) = k
tsum (Node x y) = (tsum x) + (tsum y)

recNT : (x: Type) -> (Nat -> x) -> (NatTree -> x -> NatTree -> x -> x)
  -> (NatTree -> x)
recNT x f g (Leaf k) = f k
recNT x f g (Node y z) = g y yValue z zValue where
  yValue =  recNT x f g y
  zValue = recNT x f g z

tsumTheHardWay : NatTree -> Nat
tsumTheHardWay = recNT Nat leafCase nodeCase where
  leafCase = \k : Nat => k
  nodeCase = \t1 => \n1 => \t2 => \n2 => n1 + n2

flattenTree : NatTree -> List Nat
flattenTree = recNT (List Nat) leafCase nodeCase where
  leafCase = \k => k :: []
  nodeCase = \t1 => \l1 => \t2 => \l2 => (l1 ++ l2)

data FinNatTree : Type where
  FLeaf : Nat -> FinNatTree
  FNode : (n: Nat) -> ((Fin n) -> FinNatTree) -> FinNatTree

data Evil : Type where
  Diag : (Evil -> Bool) -> Evil

evil : Evil -> Bool
evil (Diag f) = not (f (Diag f))

contra : Bool
contra = evil (Diag evil)


module Basics

trivial : Elab ()
trivial = do compute
             g <- snd <$> getGoal
             case g of
                  `((=):Type) => do fill `(Var (UN "Refl"))
                                    solve
                  `(():Type) => do fill `(():())
                                   solve
                  otherGoal  => fail [TermPart otherGoal,
                                      TextPart "is not trivial"
                                     ]

|||
||| Enumerated Types
|||

||| Days of the Week
|||
data Day : Type where
     Monday    : Day
     Tuesday   : Day
     Wednesday : Day
     Thursday  : Day
     Friday    : Day
     Saturday  : Day
     Sunday    : Day

next_weekday : (d : Day) -> Day
next_weekday d = case d of
             Monday    => Tuesday
             Tuesday   => Wednesday
             Wednesday => Thursday
             Thursday  => Friday
             Friday    => Monday
             Saturday  => Monday
             Sunday    => Monday

||| next_weekeday assertions
is_next_weekday1 : (d : Day) -> next_weekday Friday = Monday
is_next_weekday1 d = Refl

is_next_weekday2 : (d : Day) -> next_weekday (next_weekday Saturday) = Tuesday
is_next_weekday2 d = Refl

test_next_weekday : (next_weekday (next_weekday Saturday)) = Tuesday
test_next_weekday = Refl

||| Booleans
|||
data Boolean : Type where
     Top : Boolean
     Bot : Boolean

negb : (b : Boolean) -> Boolean
negb b = case b of
     Top => Bot
     Bot => Top

andb : (b1,b2 : Boolean) -> Boolean
andb b1 b2 = case b1 of
     Top => b2
     Bot => Bot

orb : (b1,b2 : Boolean) -> Boolean
orb b1 b2 = case b1 of
    Top => Top
    Bot => b2

||| orb assertions
test_orb1 : (orb Top Bot) = Top
test_orb1 = Refl

test_orb2 : (orb Bot Bot) = Bot
test_orb2 = Refl

test_orb3 : (orb Bot Top) = Top
test_orb3 = Refl

test_orb4 : (orb Top Top) = Top
test_orb4 = Refl

||| Exercise: 1 star (nandb)
||| Complete the definition of the following function, then make sure that the
|||   assertions below can each be verified by Idris.
|||
||| This function should return true if either or both of its inputs are false.
|||
nandb : (b1,b2 : Boolean) -> Boolean
nandb b1 b2 = (negb (andb b1 b2))

||| nandb assertions
test_nandb1 : (nandb Top Bot) = Top
test_nandb1 = Refl

test_nandb2 : (nandb Bot Bot) = Top
test_nandb2 = Refl

test_nandb3 : (nandb Bot Top) = Top
test_nandb3 = Refl

test_nandb4 : (nandb Top Top) = Bot
test_nandb4 = Refl

||| Exercise: 1 star (andb3)
||| Do the same for the andb3 function below. This function should return true
|||   when all of its inpouts are true, and false otherwise.
|||
andb3 : (b1,b2,b3 : Boolean) -> Boolean
andb3 b1 b2 b3 = (andb b1 (andb b2 b3))

||| andb3 assertions
test_andb31 : (andb3 Top Top Top) = Top
test_andb31 = Refl

test_andb32 : (andb3 Bot Top Top) = Bot
test_andb32 = Refl

test_andb33 : (andb3 Top Bot Top) = Bot
test_andb33 = Refl

test_andb34 : (andb3 Top Top Bot) = Bot
test_andb34 = Refl

|||
||| Function Types
|||

||| Numbers
|||

||| data Nats : Type where
|||      O : Nats
|||      S : Nats -> Nats
pred : (n : Nat) -> Nat
pred n = case n of
     Z   => Z
     S k => k

minusTwo : (n : Nat) -> Nat
minusTwo n = case n of
         Z       => Z
         S Z     => Z
         S (S k) => k

evenb : (n : Nat) -> Boolean
evenb n = case n of
      Z       => Top
      S Z     => Bot
      S (S k) => Top

oddb : (n : Nat) -> Boolean
oddb n = negb (evenb n)

||| oddb assertions
test_oddb1 : (oddb (S Z)) = Top
test_oddb1 = Refl

test_oddb2 : (oddb (S (S (S (S Z))))) = Bot
test_oddb2 = Refl

plus' : (n,m : Nat) -> Nat
plus' n m = case n of
      Z   => m
      S k => S (plus' k m)

mult' : (n,m : Nat) -> Nat
mult' n m = case n of
      Z   => Z
      S k => plus m (mult' k m)

minus' : (n,m : Nat) -> Nat
minus' n m = case (n,m) of
       (Z,   _  ) => Z
       (S _, Z  ) => n
       (S k, S j) => minus k j

exp : (base,power : Nat) -> Nat
exp base power = case power of
    Z   => S Z
    S p => mult' base (exp base p)

||| Exercise: 1 star (factorial)
||| Translate the standard factorial function into Idris.
|||
factorial : (n : Nat) -> Nat
factorial n = case n of
          Z   => S Z
          S Z => S Z
          S k => (mult' n (factorial k))

||| factorial assertions
test_factorial1 : (factorial 3) = 6
test_factorial1 = Refl

test_factorial2 : (factorial 5) = (mult' 10 12)
test_factorial2 = Refl

beq_nat : (n,m : Nat) -> Boolean
beq_nat n m = case n of
        Z => case m of
          Z   => Top
          S j => Bot
        S k => case m of
          Z   => Bot
          S j => beq_nat k j

ble_nat : (n,m : Nat) -> Boolean
ble_nat n m = case n of
        Z   => Top
        S k => case m of
            Z   => Bot
            S j => ble_nat k j

||| ble_nat assertions
test_ble_nat1 : (ble_nat 2 2) = Top
test_ble_nat1 = Refl

test_ble_nat2 : (ble_nat 2 4) = Top
test_ble_nat2 = Refl

test_ble_nat3 : (ble_nat 4 2) = Bot
test_ble_nat3 = Refl

||| Exercise: 2 stars (blt_nat)
||| The blt_nat function test natural numbers for less-than, yielding a boolean.
|||
blt_nat : (n,m : Nat) -> Boolean
blt_nat n m = case (beq_nat n m) of
        Top => Bot
        Bot => (ble_nat n m)

||| blt_nat assertions
test_blt_nat1 : (blt_nat 2 2) = Bot
test_blt_nat1 = Refl

test_blt_nat2 : (blt_nat 2 4) = Top
test_blt_nat2 = Refl

test_blt_nat3 : (blt_nat 4 2) = Bot
test_blt_nat3 = Refl

|||
||| Proof by Simplification
|||

plus_Z_n : {n : Nat} -> 0 + n = n
plus_Z_n = ?plus_Z_n


import Data.Vect

{-
vApp : Vect n (a -> b) -> Vect n a -> Vect n b
vApp []       []         = []
vApp (f :: fs) (a :: as) = f a :: vApp fs as
-}

total
vApp : {a:Type} -> {b:Type} -> {n:Nat} ->  Vect n (a -> b) -> Vect n a -> Vect n b
vApp  []       []         = []
vApp  (f :: fs) (e :: es) = f e :: vApp fs es

--vApp {a} {b} {n=S m} (f :: fs) (e :: es) = f e :: vApp fs es


module Product_Type_Eq

%access public export
%default total

||| A proof that equality for product types are generate by the equalities of the componenets

Product_Eq_property_1 : (ty1, ty2 : Type) -> (a, b : (ty1, ty2)) ->
                        ( (fst a) = (fst b) ) -> ( (snd a) = (snd b) ) ->
                        ( a = b )

Product_Eq_property_1 ty1 ty2 (x, y) (x, y) Refl Refl = Refl


module Unsigned

%access export
%default total

||| An unsigned binary number represented with `n` bits
data Unsigned : (n : Nat) -> Type where
  ||| Built from an underlying integer
  U : Integer -> Unsigned n

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

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

||| Eq instacne for equality of `Unsigned n`
Eq (Unsigned n) where
  (==) (U x) (U y) = x==y

||| Ord instance for ordering of `Unsigned n`
Ord (Unsigned n) where
  compare (U x) (U y) = compare x y

||| MinBound instance for generating extremes of `Unsigned n`
MinBound (Unsigned n) where
  minBound = U 0

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

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

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

||| Minus operations for two `Unsigned`s. Note that we cannot implement the Neg
||| typeclass because there are no negative representations.
minus : Unsigned n -> Unsigned n -> Unsigned n
minus (U x) (U y) = U (x-y)

||| Helper function to prove that 2^n for all natural n is not 0
private
powerTwoIsNotZ : (n : Nat) -> Not (power 2 n = 0)
powerTwoIsNotZ n = believe_me -- TODO prove properly

||| Add operations for two `Unsigned`s with wrapping overflow.
addWrap : Unsigned n -> Unsigned n -> Unsigned n
addWrap (U x) (U y) = let max = power 2 n
                          res = cast x + cast y
                      in U . cast $ modNatNZ res max (powerTwoIsNotZ n)

||| Minus operations for two `Unsigned`s with wrapping overflow.
minusWrap : Unsigned n -> Unsigned n -> Unsigned n
minusWrap (U x) (U y) = let max = power 2 n
                            res = max + cast x `minus` cast y
                        in U . cast $ modNatNZ res max (powerTwoIsNotZ n)

||| Show instance for printing `Unsigned n`
Show (Unsigned n) where
  show (U x) = "U" ++ show n ++ " " ++ show x

-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:


module Group_property2

import congruence
import Monoid
import Group
import Group_property

%access public export

||| Property 8 - If f : g -> h is group homomorphism then f(inv(a)) = inv(f(a))
total
Group_property_8 : (dom : Type) -> ((*) : dom -> dom -> dom) -> (pfdom : IsGroup dom (*)) ->
                    (cod : Type) -> ((+) : cod -> cod -> cod) -> (pfcod : IsGroup cod (+)) ->
                    (f : dom -> cod) -> (pfhom : (Hom dom (*) pfdom cod (+) pfcod f)) ->
                    (a : dom) -> ( (f (Inv dom (*) pfdom a)) = (Inv cod (+) pfcod (f a)) )

Group_property_8 dom (*) pfdom cod (+) pfcod f pfhom a = let
                                                         pfid1_dom = (fst (snd pfdom))
                                                         e_dom1 = (fst pfid1_dom) -- identity in the IdentityExists
                                                         e_dom1_pf = (snd pfid1_dom) -- proof that e_dom1 is the identity

                                                         pfid2_dom = (fst (snd (snd pfdom)))
                                                         e_dom2 = (fst pfid2_dom) -- identity in the InverseExists
                                                         e_dom2_pf = (snd pfid2_dom) -- prood that it is the identity

                                                         pf_eq_dom_id12 = (Group_property_1 dom (*) pfdom e_dom1 e_dom2
                                                                            e_dom1_pf e_dom2_pf) -- proof that e_dom1 and e_dom2 are equal

                                                         pfid1_cod = (fst (snd pfcod))
                                                         e_cod1 = (fst pfid1_cod) -- identity in the IdentityExists
                                                         e_cod1_pf = (snd pfid1_cod) -- proof that e_cod1 is the identity

                                                         pfid2_cod = (fst (snd (snd pfcod)))
                                                         e_cod2 = (fst pfid2_cod) -- identity in the InverseExists
                                                         e_cod2_pf = (snd pfid2_cod) -- prood that it is the identity

                                                         pf_eq_cod_id12 = (Group_property_1 cod (+) pfcod e_cod1 e_cod2
                                                                            e_cod1_pf e_cod2_pf) -- proof that e_cod1 and e_cod2 are equal

                                                         a_inv_with_pf = snd (snd (snd pfdom)) a -- (Inv_with_pf dom (*) pfdom a)
                                                         a_inv = fst a_inv_with_pf
                                                         b = (f a_inv)
                                                         c = (Inv cod (+) pfcod (f a))

                                                         pf_id_to_id = (fst pfhom)
                                                         pf_res = (snd pfhom)

                                                         --aux_pf1 : ( ( Group_id dom (*) pfdom ) = (fst (snd pfdom)) )
                                                         --aux_pf1 = Refl -- proof that fst (Group_id dom (*) pfdom) = fst (fst (snd pfdom))

                                                         pf1 = (pf_res a a_inv) -- proof that f(a * a_inv) = f a + f a_inv
                                                         pf2 = (fst (snd a_inv_with_pf)) -- proof that a * a_inv = e_dom2
                                                         pf3 = congruence dom cod (a * a_inv) e_dom2 f pf2 -- proof that a * a_inv = e_dom2
                                                         pf4 = trans (sym pf1) pf3 -- proof that f(a * a_inv) = f e_dom2
                                                         pf5 = (Group_property_1 cod (+) pfcod
                                                               (f e_dom1) e_cod1 pf_id_to_id e_cod1_pf) -- proof that f e_dom1 = e_cod1
                                                         pf6 = congruence dom cod e_dom1 e_dom2 f pf_eq_dom_id12-- proof that f e_dom1 = f e_dom2
                                                         pf7 = trans (trans pf4 (sym pf6)) pf5 -- proof that (f a) + (f a_inv) = e_cod1
                                                         pf8 = Group_property_7 cod (+) pfcod (f a) (f a_inv) pf7 -- proof that inverse of (f a)
                                                                                -- is (f a_inv)
                                                         pf9 = snd (Inv_with_pf cod (+) pfcod (f a)) -- proof that c is a inverse of (f a) with
                                                                                -- e_cod2 as identity
                                                         pf9.1 = fst pf9 -- proof that (f a) + c = e_cod2
                                                         pf9.2 = snd pf9 -- proof that c + (f a) = e_cod2
                                                         pf10.1 = trans pf9.1 (sym pf_eq_cod_id12) -- proof that (f a) + c = e_cod1
                                                         pf10.2 = trans pf9.2 (sym pf_eq_cod_id12) -- -- proof that c + (f a) = e_cod1
                                                         pf10 = (pf10.1, pf10.2)

                                                         in
                                                         (Group_property_2 cod (+) pfcod (f a) b c pf8 pf10)

||| Property 9 - If a*b = c then b = Inv(a) * c
total
Group_property_9 : (grp : Type) -> ((*) : grp -> grp -> grp) -> (pfgrp : IsGroup grp (*)) ->
                   (a, b, c : grp) -> (a*b = c) -> (b = (Inv grp (*) pfgrp a)*c)

Group_property_9 grp (*) pfgrp a b c pfEq = ?rhs


module Cosets

import Group
%access public export

--The type of proofs that a type trav Transverses a given coset only once,
--if at all
CosetInj: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
          (sbgrp: Subgroup h pfh g pfg) ->
          (trav: Type) -> (f: trav -> g) -> Type
CosetInj  h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav f =
  ((x: trav) -> (y: trav) ->
  (p: h ** (f x) = (incl p)*(f y)) -> (x = y)) where
  incl = (fst sbgrp)

--The type of proofs that a type trav Transverses every coset of a given
-- group g wrt a subgroup h
CosetAll: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
          (sbgrp: Subgroup h pfh g pfg) ->
          (trav: Type) -> (f: trav -> g) -> Type
CosetAll h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav f =
  ((a: g) ->
  (p: h ** (t: trav ** ((incl p)*(f t) = a)))) where
  incl = (fst sbgrp)

-- Transversal type - the type of proofs that a given type is a Transversal
-- of a group g wrt a subgroup h
IsTransversal: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
               (sbgrp: Subgroup h pfh g pfg) -> (trav: Type) -> Type
IsTransversal h pfh g pfg sbgrp trav = DPair (trav -> g) (\f =>
  (CosetInj h pfh g pfg sbgrp trav f,
  CosetAll  h pfh g pfg sbgrp trav f)
  )

--The transversal data type
data Transversal: (trav: Type) -> Type where
  MkTransversal: (h: Type) -> (pfh: Group h) -> (g: Type) -> (pfg: Group g) ->
                 (sbgrp: Subgroup h pfh g pfg) -> (trav: Type) ->
                 (IsTransversal h pfh g pfg sbgrp trav) -> Transversal trav

--Defining the multiplication operation between elements of a traversal
MulTrans: (trav: Type) -> (Transversal trav) -> trav -> trav -> trav
MulTrans trav (MkTransversal h (MkGroup h (+) pfh) g (MkGroup g (*) pfg) sbgrp trav pftrav) y z = (fst (snd ((snd (snd pftrav)) ((f y)*(f z))))) where
  f: trav -> g
  f = (fst pftrav)


> module BoundedNat.Operations

> import Data.Fin
> import Data.Vect

> import BoundedNat.BoundedNat
> import Fin.Properties
> import Nat.LTProperties
> import Sigma.Sigma
> import Pairs.Operations

> %default total
> %access public export

> ||| Mapping bounded |Nat|s to |Fin|s
> toFin : {b : Nat} -> LTB b -> Fin b
> toFin {b = Z}   (MkSigma  _     nLT0        ) = void (succNotLTEzero nLT0)
> toFin {b = S m} (MkSigma  Z     _           ) = FZ
> toFin {b = S m} (MkSigma (S n) (LTESucc prf)) = FS (toFin (MkSigma n prf))

> ||| Mapping |Fin|s to bounded |Nat|s
> fromFin : {b : Nat} -> Fin b -> LTB b
> fromFin k = MkSigma (finToNat k) (finToNatLemma k)

> |||
> toVect : {b : Nat} -> {A : Type} -> (LTB b -> A) -> Vect b A
> toVect {b = Z}        _ = Nil
> toVect {b = S b'} {A} f = (f (MkSigma Z (ltZS b'))) :: toVect f' where
>   f' : LTB b' -> A
>   f' (MkSigma k q) = f (MkSigma (S k) (LTESucc q))


import Data.Vect

import Data.List.Views
import Data.Vect.Views
import Data.Nat.Views

{- 1 -}

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

{- 2 -}

total
mergeSort : Ord a => Vect n a -> Vect n a
mergeSort xs with (splitRec xs)
  mergeSort [] | SplitRecNil = []
  mergeSort [x] | SplitRecOne = [x]
  mergeSort (ys ++ zs) | (SplitRecPair lrec rrec)
      = merge (mergeSort ys | lrec) (mergeSort zs | rrec)

{- 3 -}

total
toBinary : Nat -> String
toBinary k with (halfRec k)
  toBinary Z | HalfRecZ = ""
  toBinary (n + n) | (HalfRecEven rec) = toBinary n | rec ++ "0"
  toBinary (S (n + n)) | (HalfRecOdd rec) = toBinary n | rec ++ "1"

{- 4 -}

palindrome : Eq a => List a -> Bool
palindrome input with (vList input)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (xs ++ [y])) | (VCons rec)
      = x == y && palindrome xs


{- 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
   Ctrl-Alt-W: Add With View -}
module Main

data TakeN : List a -> Type where
  Fewer : TakeN xs
  Exact : (n_xs : List a) -> TakeN (n_xs ++ rest)

takeN : (n : Nat) -> (xs : List a) -> TakeN xs
takeN Z xs = Exact []
takeN (S k) [] = Fewer
takeN (S k) (x :: xs) = case takeN k xs of
  Fewer => Fewer
  Exact ys => Exact (x :: ys)

groupByN : (n : Nat) -> (xs : List a) -> List (List a)
groupByN n xs with (takeN n xs)
  groupByN n xs | Fewer = [xs]
  groupByN n (n_xs ++ rest) | (Exact n_xs) = n_xs :: groupByN n rest

halves : List a -> (List a, List a)
halves xs with (takeN (length xs `div` 2) xs)
  halves xs | Fewer = (xs, [])
  halves (n_xs ++ rest) | (Exact n_xs) = (n_xs, rest)

main : IO ()
main = do
  printLn $ groupByN 3 [1,2,3,4,5,6,7,8,9,10,11]
  printLn $ halves [1..10]
  printLn $ halves [1]


import Data.Fin
import Data.List
import Data.Nat
import Data.SortedSet as S
import Data.String.Parser
import Data.Vect

import System.File

Node : Type
Node = (Nat, Nat)

-- A Non empty grid
Grid : Nat -> Type
Grid n = Vect (S n) (Vect (S n) Node)

gupdateAt : (Fin (S n), Fin (S n)) -> (Node -> Node) -> Grid n -> Grid n
gupdateAt (x, y) f = updateAt y (updateAt x f)

gindex : (Fin (S n), Fin (S n)) -> Grid n -> Node
gindex (x, y) = index x . index y

inf : Nat
inf = 1000000

parser : Parser (n ** Grid n)
parser = do row <- some digit <* char '\n'
            let n = length row
            Just v <- pure $ toVect n $ (,inf) . finToNat <$> row
              | Nothing => fail "not length"
            Yes ItIsSucc <- pure $ isItSucc n
              | No _ => fail "Row is zero"
            vs <- ntimes (pred n) (((map ((,inf) . finToNat)) <$> ntimes n digit) <* char '\n')
            pure $ MkDPair (pred n) (v :: vs)

decFin : Fin n -> Maybe (Fin n)
decFin FZ = Nothing
decFin (FS x) = Just $ weaken $ x
incFin : {n : Nat} -> Fin n -> Maybe (Fin n)
incFin f = strengthen $ shift 1 f

neighbours : {n : Nat} -> (Fin n, Fin n) -> List (Fin n, Fin n)
neighbours (x, y) = ((, y) <$> catMaybes [decFin x, incFin x]) ++
                    ((x, ) <$> catMaybes [decFin y, incFin y])

lowestRisk' : {n : Nat} -> List (Fin (S n), Fin (S n)) -> Grid n -> Grid n
lowestRisk' [] g = g
lowestRisk' ((x, y) :: queue) g = let (_, d) = gindex (x, y) g
                                      n = filter (\p => let (v, t) = gindex p g in v + d < t) $ neighbours (x, y)
                                      ng = foldl (\g' => \p => gupdateAt p (\(v, _) => (v, v + d)) g') g $ n
                                      nq = queue ++ n in
                                      lowestRisk' nq ng

lowestRisk : {n : Nat} -> Grid n -> Grid n
lowestRisk g = lowestRisk' ((0, 0) :: []) (gupdateAt (0, 0) (mapSnd (const 0)) g)

wrapAdd : Nat -> Nat -> Nat
wrapAdd 0 n = n
wrapAdd (S k) n = if n == 9
                     then wrapAdd k 1
                     else wrapAdd k (S n)

largerRow : Vect (S n) (Nat, Nat) -> Vect (5 * (S n)) (Nat, Nat)
largerRow v = v ++ (concat $ ((\a => mapFst (wrapAdd a) <$> v) <$> [1,2,3,4]))

largerColumn : Vect (S n) (Vect (5 * (S n)) (Nat, Nat)) -> Vect (5 * (S n)) (Vect (5 * (S n)) (Nat, Nat))
largerColumn v = v ++ (concat $ ((\a => (mapFst (wrapAdd a) <$>) <$> v) <$> [1,2,3,4]))

largerGrid : Grid n -> Grid (pred (5 * (S n)))
largerGrid g = let rowextended = largerRow <$> g in
                   largerColumn rowextended

run : String -> IO ()
run s = do Right (MkDPair n g, _) <- pure $ parse parser s
             | Left err => putStrLn $ show err
           let g = lowestRisk $ largerGrid g
           putStrLn $ show $ snd $ gindex (last, last) g

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


module With

import Data.Vect

filter' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter' f [] = (_ ** [])
filter' f (x :: xs) =
  let (_ ** xs') = filter' f xs
  in if f x
    then (_ ** x :: xs')
    else (_ ** xs')

filter'' : (a -> Bool) -> Vect n a -> (p ** Vect p a)
filter'' f [] = (_ ** [])
filter'' f (x :: xs) with (filter'' f xs)
  | (_ ** xs') = if f x then (_ ** x :: xs') else (_ ** xs')

-- similar to view pattern in haskell?
-- https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns#Basicviewpatterns

data Parity : Nat -> Type where
  Even : Parity (n + n)
  Odd  : Parity (S (n + n))

parity : (n : Nat) -> Parity n
parity Z = Even {n = Z}
parity (S Z) = Odd {n = Z}
parity (S (S k)) = ?incomplete
-- parity (S (S k)) with (parity k)
--   parity (S (S (j + j)))     | Even = Even { n = S j }
--   parity (S (S (S (j + j)))) | Odd  = Odd  { n = S j }
  -- don't know how to go futher, the error message shows it cannot prove:
  --  (S j) + (S j) ~ S (S (j + j))

-- `with' syntax can be used to further decompose (pattern matchin) on the
-- parameter with respect to the result of an expression

natToBin : Nat -> List Bool
natToBin Z = Nil
natToBin k with (parity k)
  natToBin (j + j)    | Even = False :: natToBin j
  natToBin (S (j + j))| Odd  = True  :: natToBin j


module Math.Algebra.Quantum.Qubit

import public Data.Fin
import public Data.Vect
import public Data.Matrix
import public Data.Matrix.Algebraic
--import public Data.Matrix.Numeric
import public Data.Complex

import public Control.Algebra
import public Control.Algebra.VectorSpace

%access public export
%default total

C : Type
C = Complex Double

-- Euler
e : Double
e = exp 1

-- Imaginary unit
i : C
i = 0:+1

-- Complex Pi
pii : C
pii = pi:+0

-- Complex exponentiation
expi : C -> C
expi z =
  let es = exp $ realPart z in
    es * (cos $ imagPart z) :+ es * (sin $ imagPart z)

-- WIP
-- really to enforce conjugate transpose we need to have a 1-col matrix
-- and a 1-row matrix as a Bra i.e.
-- Ket = Matrix 2 1 C
-- Bra = Matrix 1 2 C
-- them implement all the Semigroup/Monoid/Group/InnerProductSpace etc. instances for these
-- along with interfaces for (ant general matrix classes, definite, normal, semi-definite etc.?)
-- Operator = Matrix 2 2 C
-- Unitary : Operator where ...
-- Hermitian : Unitary where ...

-- in some sense a vector is a linear transformation anyway especially when
-- you consider dot product as linear transformation to 1-d field
-- hermitian = dagger = adjoint

mmap : (a -> a) -> Matrix n m a -> Matrix n m a
mmap = map . map

-- TODO instead of aliases we should define new types and classes

Ket : Type
Ket = Matrix 2 1 C

Bra: Type
Bra = Matrix 1 2 C

ket : C -> C -> Ket
ket a b = [[a], [b]]

bra : C -> C -> Bra
bra a b = [[a, b]]

qubit : C -> C -> Ket
qubit = ket

one : Ket
one = qubit (0:+0) (1:+0)

zero : Ket
zero = qubit (1:+0) (0:+0)

bra2ket : Bra -> Ket
bra2ket b = Data.Vect.transpose $ mmap conjugate b

ket2bra : Ket -> Bra
ket2bra k = Data.Vect.transpose $ mmap conjugate k

--

Operator : Type
Operator = Matrix 2 2 C

Id : Operator
Id = [[1:+0, 0:+0], [0:+0, 1:+0]]

{-
Data.Matrix.Agebraic now takes care of these implementations

[AddComplexSemigroup] Semigroup C where
  (<+>) z w = z + w

[MulComplexSemigroup] Semigroup C where
  (<+>) z w = z * w

[AddComplexMonoid] Monoid C using AddComplexSemigroup where
  neutral = 0:+0

[MulComplexMonoid] Monoid C using MulComplexSemigroup where
  neutral = 1:+0

Group C using MulComplexMonoid where
  inverse z = 1 / z

AbelianGroup C where { }

Ring C where
  (<.>) z w = z * w

RingWithUnity C where
  unity = 1:+0

-- Kets upto InnerProductSpace

Semigroup Ket where
  (<+>) u v = zipWith (+) u v

Monoid Ket where
  neutral = [0:+0, 0:+0]

Group Ket where
  inverse u = map (1 /) u

AbelianGroup Ket where { }

Module C Ket where
  (<#>) c v = map (* c) v

-}

{-
InnerProductSpace C Ket where
  (<||>) u v = sum $ zipWith (*) u v

test : C
test = one <||> one
-}

-- Local Variables:
-- idris-load-packages: ("base" "contrib")
-- End:


-- module Main

data N = Zero | Suc N

addOne : N -> N
addOne Zero = Suc Zero
addOne (Suc n) = Suc (Suc n)

One : N
One = Suc Zero
Two : N
Two = (Suc (Suc Zero))
Three : N
Three = addOne Two
Four : N
Four = addOne Three
Five : N
Five = addOne Four

add : N -> N -> N
add Zero s = s
add (Suc a) b = add a (Suc b)

data Vec : (a : Type) -> N -> Type where
  Nil : Vec a Zero
  Cons : {n : N} -> a -> Vec a n -> Vec a (Suc n)

empt : Vec N Zero
empt = Nil

test : Vec N Two
test = Cons One (Cons Two Nil)

test2 : Vec N Three
test2 = Cons Three (Cons Four (Cons Five Nil))

concat : {g : Type} -> {a : N} -> {b : N} -> Vec g a -> Vec g b -> Vec g (add a b)
concat Nil rest = rest
concat (Cons a rest) b = concat rest (Cons a b)

t3 : Vec N (addOne (addOne (addOne (addOne One))))
t3 = concat test test2


module FinCmp

-- Decidable comparison of finite numbers less
-- than a given bound (i.e. "ordinals").

import public Data.Fin

%default total
%access public export

-------------------------------------------
-- Begin: DECIDABLE COMPARISONS OF ORDINALS

-- Data type for evidence that "i < j".
data FinLT : Fin n -> Fin n -> Type where
  LtZ : FinLT FZ (FS i)
  LtS : FinLT i j -> FinLT (FS i) (FS j)

-- Simplified symtax:
infixl 6 :<:
(:<:) : Fin n -> Fin n -> Type
(:<:) = FinLT

-- Data type for evidence of which of the
-- following holds between ordinals 'i' and 'j':
--
--    (a) i < j
--    (b) i = j
--    (c) i < j
--
data FinCMP : Fin n -> Fin n -> Type where
  CmpEq : (i = j) -> FinCMP i j
  CmpLt : i :<: j -> FinCMP i j
  CmpGt : j :<: i -> FinCMP i j

-- Function 'finNotLtZ' yields a proof of the following:
--
--    "There is no ordinal less than zero."
--     (In other words, given a proof that 'i' is
--     less than zero, the function 'finNotLtZ' yields
--     a member of the uninhabited type 'Void'.)
--
finNotLtZ : i :<: FZ -> Void
finNotLtZ _ impossible

-- Function 'finCmpDec' decides whether
--
--    (a) i < j, or
--    (b) i = j, or
--    (c) i > j  holds,
--
-- and yields evidence in the form of a value
-- of type 'FinCMP i j'.
finCmpDec : (i : Fin n) -> (j : Fin n) -> (FinCMP i j)
finCmpDec i j = case i of
  FZ => case j of
             FZ    => CmpEq Refl
             FS j' => CmpLt LtZ
  FS i' => case j of
                FZ    => CmpGt LtZ
                FS j' => case finCmpDec i' j' of
                              CmpEq eq => CmpEq (rewrite eq in Refl)
                              CmpLt lt => CmpLt (LtS lt)
                              CmpGt lt => CmpGt (LtS lt)

-- Function 'finLtPred' yields a proof of the following:
--
--    "Given (FS i) < (FS j)m then i < j".
--
finLtPred : (FS i) :<: (FS j) -> i :<: j
finLtPred lt = case lt of LtS lt' => lt'

-- End: DECIDABLE COMPARISONS OF ORDINALS
-----------------------------------------


import Decidable.Equality

data DivisiblebyX : Nat -> Nat -> Type where
  Base: DivisiblebyX x x
  Multiple: DivisiblebyX x y -> DivisiblebyX x (x+y)

data FizzBuzzProof: Nat -> Type where
  Fizz: DivisiblebyX 3 x -> (DivisiblebyX 5 x -> Void) -> FizzBuzzProof x
  Buzz: DivisiblebyX 5 x -> (DivisiblebyX 3 x -> Void) -> FizzBuzzProof x
  FizzBuzz: DivisiblebyX 3 x -> DivisiblebyX 5 x -> FizzBuzzProof x
  Normal: (x: Nat) -> (DivisiblebyX 3 x -> Void) ->(DivisiblebyX 5 x -> Void) -> FizzBuzzProof x

Show (FizzBuzzProof x) where
  show (Fizz _ _) = "fizz"
  show (Buzz _ _) = "buzz"
  show (FizzBuzz _ _) = "fizzbuzz"
  show (Normal x _ _) = show x

threeLessNotDivisible3 : (notdiv : DivisiblebyX 3 (S y) -> Void) -> DivisiblebyX 3 (3 + (S y)) -> Void
threeLessNotDivisible3 notdiv (Multiple x) = notdiv x

zeroNotDivisible3 : DivisiblebyX 3 0 -> Void
zeroNotDivisible3 Base impossible
zeroNotDivisible3 (Multiple _) impossible

oneNotDivisible3 : DivisiblebyX 3 1 -> Void
oneNotDivisible3 Base impossible
oneNotDivisible3 (Multiple _) impossible

twoNotDivisible3 : DivisiblebyX 3 2 -> Void
twoNotDivisible3 Base impossible
twoNotDivisible3 (Multiple _) impossible

divisibleby3: (y: Nat) -> Dec (DivisiblebyX 3 y)
divisibleby3 Z = No zeroNotDivisible3
divisibleby3 (S Z) = No oneNotDivisible3
divisibleby3 (S (S Z)) = No twoNotDivisible3
divisibleby3 (S (S (S Z))) = Yes Base
divisibleby3 (S (S (S (S y)))) = case divisibleby3 (S y) of
  Yes prf => Yes (Multiple prf)
  No notdiv => No (threeLessNotDivisible3 notdiv)

zeroNotDivisible5 : DivisiblebyX 5 0 -> Void
zeroNotDivisible5 Base impossible
zeroNotDivisible5 (Multiple _) impossible

oneNotDivisible5 : DivisiblebyX 5 1 -> Void
oneNotDivisible5 Base impossible
oneNotDivisible5 (Multiple _) impossible

twoNotDivisible5 : DivisiblebyX 5 2 -> Void
twoNotDivisible5 Base impossible
twoNotDivisible5 (Multiple _) impossible

threeNotDivisible5 : DivisiblebyX 5 3 -> Void
threeNotDivisible5 Base impossible
threeNotDivisible5 (Multiple _) impossible

fourNotDivisible5 : DivisiblebyX 5 4 -> Void
fourNotDivisible5 Base impossible
fourNotDivisible5 (Multiple _) impossible

fiveLessNotDivisible5 : (notdiv : DivisiblebyX (fromInteger 5) (S y) -> Void) -> DivisiblebyX 5 (S (S (S (S (S (S y)))))) -> Void
fiveLessNotDivisible5 notdiv (Multiple x) = notdiv x

divisibleby5: (y: Nat) -> Dec (DivisiblebyX 5 y)
divisibleby5 Z = No zeroNotDivisible5
divisibleby5 (S Z) = No oneNotDivisible5
divisibleby5 (S (S Z)) = No twoNotDivisible5
divisibleby5 (S (S (S Z))) = No threeNotDivisible5
divisibleby5 (S (S (S (S Z)))) = No fourNotDivisible5
divisibleby5 (S (S (S (S (S Z))))) = Yes Base
divisibleby5 (S (S (S (S (S (S y)))))) = case divisibleby5 (S y) of
  Yes prf => Yes (Multiple prf)
  No notdiv => No (fiveLessNotDivisible5 notdiv)

fizzbuzz: (x: Nat) -> FizzBuzzProof x
fizzbuzz x = case (divisibleby3 x, divisibleby5 x) of
  (No not_fizz, No not_buzz) => Normal x not_fizz not_buzz
  (Yes fizz_prf, Yes buzz_prf) => FizzBuzz fizz_prf buzz_prf
  (No not_fizz, Yes buzz_prf) => Buzz buzz_prf not_fizz
  (Yes fizz_prf, No not_buzz) => Fizz fizz_prf not_buzz

fizzbuzz_string: (x: Nat) -> String
fizzbuzz_string x = show $ fizzbuzz x

fizzbuzz_loop: (n: Nat) -> (end: Nat) -> IO ()
fizzbuzz_loop n end with (decEq n end)
  fizzbuzz_loop n end | Yes prf = pure ()
  fizzbuzz_loop n end | No contra =  do
    putStrLn $ show $ fizzbuzz n
    fizzbuzz_loop (S n) end

main: IO ()
main = fizzbuzz_loop 1 101


module Extra.Fin

import Data.Fin
import Data.Fin.Extra
import Data.Nat
import Data.Nat.Division
import Extra.Binary
import Extra.Nat

||| Turns a `Bits8` into its `Fin` representation
export
bits8ToFin : Bits8 -> Fin 256
bits8ToFin n = helper 0
  where
  helper : Bits8 -> Fin 256
  helper m = believe_me $ if m == n then FZ else FS (helper (m + 1))

||| Modulo a `Fin`
export
modFinNZ : Fin (S a) -> (b : Nat) -> Not (b = 0) -> Fin b
modFinNZ a b prf = let x = boundModNatNZ (finToNat a) b prf in natToFinLTE (modNatNZ (finToNat a) b prf) x

-- TODO: i have no idea how to prove this with the monotonic property of division or whatever its called by the true gameRZ of the community. For now i'm using natToFin, which is sacrilegious imo
||| Divide a `Fin`
export
divFinNZ : {a : Nat} -> Fin (S a) -> (b : Nat) -> (prf : Not (b = 0)) -> Fin (S (divNatNZ a b prf))
divFinNZ numer denom prf = case natToFin (divNatNZ (finToNat numer) denom prf) (S (divNatNZ a denom prf)) of
  Just x => x
  Nothing => last

||| Divide and modulo a `Fin`
export
divmodFinNZ : {a : Nat} -> Fin (S a) -> (b : Nat) -> (prf : Not (b = 0)) -> (Fin (S (divNatNZ a b prf)), Fin b)
divmodFinNZ a b prf = (divFinNZ a b prf, modFinNZ a b prf)


module Main

double : Num a => a -> a
double x = x*x

occurrences : Eq ty => (item : ty) -> (values : List ty) -> Nat
occurrences item [] = 0
occurrences item (value :: values) = case value == item of
                                          True => 1 + occurrences item values
                                          False => occurrences item values

data Matter = Solid | Liquid | Gas

Eq Matter where
    (==) Solid Solid = True
    (==) Liquid Liquid = True
    (==) Gas Gas = True
    (==) _ _ = False
    {-
      (/=) x y = not (x == y)
      this definition is actually the default one,
      so no need to redefine it here
    -}

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Empty empty
%name Node node, node1, node2, node3
%name Tree tree, tree1, tree2, tree3

Eq elem => Eq (Tree elem) where
    (==) Empty Empty = True
    (==) (Node left value right) (Node left' value' right') =
      left == left' && value == value' && right == right'
    (==) _ _ = False

Functor Tree where
    map func Empty = Empty
    map func (Node l x r) = (Node (map func l) (func x) (map func r))

Foldable Tree where
    foldr func acc Empty = acc
    foldr func acc (Node left x right)
      = let
          leftFold = foldr func acc left
          rightFold = foldr func leftFold right
        in
          func x rightFold


module Bifunctor

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

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

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

implementation Bifunctor Either where
  bimap f _ (Left  a) = Left  $ f a
  bimap _ g (Right b) = Right $ g b

public export
implementation Bifunctor Pair where
  bimap f g (a, b) = (f a, g b)


import Data.Fin

data Graph : Nat -> Type where
  Empty : Graph Z
  Node : Bool -> Graph (S Z)
  Combine : (Fin (S n) -> Fin (S m) -> Bool) -> Graph (S n) -> Graph (S m) -> Graph (S n + S m)

combine : {n:Nat} -> {m:Nat} -> (Fin n -> Fin m -> Bool) -> Graph n -> Graph m -> Graph (n+m)
combine {n=n} _ a Empty = rewrite plusZeroRightNeutral n in a
combine {m=m} _ Empty b = b
combine {n=S n} {m=S m} f a b = Combine f a b

f : Bool -> Fin n -> Fin m -> Bool
f a _ _ = a

overlay : Graph n -> Graph m -> Graph (n+m)
overlay a b = combine (f False) a b

connect : Graph n -> Graph m -> Graph (n+m)
connect a b = combine (f True) a b

unconnected : (n : Nat) -> Graph n
unconnected Z = Empty
unconnected (S n) = overlay (Node False) (unconnected n)

clique : (n : Nat) -> Graph n
clique Z = Empty
clique (S n) = connect (Node True) (clique n)


import Data.Vect

inputs : Vect 4 Double
inputs = [1.0, 2.0, 3.0, 2.5]

weights : Vect 3 (Vect 4 Double)
weights = [[0.2, 0.8, -0.5, 1.0], [0.5, -0.91, 0.26, -0.5], [-0.26, -0.27, 0.17, 0.87]]

biases : Vect 3 Double
biases = [2.0, 3.0, 0.5]

-- NOTE: match numpy interface in the spirit of the Python lesson
dotProduct : Vect n (Vect m Double) ->
             Vect m Double ->
             Vect n Double
dotProduct xss ys = map (\xs => sum $ zipWith (*) xs ys) xss

-- add the biases to the results of the dot product
output : Vect 3 Double
output = zipWith (+) (dotProduct weights inputs) biases

main : IO ()
main = printLn output


module AddAllN

-- The idea from Thorsten Altenkirch's "Why Type Theory matters" at Lambda Days 2019 --

public export
NatFun : Nat -> Type
NatFun Z = Nat
NatFun (S n) = Nat -> NatFun n

liftUnary : (Nat -> Nat) -> {n : Nat} -> NatFun n -> NatFun n
liftUnary f {n=Z}   nf = f nf
liftUnary f {n=S k} nf = liftUnary f . nf

-- You can also lift binary and `const`

export
add : {n : Nat} -> NatFun n
add {n=Z}   = 0
add {n=S k} = \n => liftUnary (n+) add

x : Nat
x = add 2 3 4 5

x' : Nat
x' = add (the Nat 2) (the Nat 3) (the Nat 4) (the Nat 5)

y : Nat
y = add 1 2


module EqNat

%default total

data EqNat : (num1 : Nat) -> (num2 : Nat) -> Type where
  Same : (num : Nat) -> EqNat num num

sameS : (eq : EqNat k j) -> EqNat (S k) (S j)
sameS (Same k) = Same (S k)

checkEqNat : (num1 : Nat) -> (num2 : Nat) -> Maybe (EqNat num1 num2)
checkEqNat Z Z = Just (Same Z)
checkEqNat Z _  = Nothing
checkEqNat _ Z = Nothing
checkEqNat (S k) (S l) = case checkEqNat k l of
                              Nothing => Nothing
                              Just eq => Just (sameS eq)


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

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

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

index : Fin n -> Vect n a -> a
index FZ (x::xs) = x
index (FS k) (x::xs) = index k xs

isEmpty : Vect n a -> Bool
isEmpty {n=Z} _ = True
isEmpty {n=S k} _ = False

1::(2::(3::Nil)) : Vect 3 Integer