||| Additional utilites for solving and deriving
||| (in)equalities in `Integer` arithmetics.
module Data.Prim.Integer.Extra

import public Data.Prim.Integer
import Syntax.PreorderReasoning

%default total

infixl 0  <>
prefix 1  |>
infix  1  ..., ..=, =.., =.=
infix  1  ~.., ..~, ~.~

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

||| Allows us to commute addition on both sides of an inequality.
export
0 pairPlusCommutative :  {w,x,y,z : Integer}
                      -> (w + x === x + w, y + z === z + y)
pairPlusCommutative = (plusCommutative, plusCommutative)

||| Allows us to commute multiplication on both sides of an inequality.
export
0 pairMultCommutative :  {w,x,y,z : Integer}
                      -> (w * x === x * w, y * z === z * y)
pairMultCommutative = (multCommutative, multCommutative)

--------------------------------------------------------------------------------
--          Syntax for deriving (in)equalities
--------------------------------------------------------------------------------

||| Type describing a relation between two integers.
|||
||| This is used to solve integer (in)equalities with
||| a syntax that is similar to the one used for preorder
||| reasoning.
public export
data Rel :  (rel : Integer -> Integer -> Type)
         -> (x,y : Integer)
         -> Type where
  (<)   : (x,y : Integer) -> Rel (<)   x y
  (<=)  : (x,y : Integer) -> Rel (<=)  x y
  (===) : (x,y : Integer) -> Rel (===) x y
  (>=)  : (x,y : Integer) -> Rel (>=)  x y
  (>)   : (x,y : Integer) -> Rel (>)   x y

public export
0 rel : Rel r x y -> (u,v : Integer) -> Rel r u v
rel (_ < _)   u v = u < v
rel (_ <= _)  u v = u <= v
rel (_ === _) u v = u === v
rel (_ >= _)  u v = u >= v
rel (_ > _)   u v = u > v

||| Reversed function application.
export
App : a -> (a -> b) -> b
App x f = f x

||| The identity function for relations.
export
0 (|>) : Rel r x y -> r x y -> r x y
(|>) _ v = v

||| Reversed function composition.
export
0 (<>) : (a -> b) -> (b -> c) -> a -> c
(<>) f g = g . f

||| Thought bubble similar to the one used in
||| `Syntax.PreorderReasoning`.
export
0 (...) : Rel r x y -> (Rel r x y -> a -> r x y) -> a -> r x y
(...) r f = f r

||| Replace the right hand side of an (in)equality.
export
0 (..=) : Rel r x z -> (y === z) -> r x y -> r x z
(..=) _ prf v = replace {p = r x} prf v

||| Replace the right hand side of an (in)equality.
export
0 (..~) : Rel r x z -> (z === y) -> r x y -> r x z
(..~) r prf = r ..= sym prf

||| Replace the left hand side of an (in)equality.
export
0 (=..) : Rel r x z -> (y === x) -> r y z -> r x z
(=..) _ prf v = replace {p = \a => r a z} prf v

||| Replace the left hand side of an (in)equality.
export
0 (~..) : Rel r x z -> (x === y) -> r y z -> r x z
(~..) r prf = r =.. sym prf

||| Replace both sides of an (in)equality.
export
0 (=.=) : Rel r w z -> (x === w, y === z) -> r x y -> r w z
(=.=) _ (p1,p2) v = replace {p = r w} p2
                  $ replace {p = \a => r a y} p1 v

||| Replace both sides of an (in)equality.
export
0 (~.~) : Rel r w z -> (w === x, z === y) -> r x y -> r w z
(~.~) r (p1,p2) = r =.= (sym p1, sym p2)

--------------------------------------------------------------------------------
--          Addition in Inequalities
--------------------------------------------------------------------------------

||| Adding a value on the left does not affect an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> z + x < z + y ... plusLeft
||| ```
export
0 plusLeft :  {x,y,z : Integer}
           -> Rel r (z + x) (z + y)
           -> r x y
           -> r (z + x) (z + y)
plusLeft (_ < _)   v         = plusGT x y z v
plusLeft (_ <= _)  (Left v)  = Left $ plusGT x y z v
plusLeft (_ <= _)  (Right v) = Right $ cong (z +) v
plusLeft (_ === _) v         = cong (z +) v
plusLeft (_ >= _)  (Left v)  = Left $ plusGT y x z v
plusLeft (_ >= _)  (Right v) = Right $ cong (z +) v
plusLeft (_ > _)   v         = plusGT y x z v

||| Adding a value on the right does not affect an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> x + z < y + z ... plusRight
||| ```
export
0 plusRight :  {x,y,z : Integer}
            -> Rel r (x + z) (y + z)
            -> r x y
            -> r (x + z) (y + z)
plusRight w =
  |> rel w x y
  <> rel w (z + x) (z + y) ... plusLeft
  <> rel w (x + z) (y + z) =.= pairPlusCommutative

||| The result of adding a positive value is greater than
||| the original.
export
0 plusPosRight :  {x,y : Integer} -> 0 < y -> x < x + y
plusPosRight =
  |> 0 < y
  <> x + 0 < x + y ... plusLeft
  <> x     < x + y =.. plusZeroRightNeutral

||| The result of adding a positive value is greater than
||| the original.
export
0 plusPosLeft :  {x,y : Integer} -> 0 < y -> x < y + x
plusPosLeft =
  |> 0 < y
  <> 0 + x < y + x ... plusRight
  <> x     < y + x =.. plusZeroLeftNeutral

||| The result of adding a positive value is not less than
||| the original.
export
0 plusNonNegRight :  {x,y : Integer} -> 0 <= y -> x <= x + y
plusNonNegRight (Left lt)  = Left (plusPosRight lt)
plusNonNegRight (Right eq) =
  Right $ rewrite sym eq in (sym $ plusZeroRightNeutral {n = x})

||| The result of adding a positive value is not less than
||| the original.
export
0 plusNonNegLeft :  {x,y : Integer} -> 0 <= y -> x <= y + x
plusNonNegLeft (Left lt)  = Left (plusPosLeft lt)
plusNonNegLeft (Right eq) =
  Right $ rewrite sym eq in (sym $ plusZeroLeftNeutral {n = x})

||| The result of adding a negative value is greater than
||| the original.
export
0 plusNegRight :  {x,y : Integer} -> y < 0 -> x + y < x
plusNegRight =
  |> y < 0
  <> x + y < x + 0 ... plusLeft
  <> x + y < x     ..= plusZeroRightNeutral

||| The result of adding a negative value is greater than
||| the original.
export
0 plusNegLeft :  {x,y : Integer} -> y < 0 -> y + x < x
plusNegLeft =
  |> y < 0
  <> y + x < 0 + x ... plusRight
  <> y + x < x     ..= plusZeroLeftNeutral

||| The result of adding a positive value is not less than
||| the original.
export
0 plusNonPosRight :  {x,y : Integer} -> y <= 0 -> x + y <= x
plusNonPosRight (Left lt)  = Left (plusNegRight lt)
plusNonPosRight (Right eq) =
  Right $ rewrite eq in (plusZeroRightNeutral {n = x})

||| The result of adding a positive value is not less than
||| the original.
export
0 plusNonPosLeft :  {x,y : Integer} -> y <= 0 -> y + x <= x
plusNonPosLeft (Left lt)  = Left (plusNegLeft lt)
plusNonPosLeft (Right eq) =
  Right $ rewrite eq in (plusZeroLeftNeutral {n = x})

||| Subtracting a value does not affect an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> x - z < y - z ... minus
||| ```
export
0 minus :  {x,y,z : Integer}
        -> Rel r (x - z) (y - z)
        -> r x y
        -> r (x - z) (y - z)
minus r =
  |> rel r x y
  <> rel r (x + neg z) (y + neg z) ... plusRight
  <> rel r (x - z) (y - z)         ~.~ (minusIsPlusNeg, minusIsPlusNeg)

||| Subtracting a value from a larger one
||| yields a positive result.
export
0 minusLT :  {x,y : Integer} -> x < y -> 0 < y - x
minusLT =
  |> x     < y
  <> x - x < y - x ... minus
  <> 0     < y - x =.. minusSelfZero

||| Subtracting a value from a non-smaller one
||| yields a non-negative result.
export
0 minusLTE :  {x,y : Integer} -> x <= y -> 0 <= y - x
minusLTE (Left lt)  = Left (minusLT lt)
minusLTE (Right eq) = Right $ Calc $
  |~ 0
  ~~ x - x ..< minusSelfZero
  ~~ y - x ... cong (\v => v - x) eq

||| Subtracting a value from a smaller one
||| yields a negative result.
export
0 minusGT :  {x,y : Integer} -> x < y -> x - y < 0
minusGT =
  |> x     < y
  <> x - y < y - y ... minus
  <> x - y < 0     ..= minusSelfZero

||| Subtracting a value from a non-greater one
||| yields a non-positive result.
export
0 minusGTE :  {x,y : Integer} -> x <= y -> x - y <= 0
minusGTE (Left lt)  = Left (minusGT lt)
minusGTE (Right eq) = Right $ Calc $
  |~ x - y
  ~~ x - x ..< cong (\v => x - v) eq
  ~~ 0     ... minusSelfZero

||| We can solve (in)equalities, where the same value has
||| been added on both sides.
|||
||| ```idris example
||| |> x + z < y + z
||| <> x     < y     ... solvePlusRight
||| ```
export
0 solvePlusRight :  {x,y,z : Integer}
                 -> Rel r x y
                 -> r (x + z) (y + z)
                 -> r x y
solvePlusRight r =
  |> rel r (x + z) (y + z)
  <> rel r ((x + z) - z) ((y + z - z)) ... minus
  <> rel r x y                         =.= (
       solve [x,z] ((x .+. z) -. z) (var x)
     , solve [y,z] ((y .+. z) -. z) (var y)
     )

||| We can solve (in)equalities, where the same value has
||| been added on both sides.
|||
||| ```idris example
||| |> z + x < z + x
||| <> x     < y     ... solvePlusLeft
||| ```
export
0 solvePlusLeft :  {x,y,z : Integer}
                -> Rel r x y
                -> r (z + x) (z + y)
                -> r x y
solvePlusLeft r =
  |> rel r (z + x) (z + y)
  <> rel r (x + z) (y + z) =.= pairPlusCommutative
  <> rel r x y             ... solvePlusRight

||| We can solve (in)equalities, where the same value has
||| been subtracted from both sides.
|||
||| ```idris example
||| |> x - z < y - z
||| <> x     < y     ... solveMinus
||| ```
export
0 solveMinus :  {x,y,z : Integer}
             -> Rel r x y
             -> r (x - z) (y - z)
             -> r x y
solveMinus r =
  |> rel r (x - z) (y - z)
  <> rel r ((x - z) + z) ((y - z) + z) ... plusRight
  <> rel r x y                         =.= (
       solve [x,z] ((x .-. z) +. z) (var x)
     , solve [y,z] ((y .-. z) +. z) (var y)
     )

||| We can solve (in)equalities, with one side an addition
||| and the other equalling zero.
|||
||| ```idris example
||| |> 0     < x + y
||| <> neg y < x     ... solvePlusRightZero
||| ```
export
0 solvePlusRightZero :  {x,y : Integer}
                     -> Rel r (neg y) x
                     -> r 0 (x + y)
                     -> r (neg y) x
solvePlusRightZero r =
  |> rel r 0 (x + y)
  <> rel r (0 - y) ((x + y) - y) ... minus
  <> rel r (neg y) x             =.= (
       solve [y]   (0 -. y) (neg (var y))
     , solve [x,y] ((x .+. y) -. y) (var x)
     )

||| We can solve (in)equalities, with one side an addition
||| and the other equalling the added value.
|||
||| ```idris example
||| |> y  < x + y
||| <> 0  < x     ... solvePlusRightSelf
||| ```
export
0 solvePlusRightSelf :  {x,y : Integer}
                     -> Rel r 0 x
                     -> r y (x + y)
                     -> r 0 x
solvePlusRightSelf r =
  |> rel r y (x + y)
  <> rel r (0 + y) (x + y) ~.. plusZeroLeftNeutral
  <> rel r 0 x             ... solvePlusRight

||| We can solve (in)equalities, with one side an addition
||| and the other equalling zero.
|||
||| ```idris example
||| |> 0     < x + y
||| <> neg x < y     ... solvePlusLeftZero
||| ```
export
0 solvePlusLeftZero :  {x,y : Integer}
                     -> Rel r (neg x) y
                     -> r 0 (x + y)
                     -> r (neg x) y
solvePlusLeftZero r =
  |> rel r 0 (x + y)
  <> rel r 0 (y + x)  ..= plusCommutative
  <> rel r (neg x) y  ... solvePlusRightZero

||| We can solve (in)equalities, with one side an addition
||| and the other equalling the added value.
|||
||| ```idris example
||| |> x  < x + y
||| <> 0  < y     ... solvePlusLeftSelf
||| ```
export
0 solvePlusLeftSelf :  {x,y : Integer}
                    -> Rel r 0 y
                    -> r x (x + y)
                    -> r 0 y
solvePlusLeftSelf r =
  |> rel r x (x + y)
  <> rel r (x + 0) (x + y) ~.. plusZeroRightNeutral
  <> rel r 0 y             ... solvePlusLeft

||| We can solve (in)equalities, with one side a subtraction
||| and the other equalling zero.
|||
||| ```idris example
||| |> 0 < x - y
||| <> y < x     ... solveMinusZero
||| ```
export
0 solveMinusZero : {x,y : Integer} -> Rel r y x -> r 0 (x - y) -> r y x
solveMinusZero r =
  |> rel r 0 (x - y)
  <> rel r (0 + y) ((x - y) + y) ... plusRight
  <> rel r y x                   =.= (
       solve [y]   (0 +. y) (var y)
     , solve [x,y] ((x .-. y) +. y) (var x)
     )

export
0 plusOneLTE : {x,y : Integer} -> x < y -> x + 1 <= y
plusOneLTE lt = App (oneAfterZero (y - x) (minusLT lt)) $
  |> 1     <= y - x
  <> x + 1 <= x + (y - x) ... plusLeft
  <> x + 1 <= y           ..= solve [x,y] (x .+ (y .-. x)) (var y)

--------------------------------------------------------------------------------
--          Negation in Inequalities
--------------------------------------------------------------------------------

||| Negating both sides inverts an inequality.
|||
||| ```idris example
||| |> x     <= y
||| <> neg y <= neg x ... negate
||| ```
export
0 negate :  {x,y : Integer}
         -> Rel r (neg y) (neg x)
         -> r x y
         -> r (neg y) (neg x)
negate r =
  |> rel r x y
  <> rel r (x - (x + y)) (y - (x + y)) ... minus
  <> rel r (neg y) (neg x)             =.= (
       solve [x,y] (x .- (x .+. y)) (negate $ var y)
     , solve [x,y] (y .- (x .+. y)) (negate $ var x)
     )

||| Negating both sides inverts an inequality.
|||
||| ```idris example
||| |> neg x <= neg y
||| <> y     <= x     ... negateNeg
||| ```
export
0 negateNeg : {x,y : Integer} -> Rel r y x -> r (neg x) (neg y) -> r y x
negateNeg r =
  |> rel r (neg x) (neg y)
  <> rel r (neg $ neg y) (neg $ neg x) ... negate
  <> rel r y x                         =.= (negInvolutory, negInvolutory)

||| `negate` specialized to where one side equals zero.
|||
||| ```idris example
||| |> x < 0
||| <> 0 < neg x ... negateZero
||| ```
|||
||| ```idris example
||| |> x <= 0
||| <> 0 <= neg x ... negateZero
||| ```
export
0 negateZero : {x : Integer} -> Rel r (neg x) 0 -> r 0 x -> r (neg x) 0
negateZero r =
  |> rel r 0 x
  <> rel r (neg x) (neg 0) ... negate
  <> rel r (neg x) 0       ..= negZero

||| `negate` specialized to where one side equals zero and the other
||| a negated value.
|||
||| ```idris example
||| |> neg x < 0
||| <> 0     < x ... negateNegZero
||| ```
|||
||| ```idris example
||| |> neg x <= 0
||| <> 0     <= x ... negateNegZero
||| ```
export
0 negateNegZero : {x : Integer} -> Rel r x 0 -> r 0 (neg x) -> r x 0
negateNegZero r =
  |> rel r 0             (neg x)
  <> rel r (neg (neg x)) (neg 0) ... negate
  <> rel r x 0                   =.= (negInvolutory, negZero)

--------------------------------------------------------------------------------
--          Multiplication in Inequalities
--------------------------------------------------------------------------------

0 mplLemma :  {x,y,z : Integer}
           -> 0 < z
           -> x < y
           -> z * x < z * y
mplLemma p =
  |> x         < y
  <> x - x     < y - x               ... minus
  <> 0         < y - x               =.. minusSelfZero
  <> 0         < z * (y - x)         ... (\_ => multPosPosGT0 _ _ p)
  <> 0 + z * x < z * (y - x) + z * x ... plusRight
  <> z * x     < z * y               =.= (
       solve [x,z]   (0 + z .*. x) (z .*. x)
     , solve [x,y,z] (z .* (y .-. x) + z .*. x) (z .*. y)
     )

||| Multiplication with a positive number preserves an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> z * x < z * y ... multPosLeft zgt0
||| ```
|||
||| ```idris example
||| |> x     <= y
||| <> z * x <= z * y ... multPosLeft zgt0
||| ```
export
0 multPosLeft :  {x,y,z : Integer}
              -> 0 < z
              -> Rel r (z * x) (z * y)
              -> r x y
              -> r (z * x) (z * y)
multPosLeft p (_ < _)   rxy       = mplLemma p rxy
multPosLeft p (_ <= _)  (Left w)  = Left $ mplLemma p w
multPosLeft p (_ <= _)  (Right w) = Right $ cong (z *) w
multPosLeft p (_ === _) rxy       = cong (z *) rxy
multPosLeft p (_ >= _)  (Left w)  = Left $ mplLemma p w
multPosLeft p (_ >= _)  (Right w) = Right $ cong (z *) w
multPosLeft p (_ > _)   rxy       = mplLemma p rxy

||| Multiplication with a positive number preserves an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> x * z < y * z ... multPosRight zgt0
||| ```
|||
||| ```idris example
||| |> x     <= y
||| <> x * z <= y * z ... multPosRight zgt0
||| ```
export
0 multPosRight :  {x,y,z : Integer}
               -> 0 < z
               -> Rel r (x * z) (y * z)
               -> r x y
               -> r (x * z) (y * z)
multPosRight p r =
  |> rel r x y
  <> rel r (z * x) (z * y) ... multPosLeft p
  <> rel r (x * z) (y * z) =.= pairMultCommutative

||| Multiplication with a negative number reverses an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> z * y < z * x ... multNegLeft zgt0
||| ```
|||
||| ```idris example
||| |> x     <= y
||| <> z * y <= z * x ... multNegLeft zgt0
||| ```
export
0 multNegLeft :  {x,y,z : Integer}
              -> z < 0
              -> Rel r (z * y) (z * x)
              -> r x y
              -> r (z * y) (z * x)
multNegLeft p r =
  let negp = negateZero (neg z > 0) p
   in |> rel r x y
      <> rel r (neg y) (neg x)                 ... negate
      <> rel r (neg z * neg y) (neg z * neg x) ... multPosLeft negp
      <> rel r (z * y) (z * x)                 =.= (
           solve [z,y] (neg (var z) * neg (var y)) (z .*. y)
         , solve [z,x] (neg (var z) * neg (var x)) (z .*. x)
         )

||| Multiplication with a negative number reverses an inequality.
|||
||| ```idris example
||| |> x     < y
||| <> y * z < x * z ... multNegRight zgt0
||| ```
|||
||| ```idris example
||| |> x     <= y
||| <> y * z <= x * z ... multNegRight zgt0
||| ```
export
0 multNegRight :  {x,y,z : Integer}
               -> z < 0
               -> Rel r (y * z) (x * z)
               -> r x y
               -> r (y * z) (x * z)
multNegRight p r =
  |> rel r x y
  <> rel r (z * y) (z * x) ... multNegLeft p
  <> rel r (y * z) (x * z) =.= pairMultCommutative

0 lemmaMult0 : {x,y,z : Integer} -> 0 === z -> x * z === y * z
lemmaMult0 prf = Calc $
  |~ x * z
  ~~ x * 0 ..< cong (x *) prf
  ~~ 0     ... multZeroRightAbsorbs
  ~~ y * 0 ..< multZeroRightAbsorbs
  ~~ y * z ... cong (y *) prf

||| Multiplication with a non-negative number weakens an inequality.
|||
||| ```idris example
||| |> x     <  y
||| <> x * z <= y * z ... multNonNegRight zgte0
||| ```
export
0 multNonNegRight :  {x,y,z : Integer}
                  -> 0 <= z
                  -> Rel (<=) (x * z) (y * z)
                  -> x < y
                  -> x * z <= y * z
multNonNegRight (Left p) r xy = Left $ multPosRight p (x * z < y * z) xy
multNonNegRight (Right p) r xy = Right $ lemmaMult0 p

||| Multiplication with a non-negative number weakens an inequality.
|||
||| ```idris example
||| |> x     <  y
||| <> z * x <= z * y ... multNonNegLeft zgte0
||| ```
export
0 multNonNegLeft :  {x,y,z : Integer}
                 -> 0 <= z
                 -> Rel (<=) (z * x) (z * y)
                 -> x < y
                 -> z * x <= z * y
multNonNegLeft p r =
  |> x < y
  <> x * z <= y * z ... multNonNegRight p
  <> z * x <= z * y =.= pairMultCommutative

||| Multiplication with a non-positive number weakens and
||| reverses an inequality.
|||
||| ```idris example
||| |> x     <  y
||| <> y * z <= x * z ... multNonPosRight zgte0
||| ```
export
0 multNonPosRight :  {x,y,z : Integer}
                  -> z <= 0
                  -> Rel (<=) (y * z) (x * z)
                  -> x < y
                  -> y * z <= x * z
multNonPosRight (Left p) r xy = Left $ multNegRight p (y * z < x * z) xy
multNonPosRight (Right p) r xy = Right $ lemmaMult0 (sym p)

||| Multiplication with a non-positive number weakens and
||| reverses an inequality.
|||
||| ```idris example
||| |> x     <  y
||| <> z * y <= z * x ... multNonPosLeft zlte0
||| ```
export
0 multNonPosLeft :  {x,y,z : Integer}
                 -> z <= 0
                 -> Rel (<=) (z * y) (z * x)
                 -> x < y
                 -> z * y <= z * x
multNonPosLeft p r =
  |> x < y
  <> y * z <= x * z ... multNonPosRight p
  <> z * y <= z * x =.= pairMultCommutative

0 smpLemma1 : {d,x,y : Integer} -> 0 < d -> d * x < d * y -> x < y
smpLemma1 dpos lt = case comp x y of
  LT p _ _ => p
  EQ _ p _ => void (EQ_not_LT (cong (d *) p) lt)
  GT _ _ p => void (GT_not_LT (multPosLeft dpos (d * x > d * y) p) lt)

0 smpLemma2 : {d,x,y : Integer} -> 0 < d -> d * x === d * y -> x === y
smpLemma2 dpos lt = case comp x y of
  LT p _ _ => void (LT_not_EQ (multPosLeft dpos (d * x < d * y) p) lt)
  EQ _ p _ => p
  GT _ _ p => void (GT_not_EQ (multPosLeft dpos (d * x > d * y) p) lt)

||| We can solve (in)equalities, where both sides have
||| been multiplied with the same positive value.
|||
||| ```idris example
||| |> z * x < z * y
||| <> x     < y     ... solveMultPosLeft zgt0
||| ```
export
0 solveMultPosLeft :  {d,x,y : Integer}
                   -> 0 < d
                   -> Rel r x y
                   -> r (d * x) (d * y)
                   -> r x y
solveMultPosLeft dpos (x < y)   lt         = smpLemma1 dpos lt
solveMultPosLeft dpos (x <= y)  (Left lt)  = Left $ smpLemma1 dpos lt
solveMultPosLeft dpos (x <= y)  (Right eq) = Right $ smpLemma2 dpos eq
solveMultPosLeft dpos (x === y) eq         = smpLemma2 dpos eq
solveMultPosLeft dpos (x >= y)  (Left lt)  = Left $ smpLemma1 dpos lt
solveMultPosLeft dpos (x >= y)  (Right eq) = Right $ smpLemma2 dpos eq
solveMultPosLeft dpos (x > y)   lt         = smpLemma1 dpos lt

||| We can solve (in)equalities, where both sides have
||| been multiplied with the same positive value.
|||
||| ```idris example
||| |> x * z < y * z
||| <> x     < y     ... solveMultPosRight zgt0
||| ```
export
0 solveMultPosRight :  {x,y,d : Integer}
                    -> 0 < d
                    -> Rel r x y
                    -> r (x * d) (y * d)
                    -> r x y
solveMultPosRight dpos r =
  |> rel r (x * d) (y * d)
  <> rel r (d * x) (d * y) =.= pairMultCommutative
  <> rel r x       y       ... solveMultPosLeft dpos

||| We can solve (in)equalities, where both sides have
||| been multiplied with the same negative value.
|||
||| ```idris example
||| |> z * x < z * y
||| <> y     < x     ... solveMultNegLeft zlt0
||| ```
export
0 solveMultNegLeft :  {d,x,y : Integer}
                   -> d < 0
                   -> Rel r y x
                   -> r (d * x) (d * y)
                   -> r y x
solveMultNegLeft dneg r =
  let negdPos = negateZero (neg d > 0) dneg
   in |> rel r (d * x) (d * y)
      <> rel r (neg (d * y)) (neg (d * x)) ... negate
      <> rel r (neg d * y) (neg d * x)     =.= (
           solve [d,y] (neg (d .*. y)) (neg (var d) *. y)
         , solve [d,x] (neg (d .*. x)) (neg (var d) *. x)
         )
      <> rel r y x ... solveMultPosLeft negdPos

||| We can solve (in)equalities, where both sides have
||| been multiplied with the same negative value.
|||
||| ```idris example
||| |> x * z < y * z
||| <> y     < y     ... solveMultNegLeft zlt0
||| ```
export
0 solveMultNegRight :  {x,y,d : Integer}
                    -> d < 0
                    -> Rel r y x
                    -> r (x * d) (y * d)
                    -> r y x
solveMultNegRight dneg r =
  |> rel r (x * d) (y * d)
  <> rel r (d * x) (d * y) =.= pairMultCommutative
  <> rel r y       x       ... solveMultNegLeft dneg

||| We can solve (in)equalities, with one side a multiplication
||| with a positive number and the other equalling zero.
|||
||| ```idris example
||| |> 0 < x * y
||| <> 0 < x     ... solveMultPosRightZero ygt0
||| ```
export
0 solveMultPosRightZero :  {x,y : Integer}
                        -> 0 < y
                        -> Rel r 0 x
                        -> r 0 (x * y)
                        -> r 0 x
solveMultPosRightZero pos r =
  |> rel r 0 (x * y)
  <> rel r (0 * y) (x * y) ~.. multZeroLeftAbsorbs
  <> rel r 0 x             ... solveMultPosRight pos

||| We can solve (in)equalities, with one side a multiplication
||| with a negative number and the other equalling zero.
|||
||| ```idris example
||| |> 0 < x * y
||| <> x < 0     ... solveMultNegRightZero ylt0
||| ```
export
0 solveMultNegRightZero :  {x,y : Integer}
                        -> y < 0
                        -> Rel r x 0
                        -> r 0 (x * y)
                        -> r x 0
solveMultNegRightZero neg r =
  |> rel r 0 (x * y)
  <> rel r (0 * y) (x * y) ~.. multZeroLeftAbsorbs
  <> rel r x 0             ... solveMultNegRight neg

||| We can solve (in)equalities, with one side a multiplication
||| with a positive number and the other equalling zero.
|||
||| ```idris example
||| |> 0 < x * y
||| <> 0 < y     ... solveMultPosLeftZero xgt0
||| ```
export
0 solveMultPosLeftZero :  {x,y : Integer}
                        -> 0 < x
                        -> Rel r 0 y
                        -> r 0 (x * y)
                        -> r 0 y
solveMultPosLeftZero pos r =
  |> rel r 0 (x * y)
  <> rel r (x * 0) (x * y) ~.. multZeroRightAbsorbs
  <> rel r 0 y             ... solveMultPosLeft pos

||| We can solve (in)equalities, with one side a multiplication
||| with a negative number and the other equalling zero.
|||
||| ```idris example
||| |> 0 < x * y
||| <> y < 0     ... solveMultNegLeftZero xlt0
||| ```
export
0 solveMultNegLeftZero :  {x,y : Integer}
                        -> x < 0
                        -> Rel r y 0
                        -> r 0 (x * y)
                        -> r y 0
solveMultNegLeftZero neg r =
  |> rel r 0 (x * y)
  <> rel r (x * 0) (x * y) ~.. multZeroRightAbsorbs
  <> rel r y 0             ... solveMultNegLeft neg

||| We can solve (in)equalities, with one side a multiplication
||| with a positive number and the other equalling the positive
||| number.
|||
||| ```idris example
||| |> y < x * y
||| <> 1 < x     ... solveMultPosRightSelf ygt0
||| ```
export
0 solveMultPosRightSelf :  {x,y : Integer}
                        -> 0 < y
                        -> Rel r 1 x
                        -> r y (x * y)
                        -> r 1 x
solveMultPosRightSelf pos r =
  |> rel r y (x * y)
  <> rel r (1 * y) (x * y) ~.. multOneLeftNeutral
  <> rel r 1 x             ... solveMultPosRight pos

||| We can solve (in)equalities, with one side a multiplication
||| with a positive number and the other equalling the positive
||| number.
|||
||| ```idris example
||| |> x < x * y
||| <> 1 < y     ... solveMultPosLeftSelf xgt0
||| ```
export
0 solveMultPosLeftSelf :  {x,y : Integer}
                       -> 0 < x
                       -> Rel r 1 y
                       -> r x (x * y)
                       -> r 1 y
solveMultPosLeftSelf pos r =
  |> rel r x (x * y)
  <> rel r (x * 1) (x * y) ~.. multOneRightNeutral
  <> rel r 1 y             ... solveMultPosLeft pos

||| We can solve (in)equalities, with one side a multiplication
||| with a negative number and the other equalling the negative
||| number.
|||
||| ```idris example
||| |> y < x * y
||| <> x < 1     ... solveMultNegRightSelf ylt0
||| ```
export
0 solveMultNegRightSelf :  {x,y : Integer}
                        -> y < 0
                        -> Rel r x 1
                        -> r y (x * y)
                        -> r x 1
solveMultNegRightSelf neg r =
  |> rel r y (x * y)
  <> rel r (1 * y) (x * y) ~.. multOneLeftNeutral
  <> rel r x 1             ... solveMultNegRight neg

||| We can solve (in)equalities, with one side a multiplication
||| with a negative number and the other equalling the negative
||| number.
|||
||| ```idris example
||| |> x < x * y
||| <> y < 1     ... solveMultNegLeftSelf xlt0
||| ```
export
0 solveMultNegLeftSelf :  {x,y : Integer}
                        -> x < 0
                        -> Rel r y 1
                        -> r x (x * y)
                        -> r y 1
solveMultNegLeftSelf neg r =
  |> rel r x (x * y)
  <> rel r (x * 1) (x * y) ~.. multOneRightNeutral
  <> rel r y 1             ... solveMultNegLeft neg

--------------------------------------------------------------------------------
--          Division
--------------------------------------------------------------------------------

export
0 multDivP1 : {n,d : Integer} -> (0 < d) -> d * (div n d + 1) > n
multDivP1 dpos = App (snd $ modLT n d dpos) $
  |> mod n d               < d
  <> d * div n d + mod n d < d * div n d + d ... plusLeft
  <> n < d * (div n d + 1)                   =.= (
       lawDivMod n d %search
     , solve [n,d,div n d] (d .*. div n d +. d)
                           (d .* (div n d .+ 1))
     )

export
0 multDiv : {n,d : Integer} -> (0 < d) -> d * div n d <= n
multDiv dpos = App (fst $ modLT n d dpos) $
  |> 0 <= mod n d
  <> d * div n d + 0 <= d * div n d + mod n d ... plusLeft
  <> d * div n d     <= n                     =.= (
       plusZeroRightNeutral
     , lawDivMod n d %search
     )

export
0 divNonNeg : {n,d : Integer} -> (0 <= n) -> (0 < d) -> 0 <= div n d
divNonNeg ngte0 dpos = App (trans_GT_GTE (multDivP1 dpos) ngte0) $
  |> 0     <  d * (div n d + 1)
  <> 0     <  div n d + 1       ... solveMultPosLeftZero dpos
  <> 1     <= div n d + 1       ... (\_ => oneAfterZero _)
  <> 0     <= div n d           ... solvePlusRightSelf

export
0 modLTE : {n,d : Integer} -> (0 <= n) -> (0 < d) -> mod n d <= n
modLTE ngte0 dpos = App (divNonNeg ngte0 dpos) $
  |> 0               <= div n d
  <> d * 0           <= d * div n d           ... multPosLeft dpos
  <> d * 0 + mod n d <= d * div n d + mod n d ... plusRight
  <> mod n d         <= n                     =.= (
       solve [d, mod n d] (d .* 0 +. mod n d) (var (mod n d))
     , lawDivMod n d %search
     )

export
0 modOneIsZero : {n : Integer} -> mod n 1 === 0
modOneIsZero = assert_total $ case comp (mod n 1) 0 of
  EQ _ p _ => p
  LT p _ _ => void (LT_not_GTE p $ fst $ modLT n 1 %search)
  GT _ _ p => void (LT_not_GTE (snd $ modLT n 1 %search) (oneAfterZero _ p))

export
0 divOneSame : {n : Integer} -> div n 1 === n
divOneSame = assert_total $ Calc $
  |~ div n 1
  ~~ 1 * div n 1           ..< multOneLeftNeutral
  ~~ 1 * div n 1 + 0       ..< plusZeroRightNeutral
  ~~ 1 * div n 1 + mod n 1 ..< cong (1 * div n 1 +) modOneIsZero
  ~~ n                     ... lawDivMod n 1 %search

export
0 divGreaterOneLT : {n,d : Integer} -> 0 < n -> 1 < d -> div n d < n
divGreaterOneLT npos dgt1 =
  let dpos = the (0 < d) $ trans %search dgt1
   in assert_total $ case comp 0 (div n d) of
       EQ _ p _ => replace {p = (< n)} p npos
       LT p _ _ => App dgt1 $
         |> 1 < d
         <> 1 * div n d < d * div n d ... multPosRight p
         <> div n d     < d * div n d =.. multOneLeftNeutral
         <> div n d     < n           ... (\_ => trans_GTE_GT $ multDiv dpos)
       GT _ _ p => void (LT_not_GTE p $ divNonNeg %search dpos)

export
0 divPos : {n,d : Integer} -> (d <= n) -> (0 < d) -> 0 < div n d
divPos dn dp = assert_total $ case comp 0 (div n d) of
  LT p _ _ => p
  EQ _ p _ =>
    let modIsN = Calc $
          |~ mod n d
          ~~ 0 + mod n d             ..< plusZeroLeftNeutral
          ~~ (d * 0) + mod n d       ..< cong (+ mod n d) multZeroRightAbsorbs
          ~~ (d * div n d) + mod n d ... cong (\x => (d * x) + mod n d) p
          ~~ n                       ... lawDivMod n d (Right dp)
     in void (LTE_not_GT dn $ rewrite sym modIsN in snd (modLT n d dp))
  GT _ _ p => void (GT_not_LTE p (divNonNeg (Left $ trans_LT_LTE dp dn) dp))


module Main

import Data.Strings

%default total

readNum : HasIO io => io (Maybe Nat)
readNum = do putStr "Enter a number: "
             ns <- getLine
             case all isDigit (unpack ns) of
                  False => pure Nothing
                  True => pure $ Just (stringToNatOrZ ns)

addNums : HasIO io => io (Maybe Nat)
addNums = do Just n <- readNum
              | Nothing => do putStrLn "Error: first input is not a number"
                              pure Nothing
             Just m <- readNum
               | Nothing => do putStrLn "Error: second input is not a number"
                               pure Nothing
             pure $ Just (n + m)

main : HasIO io => io ()
main = do Just sum <- addNums
            | Nothing => pure ()
          printLn sum


module CFT.Zippers

import CFT
import Datatypes

namespace Zipper
  public export
  data ZList a = MkZipper (List a) (List a)

  moveRight : ZList a -> ZList a
  moveRight ls@(MkZipper xs []) = ls
  moveRight (MkZipper xs (x :: ys)) = MkZipper (x :: xs) ys

  moveLeft : ZList a -> ZList a
  moveLeft ls@(MkZipper [] ys) = ls
  moveLeft (MkZipper (x :: xs) ys) = MkZipper xs (x :: ys)

  cycleR : ZList a -> ZList a
  cycleR (MkZipper xs []) = MkZipper [] (reverse xs)
  cycleR (MkZipper xs (x :: ys)) = MkZipper (x :: xs) ys

namespace ZipperDesc
  public export
  TZip : {n : _} -> CFT (S n)
  TZip = TList * TList

  tMoveRight : Ty TZip (a :: t) -> Ty TZip (a :: t)
  tMoveRight (Pair x (In (Left Unit))) = Pair x (In (Left Unit))
  tMoveRight (Pair x (In (Right (Pair (Pop (Top y)) (Top z)))))  = Pair (cons y x) z

toList : Ty TList (a :: t) -> List (Ty a t)
toList (In (Left Unit)) = []
toList (In (Right (Pair (Pop (Top x)) (Top y)))) = x :: toList y

fromList : List (Ty a t) -> Ty TList (a :: t)
fromList [] = In (Left Unit)
fromList (x :: xs) = cons x (fromList xs)

pairInj : (f : Ty TList (a :: t) -> Ty TList (a :: t)) -> fromList (toList y) = y -> CFT.fromList (CFT.toList (f y)) = f y
pairInj f prf = ?pairInj_rhs

toFromList : (x : Ty (Mu (One + (VS VZ * VZ))) (a :: t)) -> fromList (toList x) = x
toFromList (In (Left Unit)) = Refl
toFromList (In (Right (Pair x (Top y)))) = let result = toFromList y in
                                             pairInj (In . Right . Pair x . Top) result

fromToList : (x : List (Ty a t)) -> CFT.toList (fromList x) = x
fromToList [] = Refl
fromToList (x :: xs) = let rec = fromToList xs in cong (x :: ) rec

ListTListIso : Iso (List (Ty a t)) (Ty TList (a :: t))
ListTListIso = MkIso
  { to = fromList
  , from = toList
  , toFrom = toFromList
  , fromTo = fromToList
  }

fromZList : ZList (Ty a t) -> Ty TZip (a :: t)
fromZList (MkZipper xs ys) = Pair (fromList xs) (fromList ys)

toZList : Ty TZip (a :: t) -> ZList (Ty a t)
toZList (Pair x y) = MkZipper (toList x) (toList y)

toFromZList : (x : Ty TZip (a :: t)) -> fromZList (toZList x) = x
toFromZList (Pair x y) = ?toFromZList_rhs_1

ZListTZipIso : Iso (ZList (Ty a t)) (Ty TZip (a :: t))
ZListTZipIso = MkIso
  { to = fromZList
  , from = toZList
  , toFrom = toFromZList
  , fromTo = ?aiod
  }

derive : {n : _} -> Fin n -> CFT n -> CFT n
derive FZ     VZ = One
derive (FS x) VZ = Zero
derive FZ     (VS y) = Zero
derive (FS x) (VS y) = Zero
derive n      (App f x) = App (derive (FS n) f) x
                        + App (derive FZ f) x * derive n x
derive n      Zero = Zero
derive n      One = Zero
derive n      (a + b) = derive n a + derive n b
derive n      (a * b) = derive n a * b + a * derive n b
derive n      (Mu f) = App TList (App (derive FZ f) (Mu f))
                     * App (derive (FS n) f) (Mu f)

DerivedList : CFT 1
DerivedList = derive FZ TList


module Control.Comonad

import Control.Monad.Identity

%access public export

--------------------------------------------------------------------------------
-- | Interfaces
--------------------------------------------------------------------------------

-- | `Comonad` extends the `Extend` class with the `extract` function
-- | which extracts a value, discarding the comonadic context.
-- |
-- | dual of |
-- | --------+----------
-- | Monad   | Comonad
-- | bind    | extend
-- | pure    | extract
-- | join    | duplicate

interface Functor w => Comonad (w : Type -> Type) where
  extract : w a -> a

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

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

interface Comonad w => VerifiedComonad (w : Type -> Type) where
  comonadLeftIdentity : (wx : w a) -> Control.Comonad.extract `extend` wx = wx
  comonadRightIdentity : (wx : w a) -> (f : w a -> b) -> extract (f `extend` wx) = f wx
  comonadAssociative : (wx : w a) -> (f : w b -> c) -> (g : w a -> b) ->
                       (extend f . extend g) wx = extend (f . extend g) wx

infixl 1 <<=
(<<=) : Comonad w => (w a -> b) -> w a -> w b
(<<=) = extend

-- | Forwards co-Kleisli composition
composeCoKleisli : Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
composeCoKleisli f g w = g (f <<= w)

infixl 1 =>=
(=>=) : Comonad w => (w a -> b) -> (w b -> c) -> w a -> c
(=>=) = composeCoKleisli

--------------------------------------------------------------------------------
-- | Functions
--------------------------------------------------------------------------------

liftW : Comonad w => (a -> b) -> w a -> w b
liftW f = extend (f . extract)

--------------------------------------------------------------------------------
-- | Implementations
--------------------------------------------------------------------------------

Comonad Identity where
  duplicate = Id
  extract = runIdentity

VerifiedComonad Identity where
  comonadLeftIdentity (Id runIdentity) = Refl
  comonadRightIdentity (Id runIdentity) f = Refl
  comonadAssociative (Id runIdentity) f g = Refl


%prefix_record_projections off

data T : Nat -> Type where
  MkT : (n : Nat) -> T n

record R where
  n : Nat
  x : T n


-- --------------------------------------------------------------- [ State.idr ]
-- Module      : Chapter.State
-- Description : Definitions from Chapter 12 of Edwin Brady's book,
--               "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Chapter.State

-- NOTE: See 12.1.3
import public Control.Monad.State

-- NOTE: See 12.3.6
import Data.Primitives.Views

-- ----------------------------------------- [ 12.1 Working with Mutable State ]

||| Attach labels from `lbls` to elements of `vals`.
||| @ lbls A stream of labels.
||| @ vals A list of values.
export
labelWith : (lbls : Stream labelType) -> (vals : List a) -> List (labelType, a)
labelWith lbls [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals

-- ---------------------------------- [ 12.1.1 Running Example: Tree Traversal ]

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

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

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

-- -------------------------- [ 12.1.2 Representing Mutable State using a Pair ]

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

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

-- ----------------- [ 12.1.3 State, a Type for Describing Stateful Operations ]

export
increase : Nat -> State Nat ()
increase inc = do current <- get
                  put (current + inc)

-- NOTE:
-- runState : StateT stateType Identity a -> stateType -> (a, stateType)
-- evalState : State stateType a -> stateType -> a
-- execState : State stateType a -> stateType -> stateType
-- get : MonadState stateType m => m stateType
-- put : MonadState stateType m => stateType -> m ()

-- ---------------------------------------- [ 12.1.4 Tree Traversal with State ]

namespace Stateful
  export
  treeLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
  treeLabelWith Empty = pure Empty
  treeLabelWith (Node left val right)
    = do leftLabelled <- treeLabelWith left
         -- Get the current stream of labels.
         (this :: rest) <- get
         -- Set the new stream of labels to be
         -- the tail of the current stream, rest.
         put rest
         rightLabelled <- treeLabelWith right
         pure (Node leftLabelled (this, val) rightLabelled)

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

-- ----------------------------------------------------------- [ Listing 12.13 ]

export
addIfPositive : Integer -> State Integer Bool
addIfPositive val = do let positive = val > 0
                       when positive $ update (+ val)
                       pure positive
  where
    update = (get >>=) . (put .)

export
addPositives : List Integer -> State Integer Nat
addPositives vals = do added <- traverse addIfPositive vals
                       pure (length (filter id added))

-- ---------------------------------------------------- [ 12.3.2 Complex State ]

public export
record Score where
       constructor MkScore
       correct, attempted : Nat

public export
record GameState where
       constructor MkGameState
       score : Score
       difficulty : Int

public export
implementation Show GameState where
  show st = show (record { score->correct } st) ++ " / " ++
            show (record { score->attempted } st) ++ "\n" ++
            "Difficulty: " ++ show (difficulty st)

export
initState : GameState
initState = MkGameState (MkScore 0 0) 12

-- ------------------------------------- [ 12.3.1 The Arithmetic Quiz Revisted ]

public export
data Command : Type -> Type where
     PutStr : String -> Command ()
     GetLine : Command String

     GetRandom : Command Int

     GetGameState : Command GameState

     PutGameState : GameState -> Command ()

     Pure : ty -> Command ty
     Bind : Command a -> (a -> Command b) -> Command b

public export
data ConsoleIO : Type -> Type where
     Quit : a -> ConsoleIO a
     Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b

namespace CommandDo

  public export
  (>>=) : Command a -> (a -> Command b) -> Command b
  (>>=) = Bind

namespace ConsoleDo

  public export
  (>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b
  (>>=) =  Do

public export
data Fuel = Dry | More (Lazy Fuel)

public export
partial
forever : Fuel
forever = More forever

-- ----------------------------------------------- [ 12.3.6 Executing the Quiz ]

export
runCommand : Stream Int ->
             GameState ->
             Command a ->
             IO (a, Stream Int, GameState)
runCommand rnds state (PutStr x) = do putStr x
                                      pure ((), rnds, state)
runCommand rnds state GetLine    = do str <- getLine
                                      pure (str, rnds, state)

runCommand (val :: rnds) state GetRandom =
  pure (getRandom val (difficulty state), rnds, state)
  where
    getRandom : Int -> Int -> Int
    getRandom val max with (divides val max)
      getRandom val 0             | DivByZero = 1
      getRandom ((_ * _) + rem) _ | DivBy prf = abs rem + 1

runCommand rnds state GetGameState            = pure (state, rnds, state)
runCommand rnds state (PutGameState newState) = pure ((), rnds, newState)

runCommand rnds state (Pure val) = pure (val, rnds, state)
runCommand rnds state (Bind c f) =
  do (res, newRnds, newState) <- runCommand rnds state c
     runCommand newRnds newState (f res)

export
run : Fuel -> Stream Int -> GameState -> ConsoleIO a ->
      IO (Maybe a, Stream Int, GameState)
run fuel rnds state (Quit val) = do pure (Just val, rnds, state)
run (More fuel) rnds state (Do cmd f) =
  do (res, newRnds, newState) <- runCommand rnds state cmd
     run fuel newRnds newState (f res)
run Dry rnds state _ = pure (Nothing, rnds, state)

-- ------------------------------------- [ 12.3.3 Updating Record Field Values ]

export
setDifficulty : Int -> GameState -> GameState
setDifficulty newDiff = record { difficulty = newDiff}

export
addWrong : GameState -> GameState
addWrong = record { score->attempted $= (+1) }

export
addCorrect : GameState -> GameState
addCorrect = record { score->correct   $= (+1)
                    , score->attempted $= (+1)
                    }

-- -------------------------------------------- [ 12.3.5 Implementing the Quiz ]

-- Copied from 11.3.3
public export
data Input = Answer Int
           | QuitCmd

mutual
  export
  correct : ConsoleIO GameState
  correct = do PutStr "Correct!\n"
               st <- GetGameState
               PutGameState (addCorrect st)
               quiz
  export
  wrong : Int -> ConsoleIO GameState
  wrong ans = do PutStr $ "Wrong, the answer is " ++ show ans ++ "\n"
                 st <- GetGameState
                 PutGameState (addWrong st)
                 quiz
  export
  readInput : (prompt : String) -> Command Input
  readInput prompt = do PutStr prompt
                        answer <- GetLine
                        if toLower answer == "quit"
                           then Pure QuitCmd
                           else Pure (Answer (cast answer))
  export
  quiz : ConsoleIO GameState
  quiz = do x <- GetRandom
            y <- GetRandom
            st <- GetGameState
            PutStr $ show st ++ "\n"
            let solution = x * y
            QuitCmd <- readInput $ show x ++ " * " ++ show y ++ "? "
              | Answer answer => if solution == answer
                                    then correct
                                    else wrong solution
            Quit st

-- ----------------------------------------------------------- [ Listing 12.32 ]

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

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


module TypeListToFunction

%default total

TypeListFun : List Type -> Type
TypeListFun [] = Unit
TypeListFun (x::xs) = x -> TypeListFun xs

typeListFun : (ts : List Type) -> TypeListFun ts
typeListFun [] = ()
typeListFun (_::xs) = \_ => typeListFun xs


import Data.List
import Data.Stream

-- the built in sort function is an implementation of merge sort (for now at least)

lincong : Integral a => a -> Stream a
lincong = tail . (iterate (\n => (1103515245 * n + 12345) `mod` 2147483648))

randishInts : Nat -> Integer -> List Integer
randishInts size seed = take size $ lincong seed

mylast : List a -> Maybe a
mylast [] = Nothing
mylast [x] = Just x
mylast (x::xs) = mylast xs

doSort : Nat -> IO ()
doSort Z     = putStrLn "Done"
doSort (S k) = do let xs = sort $ randishInts 12000 $ natToInteger k
                  -- get last elem to make sure compiler doesn't optimise away the sort
                  putStrLn $ show $ mylast xs
                  doSort k

main : IO ()
main = do max <- getLine
          doSort (integerToNat (cast max))


module Control.HigherOrder

infixr 0 ~>
infixr 0 ~~>

||| Type of natural transformations between two functors.
public export
0
(~>) : (Type -> Type) -> (Type -> Type) -> Type
f ~> g = forall a. f a -> g a

||| As above, but with explicit 0-morphisms.
public export
0
(~~>) : (Type -> Type) -> (Type -> Type) -> (Type -> Type)
(f ~~> g) a = f a -> g a

||| Higher-order functor, i.e. a functor
||| in the category of functors and natural transformations.
public export
interface HFunctor h where
  hmap : (Functor f, Functor g)
      =>   f ~>   g
      -> h f ~> h g

infixr 8 :+:

||| Higher-order disjoint union.
||| Effects are composed via this datatype.
public export
data (:+:) : (sig1 : (Type -> Type) -> (Type -> Type))
          -> (sig2 : (Type -> Type) -> (Type -> Type))
          -> (m : Type -> Type)
          -> (a : Type)
          -> Type where
  Inl : sig1 m a -> (:+:) sig1 sig2 m a
  Inr : sig2 m a -> (:+:) sig1 sig2 m a

public export
HFunctor sig1 => HFunctor sig2 => HFunctor (sig1 :+: sig2) where
  hmap t (Inl op) = Inl (hmap t op)
  hmap t (Inr op) = Inr (hmap t op)

||| Higher order projections.
||| Prj forms a category.
public export
interface Prj (0 sup : (Type -> Type) -> (Type -> Type))
              (0 sub : (Type -> Type) -> (Type -> Type)) | sub where
  constructor MkPrj
  prj : sup m a -> sub m a

||| Higher order injections.
||| Inj forms a category.
public export
interface Inj (0 sub : (Type -> Type) -> (Type -> Type))
              (0 sup : (Type -> Type) -> (Type -> Type)) | sub where
  constructor MkInj
  inj : sub m a -> sup m a

export
Prj sub' sub => Inj sub sup => Inj sub' sup where
  inj = inj . prj {sup = sub', sub}

namespace Inj
  ||| Identity injection.
  ||| Example: `a :+: b ↦ a :+: b`
  public export
  [S] Inj sig sig where
     inj = id

  ||| Inject to a Sum from the left.
  ||| Example: `a ↦ a :+: b`
  public export
  [L] Inj sig1 (sig1 :+: sig2) where
    inj = Inl

  ||| Inject to a Sum from the right.
  ||| Example: `b ↦ a :+: b`
  public export
  [R] Inj sig2 (sig1 :+: sig2) where
    inj = Inr

  ||| Composition of injections.
  ||| Example: `b ↦ (a :+: b) :+: c`
  public export
  [Trans] (inner : Inj siga sigb) => (outer : Inj sigb sigc) => Inj siga sigc where
    inj = inj {sub = sigb, sup = sigc}
        . inj {sub = siga, sup = sigb}

  ||| Same as `Trans`, but the two arguments are explicit.
  public export
  T : (inner : Inj siga sigb) -> (outer : Inj sigb sigc) -> Inj siga sigc
  T inner outer = Trans @{inner} @{outer}

||| State-preserving transformation of
||| a computation in one monad into a computation
||| in another monad, whose value is annotated with the final state.
||| Handler is a natural transformation.
public export
0
Handler : (Type -> Type)
       -> (Type -> Type)
       -> (Type -> Type)
       -> Type
Handler s m n = s . m ~> n . s

||| Handler with explicit 0-morphism.
public export
0
HandlerX : (Type -> Type)
        -> (Type -> Type)
        -> (Type -> Type)
        -> (Type -> Type)
HandlerX s m n = s . m ~~> n . s

public export
interface HFunctor sig => Syntax sig where
  ||| Extend the continuation.
  emap : forall m. (m a -> m b) -> (sig m a -> sig m b)
  ||| Generically thread a handler through a higher-order
  ||| signature.
  weave : (m1 : Monad m) => (m2 : Monad n) => (fs : Functor s)
       => s ()
       -> Handler s m n
       -> (sig m a -> sig n (s a))

public export
Syntax sig1 => Syntax sig2 => Syntax (sig1 :+: sig2) where
  emap f (Inl op) = Inl (emap f op)
  emap f (Inr op) = Inr (emap f op)

  weave s hdl (Inl op) = Inl (weave s hdl op)
  weave s hdl (Inr op) = Inr (weave s hdl op)

||| Lift a first-order functor to a second-order one.
public export
data Lift : (sig : (Type -> Type))
         -> ((Type -> Type) -> (Type -> Type)) where
  MkLift : sig (m a) -> Lift sig m a

public export
unlift : Lift sig m a -> sig (m a)
unlift (MkLift x) = x

||| Alias for use as an effect.
public export
LiftE : (sig : Type -> Type) -> (Type -> Type) -> (Type -> Type)
LiftE = Lift

public export
Functor sig => HFunctor (Lift sig) where
  hmap t (MkLift op) = MkLift (map t op)

public export
Functor sig => Syntax (Lift sig) where
  emap f (MkLift op) = MkLift (map f op)

  weave s hdl (MkLift op) = MkLift $
    map (\p => hdl (map (const p) s)) op

infixr 1 ~<~

-- hdl1 : ctxt1 . m ~> n . ctxt1
-- hdl2 : ctxt2 . l ~> m . ctxt2
-- ?    : (ctxt1 . ctxt2) . l ~> n . (ctxt1 . ctxt2)
--
--  (ctxt1 . ctxt2) . l ===
--  ctxt1 . (ctxt2 . l) ==>
--  ctxt1 . (m . ctxt2) ===
--  (ctxt1 . m) . ctxt2 ==>
--  (n . ctxt1) . ctxt2 ===
--  n . (ctxt1 . ctxt2)
||| Fuse two handlers.
public export
(~<~) : (f : Functor n)
     => (g : Functor ctx1)
     => (forall q. HandlerX ctx1 m n q)
     -> (forall t. HandlerX ctx2 l m t)
     -> (forall p. HandlerX (ctx1 . ctx2) l n p)
hdl1 ~<~ hdl2 = hdl1 . map hdl2


module Regex.Type

import Pruviloj.Core
import Pruviloj.Derive.DecEq

infixl 7 :.:
infixl 6 :|:
infixl 6 :&:

%default total

||| The type of regular expressions over a given token type.
public export
data Regex : Type where
  ||| The regular expression matching nothing
  Ø     : Regex
  ||| The regular expression matching an empty string
  Ɛ     : Regex
  ||| The regular expression matching a single token
  Tok   : Char -> Regex
  ||| Kleene star
  Star  : Regex -> Regex
  ||| Union of two regular expressions
  (:|:) : Regex -> Regex -> Regex
  ||| Complement of regular expressions
  Comp  : Regex -> Regex
  ||| Intersection of two regular expressions
  (:&:) : Regex -> Regex -> Regex
  ||| Sequence one regular expression after another
  (:.:) : Regex -> Regex -> Regex

||| Decidable equality on regular expressions
public export
regexDecEq : (r : Regex) -> (s : Regex) -> Dec (r = s)
%runElab (deriveDecEq `{regexDecEq})

implementation DecEq Regex where
  decEq a b = regexDecEq a b

-- implementation Functor Regex where
--   map f Ø         = Ø
--   map f Ɛ         = Ɛ
--   map f (Tok t)   = Tok (f t)
--   map f (Comp r)  = Comp (map f r)
--   map f (Star r)  = Star (map f r)
--   map f (r :|: s) = (map f r) :|: (map f s)
--   map f (r :&: s) = (map f r) :&: (map f s)
--   map f (r :.: s) = (map f r) :.: (map f s)


module Excercise_4_2

import Data.Vect

data PowerSource = Petrol | Pedal | Electricity

data Vehicle : PowerSource -> Type where
     Bicycle : Vehicle Pedal
     Car : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol
     Unicycle : Vehicle Pedal
     Motorcyle : (fuel : Nat) -> Vehicle Petrol
     Tram : Vehicle Electricity

wheels : Vehicle power -> Nat
wheels Bicycle = 2
wheels (Car fuel) = 4
wheels (Bus fuel) = 4
wheels Unicycle = 1
wheels (Motorcyle fuel) = 2
wheels Tram = 60

refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Car fuel) = Car 100
refuel (Bus fuel) = Bus 200
refuel Bicycle impossible
refuel Unicycle impossible
refuel (Motorcyle fuel) = Motorcyle 50
refuel Tram impossible

vectTake : (n : Nat) -> Vect (n + m) e -> Vect n e
vectTake Z xs = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys = case integerToFin pos n of
                                Nothing => Nothing
                                Just idx => Just ((index idx xs) + (index idx ys))


import Data.Either
import Data.List
import Data.List1
import Data.Maybe
import Data.String

import System.File

data BingoNum = M Nat | U Nat

Card : Type
Card = List (List BingoNum)

parseLines : (String -> Maybe a) -> String -> List a
parseLines f s = catMaybes $ f <$> lines s

getNumbers : List String -> Maybe (List Nat, List String)
getNumbers [] = Nothing
getNumbers (x :: xs) = Just (catMaybes $ parsePositive <$> (forget $ split (== ',') x),  xs)

parseCard : List String -> Card
parseCard l = (\s => U <$> (catMaybes $ parsePositive <$> (forget $ split (== ' ') s))) <$> l

parseCards : List String -> List Card
parseCards [] = []
parseCards (_ :: xs) = parseCard (take 5 xs) :: parseCards (drop 5 xs)

isMarked : BingoNum -> Bool
isMarked (M _) = True
isMarked (U _) = False

winRow : Card -> Bool
winRow [] = False
winRow (x :: xs) = all isMarked x || winRow xs

winColumn : Card -> Bool
winColumn c = any id $ foldl (\a => \bs => (\(b1, b2) => b1 && b2) <$> zip a (isMarked <$> bs)) (replicate 5 True) c

wins : List Card -> Maybe Card
wins [] = Nothing
wins (c :: cs) = if winRow c || winColumn c
                    then Just c
                    else wins cs

drawNumber : Nat -> Card -> Card
drawNumber n [] = []
drawNumber n (x :: xs) = ((\d => case d of
                                      M m => M m
                                      U u => if u == n
                                                then M u
                                                else U u) <$> x) :: drawNumber n xs

drawNumbers : List Nat -> List Card -> Maybe (Card, Nat)
drawNumbers [] cs = Nothing
drawNumbers (x :: xs) cs = let ncs = drawNumber x <$> cs in
                               case wins ncs of
                                    Just c => Just (c, x)
                                    Nothing => drawNumbers xs ncs

scoreOf : Card -> Nat
scoreOf [] = 0
scoreOf (x :: xs) = (foldl (\a => \b => case b of
                                             M n => a
                                             U n => n + a) 0 x) + scoreOf xs

run : String -> IO ()
run s = do let lines = lines s
           Just (ns, lines) <- pure $ getNumbers lines
             | Nothing => putStrLn $ "err"
           let cards = parseCards lines
           Just (win, n) <- pure $ drawNumbers ns cards
             | Nothing => putStrLn $ "no win"
           let score = n * scoreOf win
           putStrLn $ show $ score

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


import Data.Primitives.Views
import System

quiz : Stream Int -> (score : Nat) -> IO ()
quiz (num1 :: num2 :: nums) score
   = do putStrLn ("Score so far: " ++ show score)
        putStr (show num1 ++ " * " ++ show num2 ++ "? ")
        answer <- getLine
        if cast answer == num1 * num2
           then do putStrLn "Correct!"
                   quiz nums (score + 1)
           else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2))
                   quiz nums score

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

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

main : IO ()
main = do seed <- time
          quiz (arithInputs (fromInteger seed)) 0


module Uninh

data MyElem : a -> List a -> Type where
  MyHere : MyElem x (x :: xs)
  MyThere : (later : MyElem x xs) -> MyElem x (y :: xs)

noIndent : (MyElem a []) -> Void
noIndent c = ?noIndent_rhs

Uninhabited (MyElem a []) where
  uninhabited c = ?uninhabited_rhs


import Data.Vect

{- 1 -}

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

testMatrix : Matrix 2 3
testMatrix = [[0, 0, 0], [0, 0, 0]]


module PacketStruct
import IdrisNet.PacketLang
import Data.So

%access public

simpleStruct : PacketLang
simpleStruct = do
  cstring
  lstring 5
  p_either (bits 32) (lstring 4)
  listn 3 cstring
  b1 <- bool
  b2 <- bool
  prop (prop_or (prop_bool b2)
                (prop_bool b1))

myBoundedInt : Bounded 32
myBoundedInt = BInt 9001 Oh

simpleStructInstance : (mkTy simpleStruct)
simpleStructInstance = ("hello" ##
                        "world" ##
                        (Left myBoundedInt) ##
                        ["hello", "you", "dears"] ##
                        True ##
                        False ##
                        (Right Oh))

simpleResponse : PacketLang
simpleResponse = do
  cstring
  cstring

simpleResponseInstance : (mkTy simpleResponse)
simpleResponseInstance = "Got" ## "It!"


module Main

import Data.Primitives.Views

quiz : Stream Int -> (score : Nat) -> IO ()
quiz (n1 :: n2 :: ns) score = do
  putStrLn $ "Score so far: " ++ show score
  putStrLn (show n1 ++ " * " ++ show n2 ++ "?")
  answer <- getLine
  case answer of
    "quit" => do putStrLn "Bye!"
                 pure ()
    _ => if cast answer == n1 * n2
           then do putStrLn "Correct!"
                   quiz ns (score + 1)
           else do putStrLn ("Wrong, the answer is " ++ show (n1 * n2))
                   quiz ns score

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

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

main : IO ()
main = quiz (arithInputs 52816) 0


module Data.Bitraversable

import Control.Monad.Identity
import Data.Functor.Const
import Data.Morphisms

public export
bimapDefault : Bitraversable p => (a -> c) -> (b -> d) -> p a b -> p c d
bimapDefault f g = runIdentity . bitraverse (Id . f) (Id . g)

public export
bifoldrDefault : Bitraversable p =>
                 (a -> acc -> acc) -> (b -> acc -> acc) -> acc -> p a b -> acc
bifoldrDefault f g acc t =
  (applyEndo . getConst $ bitraverse (endo f) (endo g) t) acc
  where endo : forall x,y . (x -> y -> y) -> x -> Const (Endomorphism y) ()
        endo f = MkConst . Endo . f


module STLCInterp

data HasType : List a -> a -> Type where
  VZ : HasType (t :: env) t
  VS : HasType env t -> HasType (_ :: env) t

data Expr : List Type -> Type -> Type where
  Val : Int -> Expr env Int
  Var : HasType env t -> Expr env t
  Lam : Expr (a :: env) b -> Expr env (a -> b)
  App : Expr env (a -> b) -> Expr env a -> Expr env b

interpEnv : List Type -> Type
interpEnv [] = ()
interpEnv (x :: xs) = (x, interpEnv xs)

lookup : HasType env t -> interpEnv env -> t
lookup VZ (t, _) = t
lookup (VS x) (_, ts) = lookup x ts

eval : interpEnv env -> %static Expr env t -> t
eval env (Val x) = x
eval env (Var x) = lookup x env
eval env (Lam body) = \x => eval (x, env) body
eval env (App f x) = (eval env f) (eval env x)

example : Expr [] Int
example = App (Lam (Var VZ)) (Val 42)

test : Int
test = eval () example


module Collections.BSTree.Map

import Collections.BSTree.Map.Quantifiers
import Collections.Util.Bnd
import Collections.Util.Erased
import Data.Nat
import Data.Nat.Order.Strict
import Decidable.Order.Strict

import public Collections.BSTree.Map.Core

------------------
-- CONSTRUCTION --
------------------

||| The empty tree.
public export
empty : {0 rel : kTy -> kTy -> Type} ->
        {auto pre : StrictPreorder kTy rel} ->
        {auto tot : StrictOrdered kTy rel} ->
        BSTree rel {pre} {tot} vTy
empty = Empty BotLTTop

||| A tree with a single element.
public export
singleton : {0 rel : kTy -> kTy -> Type} ->
            {auto pre : StrictPreorder kTy rel} ->
            {auto tot : StrictOrdered kTy rel} ->
            (k : kTy) ->
            (v : vTy) ->
            BSTree rel {pre} {tot} vTy
singleton k v = Node k v (Empty BotLTMid) (Empty MidLTTop)

---------------
-- INSERTION --
---------------

insertWith' : {0 rel : kTy -> kTy -> Type} ->
              {pre : StrictPreorder kTy rel} ->
              {tot : StrictOrdered kTy rel} ->
              {0 mn,mx : Bnd kTy} ->
              (f : vTy -> vTy -> vTy) ->
              (k : kTy) ->
              (v : vTy) ->
              (0 bnds : (BndLT rel mn (Mid k), BndLT rel (Mid k) mx)) ->
              (t : BST pre tot vTy mn mx) ->
              BST pre tot vTy mn mx
insertWith' f x vX (lx, xu) (Empty _) = Node x vX (Empty lx) (Empty xu)
insertWith' {tot} f x vX (lx, xu) (Node y vY l r) =
  case order (Mid x) (Mid y) of
       DecLT xy   => Node y vY (insertWith' f x vX (lx, xy) l) r
       DecEQ Refl => Node x (f vX vY) l r
       DecGT yx   => Node y vY l (insertWith' f x vX (yx, xu) r)

||| Insert with a function, combining new value and old value. `insertWith f k v m` will insert
||| the pair `(k, v)` into `m` if `k` does not exist in the tree. If the key does exist, the
||| function will insert the pair `(k, f new_v old_v)`.
export
insertWith : {0 rel : kTy -> kTy -> Type} ->
             {pre : StrictPreorder kTy rel} ->
             {tot : StrictOrdered kTy rel} ->
             (f : vTy -> vTy -> vTy) ->
             (k : kTy) ->
             (v : vTy) ->
             BSTree rel {pre} {tot} vTy ->
             BSTree rel {pre} {tot} vTy
insertWith f k v t = insertWith' f k v (BotLTMid, MidLTTop) t

||| Insert a new key and value in the tree. If the key is already present in the tree, the
||| associated value is replaced with the supplied value.
export
insert : {0 rel : kTy -> kTy -> Type} ->
         {pre : StrictPreorder kTy rel} ->
         {tot : StrictOrdered kTy rel} ->
         (k : kTy) ->
         (v : vTy) ->
         BSTree rel {pre} {tot} vTy ->
         BSTree rel {pre} {tot} vTy
insert = insertWith const

--------------
-- QUERYING --
--------------

||| Is the tree empty?
export
null : BSTree rel {pre} {tot} vTy -> Bool
null (Empty _) = True
null (Node _ _ _ _) = False

size' : Nat -> (t: BST {rel} pre tot vTy mn mx) -> Nat
size' n (Empty _)      = n
size' n (Node _ _ l r) = size' (S (size' n l)) r

||| The number of elements in the tree.
export
size : BSTree rel {pre} {tot} vTy -> Nat
size t = size' 0 t where

member' : {0 rel : kTy -> kTy -> Type} ->
          {pre : StrictPreorder kTy rel} ->
          {tot : StrictOrdered kTy rel} ->
          (k : kTy) ->
          (t : BST pre tot vty mn mx) ->
          Bool
member'       k (Empty _)      = False
member' {tot} k (Node x v l r) = case order @{tot} k x of
                                      DecLT _ => member' k l
                                      DecEQ _ => True
                                      DecGT _ => member' k r

||| Is the key a member of the tree?
export
member : {0 rel : kTy -> kTy -> Type} ->
         {pre : StrictPreorder kTy rel} ->
         {tot : StrictOrdered kTy rel} ->
         (k : kTy) ->
         BSTree rel {pre} {tot} vTy ->
          Bool
member = member'

lookup' : {0 rel : kTy -> kTy -> Type} ->
          {pre : StrictPreorder kTy rel} ->
          {tot : StrictOrdered kTy rel} ->
          (k : kTy) ->
          (t : BST pre tot vTy mn mx) ->
          Maybe vTy
lookup'       k (Empty _)      = Nothing
lookup' {tot} k (Node x v l r) = case order @{tot} k x of
                                      DecLT _ => lookup' k l
                                      DecEQ _ => Just v
                                      DecGT _ => lookup' k r

||| Lookup the value at a key in the tree.
export
lookup : {0 rel : kTy -> kTy -> Type} ->
         {pre : StrictPreorder kTy rel} ->
         {tot : StrictOrdered kTy rel} ->
         (k : kTy) ->
         BSTree rel {pre} {tot} vTy ->
         Maybe vTy
lookup = lookup' where

lookupOr' : {0 rel : kTy -> kTy -> Type} ->
            {pre : StrictPreorder kTy rel} ->
            {tot : StrictOrdered kTy rel} ->
            (def : vTy) ->
            (k : kTy) ->
            (t : BST pre tot vTy mn mx) ->
            vTy
lookupOr'       def k (Empty _)      = def
lookupOr' {tot} def k (Node x v l r) = case order @{tot} k x of
                                            DecLT _ => lookupOr' def k l
                                            DecEQ _ => v
                                            DecGT _ => lookupOr' def k r

||| Returns the value at key `k` or returns default value `def` when the key is not in the tree.
export
lookupOr : {0 rel : kTy -> kTy -> Type} ->
           {pre : StrictPreorder kTy rel} ->
           {tot : StrictOrdered kTy rel} ->
           (def : vTy) ->
           (k : kTy) ->
           BSTree rel {pre} {tot} vTy ->
           vTy
lookupOr = lookupOr'

-----------------------
-- DELETION / UPDATE --
-----------------------

||| Deletes the leftmost element of a tree, returning the key/value of the deleted element,
||| the ordering proof of the key w.r.t. `mn`, and the updated tree.
deleteLeftmost : {0 rel : kTy -> kTy -> Type} ->
                 {pre : StrictPreorder kTy rel} ->
                 {tot : StrictOrdered kTy rel} ->
                 (t : BST pre tot vTy mn mx) ->
                 (prf : NonEmpty t) ->
                 (kv : (kTy, vTy) ** (Erased (BndLT rel mn (Mid (fst kv))),
                                     BST pre tot vTy (Mid (fst kv)) mx))
deleteLeftmost (Node k v (Empty mnk)     (Empty kmx)    ) IsNode =
  ((k, v) ** (MkErased mnk, Empty kmx))
deleteLeftmost (Node k v (Empty mnk)     r@(Node _ _ _ _)) IsNode =
  ((k, v) ** (MkErased mnk, r))
deleteLeftmost (Node k v l@(Node _ _ _ _) r               ) IsNode =
  let ((k', v') ** (mnk, l')) = deleteLeftmost l IsNode in
      ((k', v') ** (mnk, Node k v l' r))

delete' : {0 rel : kTy -> kTy -> Type} ->
          {pre : StrictPreorder kTy rel} ->
          {tot : StrictOrdered kTy rel} ->
          (k : kTy) ->
          (t : BST pre tot vTy mn mx) ->
          BST pre tot vTy mn mx
delete' x t@(Empty _) = t
delete' {pre} {tot} x (Node {mn} {mx} k v l r) =
  case order {spo=BndLT rel} (Mid x) (Mid k) of
       DecLT _    => Node k v (delete' x l) r
       DecEQ Refl =>
         case (l, r) of
              (Empty mnx,   Empty xmx      ) =>
                Empty $ transitive {rel=BndLT rel} {x=mn} {y=Mid x} {z=mx} mnx xmx
              (Empty mnx,   Node _ _ _ _     ) => extendMin mnx r
              (Node _ _ _ _, Empty xmx       ) => extendMax xmx l
              (Node _ _ _ _, r@(Node _ _ _ _)) =>
                let ((k', v') ** (MkErased xk, r')) = deleteLeftmost r IsNode in
                    Node k' v' (extendMax xk l) r'
       DecGT _    => Node k v l (delete' x r)

||| Delete a key and its value from the tree. When the key is not a member of the tree, the
||| original tree is returned.
export
delete : {0 rel : kTy -> kTy -> Type} ->
         {pre : StrictPreorder kTy rel} ->
         {tot : StrictOrdered kTy rel} ->
         (k : kTy) ->
         BSTree rel {pre} {tot} vTy ->
         BSTree rel {pre} {tot} vTy
delete = delete'

adjust' : {0 rel : kTy -> kTy -> Type} ->
          {pre : StrictPreorder kTy rel} ->
          {tot : StrictOrdered kTy rel} ->
          (f : vTy -> vTy) ->
          (k : kTy) ->
          BST pre tot vTy mn mx ->
          BST pre tot vTy mn mx
adjust'       f x t@(Empty _) = t
adjust' {tot} f x (Node k v l r) = case order @{tot} x k of
                                        DecLT _    => Node k v (adjust' f x l) r
                                        DecEQ Refl => Node k (f v) l r
                                        DecGT _    => Node k v l (adjust' f x r)

||| Update a value at a specific key with the result of the provided function. When the key is not
||| a member of the tree, the original tree is returned.
export
adjust : {0 rel : kTy -> kTy -> Type} ->
         {pre : StrictPreorder kTy rel} ->
         {tot : StrictOrdered kTy rel} ->
         (f : vTy -> vTy) ->
         (k : kTy) ->
         BSTree rel {pre} {tot} vTy ->
         BSTree rel {pre} {tot} vTy
adjust = adjust'

-----------
-- TESTS --
-----------

empty_isNull : null (empty {rel=LT} {vTy=Bool}) = True
empty_isNull = Refl

singleton_notNull : null (singleton {rel=LT} 2 False) = False
singleton_notNull = Refl

singleton_equivToInsertEmpty : singleton 5 'a' = insert 5 'a' (empty {rel=LT})
singleton_equivToInsertEmpty = Refl

member_missingKeyLeft_returnsFalse : member 1 (singleton {rel=LT} 2 'a') = False
member_missingKeyLeft_returnsFalse = Refl

member_missingKeyRight_returnsFalse : member 3 (singleton {rel=LT} 2 'a') = False
member_missingKeyRight_returnsFalse = Refl

member_keyInRoot_returnsTrue : member 2 (singleton {rel=LT} 2 'a') = True
member_keyInRoot_returnsTrue = Refl

member_keyInRight_returnsTrue : member 5 (insert 5 True (singleton {rel=LT} 2 False)) = True
member_keyInRight_returnsTrue = Refl

member_keyInLeft_returnsTrue : member 1 (insert 1 True (singleton {rel=LT} 2 False)) = True
member_keyInLeft_returnsTrue = Refl

lookup_keyExists_returnsJust : lookup 2 (insert 5 'b' (singleton {rel=LT} 2 'a')) = Just 'a'
lookup_keyExists_returnsJust = Refl

lookup_keyMissing_returnsNothing : lookup 9 (insert 5 'b' (singleton {rel=LT} 2 'a')) = Nothing
lookup_keyMissing_returnsNothing = Refl

lookupOr_keyExists_returnsValue : lookupOr 'c' 2 (insert 5 'a' (singleton {rel=LT} 2 'b')) = 'b'
lookupOr_keyExists_returnsValue = Refl

lookupOr_keyMissing_returnsDefault : lookupOr 'c' 9 (insert 5 'a' (singleton {rel=LT} 2 'b')) = 'c'
lookupOr_keyMissing_returnsDefault = Refl

delete_keyMissing_treeUnchanged : delete 1 (singleton {rel=LT} 2 'a') = singleton {rel=LT} 2 'a'
delete_keyMissing_treeUnchanged = Refl

delete_keyExists_removesKey : delete 2 (insert 1 'a' (singleton {rel=LT} 2 'b')) = singleton {rel=LT} 1 'a'
delete_keyExists_removesKey = Refl

adjust_keyMissing_treeUnchanged : adjust (\_ => 'b') 1 (singleton {rel=LT} 2 'a') = singleton {rel=LT} 2 'a'
adjust_keyMissing_treeUnchanged = Refl

adjust_keyExists_treeUpdated : adjust (\_ => 'c') 2 (insert 1 'a' (singleton {rel=LT} 2 'b')) =
                                insert 1 'a' (singleton {rel=LT} 2 'c')
adjust_keyExists_treeUpdated = Refl


module Hamming

import Data.Vect

public export
data Nucleotide = A | C | G | T

public export
implementation Eq Nucleotide where
  A == A = True
  C == C = True
  G == G = True
  T == T = True
  _ == _ = False

export
hamming_distance : Eq a => Vect n a -> Vect n a -> Nat
hamming_distance s1 s2 =
  fst $ filter ((/=) 0) $ map (\(n1,n2) => if n1 == n2 then 0 else 1) $ zip s1 s2

export
version : String
version = "1.0.0"


import Data.Vect

fourInts : Vect 4 Int
fourInts = [0,1,2,3]

||| The sum of both 4D vectors is an 8D vector
eightInts : Vect 8 Int
eightInts = fourInts ++ fourInts

total allLengths : Vect len String -> Vect len Nat
allLengths [] = []
allLengths (word :: words) = length word :: allLengths words

badLengthWithList : List String -> List Nat
badLengthWithList xs = []

badLengthWithVect : Vect n String -> Vect n Nat
badLengthWithVect xs = ?replace_with_empty_list_for_type_checking_error

anotherLengths : Vect length String -> Vect length Nat
anotherLengths [] = ?anotherLengths_rhs_1
anotherLengths (x :: xs) = ?anotherLengths_rhs_2


module Common.Felt

-- Idris2 does not support pattern matching on [external] types.
-- Do not declare public since it allows to write pattern matching code which does not work
export
data Felt : Type where [external]

public export %extern
prim__mk_Felt : Integer -> Felt

public export %extern
prim__from_Felt : Felt -> Integer

public export %extern
prim__add_Felt : Felt -> Felt -> Felt

public export %extern
prim__mul_Felt : Felt -> Felt -> Felt

public export %extern
prim__sub_Felt : Felt -> Felt -> Felt

public export %extern
prim__div_Felt : Felt -> Felt -> Felt

public export %extern
prim__eq_Felt : Felt -> Felt -> Bool

public export %inline
Eq Felt where
  (==) = prim__eq_Felt

public export %inline
Num Felt where
  (+) = prim__add_Felt
  (*) = prim__mul_Felt
  fromInteger = prim__mk_Felt

public export %inline
Neg Felt where
  negate x = assert_total $ prim__sub_Felt (fromInteger 0) x
  a - b = prim__sub_Felt a b

public export %inline
Integral Felt where
  div = prim__div_Felt
  mod _ _ = prim__mk_Felt 0 -- In a primefield divisions do not have a rest

public export %inline
Show Felt where
  show = show . prim__from_Felt

public export %inline
[PlusFeltSemi] Semigroup Felt using Semigroup.Additive where
  (<+>) x y = x + y

public export %inline
[MultFeltSemi] Semigroup Felt using Semigroup.Multiplicative where
  (<+>) x y = x * y

public export %inline
[PlusFeltMonoid] Monoid Felt using Monoid.Additive PlusFeltSemi where
  neutral = 0

public export %inline
[MultFeltMonoid] Monoid Felt using Monoid.Multiplicative MultFeltSemi where
  neutral = 1

{-
TODO: How to treat partiallity?

%inline
partial
public export
Integral Felt where
  div x y
      = case y == 0 of
             False => prim__div_Felt x y
  mod x y
      = case y == 0 of
             False => prim__mod_Felt x y

-}

public export %inline
Cast Bool Felt where
  cast True = 1
  cast False = 0


idF : a -> a
idF = id

extensionality : (f : a -> b) -> (g : a -> b) -> ((x : a) -> f x = g x) -> f = g
extensionality f g = believe_me

leftIdPoint : (f : a -> b) -> (x : a) -> idF (f x) = f x
leftIdPoint f x = Refl

leftId : (f : a -> b) -> (idF . f = f)
leftId f = ?hole


module Main

-- Required by usleep
import System

import Data.String

readNumber : IO (Maybe Nat)
readNumber = do
  input <- getLine
  if all isDigit (unpack input)
    then pure (Just (stringToNatOrZ input))
    else pure Nothing

total countDown : (secs : Nat) -> IO ()
countDown Z = putStrLn "Lift off!"
countDown (S secs) = do
  putStrLn (show (S secs))
  usleep 1000000
  countDown secs

partial countDowns : IO ()
countDowns = do
  putStr "Enter starting number: "
  Just startNum <- readNumber
    | Nothing => do putStrLn "Invalid input"
                    countDowns
  countDown startNum
  putStr "Another (y/n)? "
  yn <- getLine
  if yn == "y" then countDowns
               else pure ()


||| An expression language with mechanical proof of type-safety.
|||
||| `Tupled` is an expression language supporting Let-bindings, and
||| Tuples.  Standard constructions are used to represent the language
||| as an EDSL, together with proof of progress taken from PLFA Part
||| 2.
|||
||| This module compliments Section 3 of the Functional Pearl, but does
||| not appear due to similarities with `Razor.Recorded`.
|||
module Razor.Tupled

import Razor.Common

%default total

namespace Types

  public export
  data Ty = TyInt
          | TyChar
          | TyTuple (Vect (S n) Ty)

namespace Terms

  mutual
    ||| Fields in a Tuple.
    public export
    data Fields : (g     : List Ty)
               -> (types : Vect (S n) Ty)
               -> Type
      where
        Singleton : {ty    : Ty}
                 -> (field : Tupled g ty)
                          -> Fields g (ty::Nil)

        Extend : {ty    : Ty}
              -> {tys   : Vect (S n) Ty}
              -> (field : Tupled g ty)
              -> (rest  : Fields g      tys)
                       -> Fields g (ty::tys)

    public export
    data Tupled : List Ty -> Ty -> Type where
         -- Let-Bindings & Variables
          Var : Elem ty g -> Tupled g ty

          Let : (this     : Tupled        g  expr)
             -> (beInThis : Tupled (expr::g) body)
                         -> Tupled        g  body

          -- Base Values
          I : Int  -> Tupled g TyInt
          C : Char -> Tupled g TyChar

          -- Tuples & Accessors
          MkTuple : {types : Vect (S n) Ty}
                 -> (values : Fields g          types)
                           -> Tupled g (TyTuple types)

          Proj : {types : Vect (S n) Ty}
              -> (i     : Fin (S n))
              -> (tuple : Tupled g (TyTuple types))
              -> (idx   : AtIndex i types ty)
                       -> Tupled g ty

  public export
  index : {types  : Vect (S n) Ty}
       -> (fields : Fields  g types)
       -> (idx    : AtIndex i types ty)
                 -> Tupled  g       ty
  index (Singleton field) Here = field
  index (Extend field rest) Here = field

  index (Singleton _) (There Here) impossible
  index (Singleton _) (There (There later)) impossible

  index (Extend field rest) (There later)
    = index rest later

namespace Renaming

  public export
  weaken : (Contains  old           type -> Contains  new           type)
        -> (Contains (old += type') type -> Contains (new += type') type)

  weaken func Here         = Here
  weaken func (There rest) = There (func rest)

  mutual
    namespace Fields
      public export
      rename : (forall type  . Contains old type -> Contains new type)
            -> (forall types . Fields old types -> Fields new types)
      rename f (Singleton first)  = Singleton (rename f first)
      rename f (Extend next rest) = Extend (rename f next) (rename f rest)

    public export
    rename : (forall type . Contains old type -> Contains new type)
          -> (forall type . Tupled   old type -> Tupled   new type)
    -- Let-Bindings & Variables
    rename f (Var x) = Var (f x)
    rename f (Let this beInThis) = Let (rename f this)
                                       (rename (weaken f) beInThis)

    -- Base Values
    rename f (I x) = I x
    rename f (C x) = C x

    -- Tuples & Accessors
    rename f (MkTuple values)   = MkTuple (rename f values)
    rename f (Proj i tuple idx) = Proj i (rename f tuple) idx

namespace Substitution

  public export
  weakens : (forall type . Contains  old           type -> Tupled  new           type)
         -> (forall type . Contains (old += type') type -> Tupled (new += type') type)
  weakens f Here         = Var Here
  weakens f (There rest) = rename There (f rest)

  namespace General
    mutual
      namespace Fields
        public export
        subst : (f     : forall type . Contains old type -> Tupled new type)
             -> (forall types . Fields old types -> Fields new types)
        subst f (Singleton first) = Singleton (subst f first)
        subst f (Extend next rest) = Extend (subst f next) (subst f rest)

      public export
      subst : (forall type . Contains old type -> Tupled new type)
           -> (forall type . Tupled   old type -> Tupled new type)
      -- Let-Bindings & Variables
      subst f (Var x) = f x
      subst f (Let this beInThis) = Let (subst f this)
                                        (subst (weakens f) beInThis)

      -- Base Values
      subst f (I x) = I x
      subst f (C x) = C x

      -- Tuples & Accesors
      subst f (MkTuple values)   = MkTuple (subst f values)
      subst f (Proj i tuple idx) = Proj i (subst f tuple) idx

  namespace Single
    public export
    apply : (this   : Tupled ctxt typeB)
         -> (idx    : Contains (ctxt += typeB) typeA)
                   -> Tupled ctxt typeA
    apply this Here         = this
    apply this (There rest) = Var rest

    public export
    subst : (this   : Tupled  ctxt           typeB)
         -> (inThis : Tupled (ctxt += typeB) typeA)
                   -> Tupled  ctxt           typeA
    subst {ctxt} {typeA} {typeB} this inThis = General.subst (apply this) inThis

namespace Values
  mutual
    namespace Fields
      public export
      data Value : (fields : Fields g types) -> Type
        where
          SingletonV : (field : Value v) -> Value (Singleton v)
          ExtendV : {field  : Tupled ctxt type}
                 -> {fields : Fields ctxt types}
                 -> (next : Value field)
                 -> (rest : Value fields)
                         -> Value (Extend field fields)

    public export
    data Value : Tupled ctxt type -> Type where

      -- Base Values
      IV : Value (I i)
      CV : Value (C c)

      -- Tuples
      MkTupleV : Value fields
              -> Value (MkTuple fields)

namespace Reduction

  mutual
    namespace Fields
      public export
      data Redux : (this, that : Fields g types) -> Type where
          -- Single field.
          SimplifySingleton : (prf : Redux this that)
                                  -> Redux (Singleton this) (Singleton that)

          SimplifyExtend : {this, that : Tupled ctxt type}
                        -> {rest : Fields ctxt types}
                        -> (prf : Redux this that)
                        -> Redux (Extend this rest) (Extend that rest)

          SimplifyExtendV : {this, that : Fields ctxt types}
                         -> (value      : Values.Value v)
                         -> (rest       : Fields.Redux this that)
                                       -> Redux (Extend v this) (Extend v that)

    public export
    data Redux : (this, that : Tupled ctxt type) -> Type where
      -- Let Bindings
      SimplifyLetValue : Redux this that
                      -> Redux (Let this body)
                               (Let that body)
      ReduceLetBody : Value value
                   -> Redux (Let value body)
                            (subst value body)

      SimplifyTupleR : Redux this that
                    -> Redux (MkTuple this) (MkTuple that)

      -- Accessors
      SimplifyProj : {0  labels : Vect (S n) Ty}
                  -> {   this, that : Tupled g (TyTuple labels)}
                  -> {0  idx        : AtIndex i labels ty}
                  -> Redux this that
                  -> Redux (Proj i this idx) (Proj i that idx)

      ReduceProj : {types  : Vect (S n) Ty}
                -> {fields : Fields g types}
                -> {idx    : AtIndex i types type}
                -> (values : Value fields)
                    -> Redux (Proj i (MkTuple fields) idx)
                             (index fields idx)

namespace Progress

  public export
  data Progress : (term : Tupled Nil type) -> Type where
      Done : Value term -> Progress term
      Step : {this,that : Tupled Nil type} -> (step : Redux this that) -> Progress this

  namespace Fields
    public export
    data Progress : (fields : Fields Nil types) -> Type where
      Done : (value : Value fields) -> Progress fields
      Step : {this,that : Fields Nil types} -> (step  : Redux this that) -> Progress this

  mutual
    namespace Fields
      public export
      progress : (fields : Fields Nil types) -> Progress fields
      progress (Singleton first) with (progress first)
        progress (Singleton first) | (Done x) = Done (SingletonV x)
        progress (Singleton first) | (Step prf) = Step (SimplifySingleton prf)

      progress (Extend next rest) with (progress next)
        progress (Extend next rest) | (Done x) with (progress rest)
          progress (Extend next rest) | (Done x) | (Done xs)  = Done (ExtendV x xs)
          progress (Extend next rest) | (Done x) | (Step prf) = Step (SimplifyExtendV x prf)

        progress (Extend next rest) | (Step prf) = Step (SimplifyExtend prf)

    public export
    progress : (term : Tupled Nil type) -> Progress term
    progress (Var Here) impossible

    -- Let-Bindings & Variables
    progress (Var _) impossible
    progress (Let this beInThis) with (progress this)
      progress (Let this beInThis) | (Done x) = Step (ReduceLetBody x)
      progress (Let this beInThis) | (Step prf) = Step (SimplifyLetValue prf)

    -- Base Values
    progress (I x) = Done IV
    progress (C x) = Done CV

    -- Tuples & Accessors
    progress (MkTuple values) with (progress values)
      progress (MkTuple values) | (Done v)   = Done (MkTupleV v)
      progress (MkTuple values) | (Step prf) = Step (SimplifyTupleR prf)

    progress (Proj i tuple idx) with (progress tuple)
      progress (Proj i (MkTuple fields) idx) | (Done (MkTupleV x)) = Step (ReduceProj x)
      progress (Proj i tuple idx) | (Step prf) = Step (SimplifyProj prf)

namespace Evaluation

  public export
  data Reduces : (this : Tupled ctxt type)
              -> (that : Tupled ctxt type)
              -> Type
    where
      Refl  : {this : Tupled ctxt type}
                   -> Reduces this this
      Trans : {this, that, end : Tupled ctxt type}
           -> Redux this that
           -> Reduces that end
           -> Reduces this end

  public export
  data Finished : (term : Tupled ctxt type)
                       -> Type
    where
      Normalised : {term : Tupled ctxt type} -> Value term -> Finished term
      OOF : Finished term

  public export
  data Steps : (term : Tupled Nil type) -> Type where
    MkSteps : {this, that : Tupled Nil type}
           -> (steps  : Inf (Reduces this that))
           -> (result : Finished that)
           -> Steps this

  public export
  data Fuel = Empty | More (Lazy Fuel)

  public export
  covering
  forever : Fuel
  forever = More forever

  public export
  compute : (fuel : Fuel)
         -> (term : Tupled Nil type)
         -> Steps term
  compute Empty term = MkSteps Refl OOF
  compute (More fuel) term with (progress term)
    compute (More fuel) term | (Done value) = MkSteps Refl (Normalised value)
    compute (More fuel) term | (Step step {that}) with (compute fuel that)
      compute (More fuel) term | (Step step {that = that}) | (MkSteps steps result)
        = MkSteps (Trans step steps) result

public export
covering
run : (this : Tupled Nil type)
           -> Maybe (Subset (Tupled Nil type) (Reduces this))
run this with (compute forever this)
  run this | (MkSteps steps (Normalised {term} x)) = Just (Element term steps)
  run this | (MkSteps steps OOF) = Nothing

namespace Examples
    public export
    abc : Tupled Nil (TyTuple [TyInt, TyChar, TyChar])
    abc = MkTuple (Extend (I 1) (Extend (C 'c') (Singleton (C '2'))))

    public export
    a : Tupled Nil (TyInt)
    a = Proj FZ abc Here

    public export
    b : Tupled Nil (TyChar)
    b = Proj (FS FZ) abc (There Here)


module Frees

import Control.Monad.Freer
import Debug.Trace
import Control.Monad.State
import Control.Monad.Writer
import System
data Tensor : Type where
  DoubleT : Double -> Tensor

implementation Show Tensor where
  show (DoubleT x) = show x

data GraphData : Type -> Type where
  Mul : Tensor -> Tensor -> GraphData Tensor
  Placeholder : GraphData Tensor
  Constant : Double -> GraphData Tensor

FreeGraph : Type --type of computation graph ,freer graph
FreeGraph = Freer GraphData Tensor

mulG : FreeGraph
mulG = do
  x<-liftF $ Constant 2
  y<-liftF $ Constant 3
  liftF $ Mul x y

st : State String Int
st = ST (\str => Id (1, str++"1,"))

stm : State String Int
stm = do
  st
  st

free2state : {x : Type} -> GraphData x -> State String x
free2state (Mul (DoubleT x) (DoubleT y)) = ST (\str => Id (DoubleT $ x*y, str++"mul"))
free2state Placeholder = ST (\str => Id (DoubleT $ 0.0, str++"Placeholder,"))
free2state (Constant x) = ST (\str => Id (DoubleT $ x, str++"Constant,"))

free2li : {x : Type} -> GraphData x -> List x
free2li (Mul (DoubleT x) (DoubleT y)) = pure $ DoubleT $ x*y
free2li Placeholder = pure $ DoubleT 1
free2li (Constant x) = [DoubleT 1,DoubleT x]

free2w : {x : Type} -> GraphData x -> Writer String x
free2w (Mul (DoubleT x) (DoubleT y)) = do
  tell "(Mul (DoubleT x) (DoubleT y))"
  pure $ DoubleT $ x*y
free2w Placeholder = do
  tell "Placeholder"
  pure $ DoubleT 1
free2w (Constant x) = do
  tell "(Constant x)"
  pure $ DoubleT x

f2st : State String Tensor
f2st = foldFreer free2state mulG

data Sess : Type where
  Loginfo : String->String->Sess

data SessData : Type -> Type where
  GetSess : SessData Sess

SessGraph : Type --type of computation graph ,freer graph
SessGraph = Freer SessData Sess

implicit liftd : SessData Sess -> SessGraph
liftd = liftF

sess1 : SessGraph
sess1 = do
  x<-GetSess
  GetSess


module Main
import System

readNumber : IO (Maybe Nat)
readNumber = do
  input <- getLine
  if all isDigit (unpack input)
     then pure (Just (cast input))
     else pure Nothing

readNumbers : IO (Maybe (Nat, Nat))
readNumbers =
  do Just num1_ok <- readNumber
     Just num2_ok <- readNumber
     pure (Just (num1_ok, num2_ok))

guess : (target : Nat) -> (guesses : Nat) -> IO ()
guess target guesses = do putStr ("Guess the number (" ++ show guesses ++ " guesses so far): ")
                          Just startNum <- readNumber | Nothing => do putStrLn "Invalid input"
                                                                      guess target guesses
                          case compare startNum target of
                             LT => do putStrLn "Too low"
                                      guess target (S guesses)
                             EQ => do putStrLn ("You finally got it: " ++ show target ++ " (after " ++ show guesses ++ " tries)")
                                      pure ()
                             GT => do putStrLn "Too high"
                                      guess target (S guesses)

main : IO ()
main = do rand <- time
          let randy = cast (mod rand 100)
          guess randy 0


module Main

import Vec3
import Ray
-- import shapes.Sphere
import Hittable

aspectRatio : Double
aspectRatio = 16.0 / 9.0

width : Int
width = 400

height : Int
height = cast (cast width / aspectRatio)

-- World
world : List (Sphere)
world = [
    MkSphere (0, 0, -1) 0.5,
    MkSphere (0, -100.5, -1) 100
]

viewport_height : Double
viewport_height = 2.0

viewport_width : Double
viewport_width = aspectRatio * viewport_height

focalLength : Double
focalLength = 1.0

origin : Vec3
origin = (0.0, 0.0, 0.0)

horizontal : Vec3
horizontal = (viewport_width, 0.0, 0.0)

vertical : Vec3
vertical = (0.0, viewport_height, 0.0)

lower_left_corner : Vec3
lower_left_corner = origin - horizontal/2 - vertical/2 - (0.0, 0.0, focalLength)

rayColor : Ray -> HittableList -> Vec3
rayColor ray world =
        let hit' = hit world ray 0.0 99999
        in
            if isHitted hit'
                then
                    0.5 * (normal hit' + (1, 1, 1))
                else
                    (1.0 - t) * (1.0, 1.0, 1.0) + t * (0.5, 0.7, 1.0)
                    where
                        direction : Vec3
                        direction = unitVector (dir ray)
                        t         = 0.5 * (getY direction + 1.0)

pixelColor : Int -> Int -> Vec3
pixelColor h w =
    rayColor (MkRay origin (lower_left_corner + (cast h / (cast width-1)) * horizontal + (cast w / (cast height-1)) * vertical - origin)) Main.world

writeColor : Vec3 -> Vec3
writeColor v = 255.999 * v

-- //TODO: seg fault !!!
createImg : Int -> Int -> List (Vec3)
createImg w h = [writeColor $ pixelColor j i | i <- [(h - 1)..0], j <- [1..w]]

main : IO ()
main = do putStrLn $ concat ["P3\n", show width, " ", show height, "\n255\n"]
          traverse putStrLn (map vecToStr $ createImg width height)
          pure ()


module Parser

import Lightyear
import Control.Monad.Identity
import Lexer
import Syntax

public export
Parser : Type -> Type
Parser = ParserT (List Lexeme) Identity

is : (Monad m, Stream tok str, Eq tok)
     => tok
     -> ParserT str m tok
is l = satisfy (== l)

implementation Stream Lexeme (List Lexeme) where
  uncons []        = Nothing
  uncons (x :: xs) = Just (x, xs)

E : Type
E = Expr

infixOp : Lexeme -> (a -> a -> a) -> Parser (a -> a -> a)
infixOp l ctor = do
  _ <- satisfy (== l)
  pure ctor

addOp : Parser (E -> E -> E)
addOp = infixOp PLUS Plus <|> infixOp MINUS Minus

mulOp : Parser (E -> E -> E)
mulOp = infixOp TIMES Times

boolOp : Parser (E -> E -> E)
boolOp = infixOp EQUAL Equal <|> infixOp LESS Less

tyOp : Parser (Ty -> Ty -> Ty)
tyOp = infixOp TARROW TArrow

-- Actually no "operator" here. Function application is just juxtaposition.
applyOp : Parser (E -> E -> E)
applyOp = pure Apply

isInt : Lexeme -> Bool
isInt (INT n) = True
isInt _       = False

int : Parser Expr
int = do
  (INT i) <- satisfy isInt
  pure (EInt i)

neg : Parser Expr
neg = do
  _ <- is MINUS
  (EInt i) <- int
  pure $ EInt (-i)

lparen : Parser Lexeme
lparen = is LPAREN

rparen : Parser Lexeme
rparen = is RPAREN

semicolon2 : Parser Lexeme
semicolon2 = is SEMICOLON2

true : Parser Expr
true = is TRUE *> pure (EBool True)

false : Parser Expr
false = is FALSE *> pure (EBool False)

isVar : Lexeme -> Bool
isVar (VAR _) = True
isVar _         = False

nm : Parser Name
nm = do
  (VAR nm) <- satisfy isVar
  pure $ nm

var : Parser Expr
var = do
  name <- nm
  pure $ Var name

mutual
  def : Parser TopLevelCmd
  def = do
    _ <- is LET
    name <- nm
    _ <- is EQUAL
    e <- expr
    pure $ TopDef name e

  expr : Parser Expr
  expr = boolean

  boolean : Parser Expr
  boolean = arith `chainl1` boolOp

  arith : Parser Expr
  arith = term `chainl1` addOp

  term : Parser Expr
  term = factor `chainl1` mulOp

  ifExpr : Parser Expr
  ifExpr = do
    _ <- is IF
    c <- expr
    _ <- is THEN
    t <- expr
    _ <- is ELSE
    f <- expr
    pure $ If c t f

  ty : Parser Ty
  ty = tyFactor `chainr1` tyOp

  tyFactor : Parser Ty
  tyFactor = (is TBOOL *> pure TBool)
         <|> (is TINT  *> pure TInt)
         <|> (lparen *>| ty <*| rparen)

  fun : Parser Expr
  fun = do
    _ <- is FUN
    funName <- nm
    _ <- lparen
    parName <- nm
    _ <- is COLON
    parTy <- ty
    _ <- rparen
    _ <- is COLON
    resTy <- ty
    _ <- is IS
    body <- expr
    pure $ Fun funName parName parTy resTy body

  factor : Parser Expr
  factor = (nonApp `chainl1` applyOp)
       <|> ifExpr
       <|> fun

  nonApp : Parser Expr
  nonApp = var
       <|> true
       <|> false
       <|> int
       <|> (lparen *>| expr <*| rparen)

export
toplevel : Parser (List TopLevelCmd)
toplevel = do
  cmd <- TopExpr <$> expr <|> def
  esOpt <- opt (semicolon2 *> toplevel)
  _ <- opt semicolon2
  pure $ cmd :: case esOpt of
    Just es => es
    None    => []

{-
toplevel ::=
  | EOF
  | def EOF
  | def ";;" EOF
  | expr EOF
  | expr ";; EOF
  | def ";;" toplevel
  | expr ";; toplevel

def ::= LET VAR EQUAL expr

expr ::=
  | non_app
  | app
  | arith
  | boolean
  | IF expr THEN expr ELSE expr
  | FUN VAR "(" VAR ":" ty ")" ":" ty IS expr

app ::=
  | app non_app -- huh?
  | non_app non_app

non_app ::=
  | VAR
  | TRUE
  | FALSE
  | INT
  | "(" expr ")"

arith ::=
  | MINUS INT
  | expr PLUS expr
  | expr MINUS expr
  | expr TIMES expr

boolean ::=
  | expr EQUAL expr
  | expr LESS expr

ty ::=
  | TBOOL
  | TINT
  | ty "->" ty
  | "(" ty ")"
-}


public export
data InfList : Type -> Type where
  (::) : (value : elem) -> Inf (InfList elem) -> InfList elem

Functor InfList where
    map func (value :: xs) = func value :: Delay (map func xs)

%name InfList xs, ys, zs


ff : (a -> b) -> Not (Not a) -> Not (Not b)
ff ab nna nb = nna $ nb . ab


module InfIO

data InfIO : Type where
     Do : IO a
          -> (a -> Inf InfIO)
          -> InfIO

data Fuel = Dry | More (Lazy Fuel)

(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do

forever : Fuel
forever = More forever

tank : Nat -> Fuel
tank Z = Dry
tank (S k) = More $ tank k

run : Fuel -> InfIO -> IO ()
run Dry (Do action cont) = putStrLn "Out of fuel."
run (More x) (Do action cont) = action >>= \res => run x $ cont res

loopPrint : String -> InfIO
loopPrint m = Do (putStrLn m) (\_ => loopPrint m)

lp : String -> InfIO
lp m = do putStrLn m
          lp m


import Data.Vect

maryInVector : Elem "Mary" ["Peter", "Paul", "Mary"]
maryInVector = There (There Here)


module Main

simple : String
simple = "hello"

add : Nat -> Nat -> Nat
add (S k) y = S (add k y)
add Z     y = y

getType : Bool -> Type
getType True  = Integer
getType False = String

bla : (x : Bool) -> getType x
bla True  = 0
bla False = "false"

main : IO ()
main = do
  putStrLn ("one: "   ++ simple)
  putStrLn ("two: "   ++ x)
  putStrLn ("three: " ++ y)
    where
      x : String
      x = cast $ cast { to = Int } (add 1 5)

      y : String
      y = bla False


import Data.Primitives.Views
import System

%default total

data InfIO: Type where
  Do: IO a -> (a -> Inf InfIO) -> InfIO

(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

partial
forever: Fuel
forever = More forever

run: Fuel -> InfIO -> IO()
run Dry         y                = putStrLn "Out of fuel"
run (More fuel) (Do action cont) =
  do
    res <- action
    run fuel (cont res)

quiz : Stream Int -> (score: Nat) -> InfIO
quiz (num1 :: num2 :: nums) score =
  do
    putStrLn ("Score so far: " ++ show score)
    putStr   (show num1 ++ " * " ++ show num2 ++ "? ")
    answer <- getLine
    if cast answer == num1 * num2
      then do putStrLn "Correct!"
              quiz nums (score + 1)
      else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2))
              quiz nums score

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

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

partial
main : IO()
main =
  do
    seed <- time
    run forever (quiz (arithInputs (fromInteger seed)) 0)