module Data.Scientific

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

||| Arbitrary precision coefficient for scientific notation in base b.
||| Representants are unique regarding (==) and there are no trailing zeros.
||| For a coefficient x this holds:
|||   1 <= x < b
public export
data Coefficient : (b : Nat) -> Type where
  CoeffInt : Fin (S b) ->
             Coefficient (S (S b))
  CoeffFloat : Fin (S b) ->
               List (Fin (S (S b))) ->
               Fin (S b) ->
               Coefficient (S (S b))

public export
Uninhabited (Coefficient 0) where
  uninhabited _ impossible
public export
Uninhabited (Coefficient 1) where
  uninhabited _ impossible

public export
Eq (Coefficient b) where
  (CoeffInt x) == (CoeffInt y) = x == y
  (CoeffFloat x xs x') == (CoeffFloat y ys y') = x == y && xs == ys && x' == y'
  _ == _ = False

public export
Ord (Coefficient b) where
  compare (CoeffInt x) (CoeffInt y) = compare x y
  compare (CoeffInt x) (CoeffFloat y ys y') = case compare x y of
                                               EQ => LT
                                               comp => comp
  compare (CoeffFloat x xs x') (CoeffInt y) = case compare x y of
                                               EQ => GT
                                               comp => comp
  compare (CoeffFloat x xs x') (CoeffFloat y ys y') =
    compare (FS x :: xs `snoc` FS x') (FS y :: ys `snoc` FS y')

private
prettyShowDigit : Fin 10 -> Char
prettyShowDigit x =
  case x of
       0 => '0'
       1 => '1'
       2 => '2'
       3 => '3'
       4 => '4'
       5 => '5'
       6 => '6'
       7 => '7'
       8 => '8'
       9 => '9'

private
prettyShowCoefficient : Coefficient 10 -> String
prettyShowCoefficient (CoeffInt x) = pack [ prettyShowDigit (FS x) ]
prettyShowCoefficient (CoeffFloat x xs x') =
  pack $ [ prettyShowDigit (FS x), '.' ] ++ map prettyShowDigit xs ++ [ prettyShowDigit (FS x') ]

public export
data Sign = Positive
          | Negative

public export
Eq Sign where
  Positive == Positive = True
  Negative == Negative = True
  _ == _ = False

public export
Ord Sign where
  compare Positive Positive = EQ
  compare Positive Negative = GT
  compare Negative Positive = LT
  compare Negative Negative = EQ

private
prettyShowSign : Sign -> String
prettyShowSign s = case s of
                        Positive => ""
                        Negative => "-"

||| A scientific notation numeral in base b.
||| Representants are unique, as this type is built on top of Coefficient.
||| The numbers x represented are those which can be written as a finite sum of powers of b:
|||   x = \Sigma_{i=n}^m a_i * b^i          , {n,m : Integer; a_i : Fin b}
public export
data Scientific : (b : Nat) -> Type where
  SciZ : Scientific (S (S b))
  Sci : Sign ->
        Coefficient b ->
        Integer ->
        Scientific b

public export
Uninhabited (Scientific 0) where
  uninhabited (Sci _ _ _) impossible

public export
Uninhabited (Scientific 1) where
  uninhabited (Sci _ _ _) impossible

public export
Eq (Scientific b) where
  SciZ == SciZ = True
  (Sci s c e) == (Sci s' c' e') = s == s' && c == c' && e == e'
  _ == _ = False

public export
Ord (Scientific b) where
  compare SciZ SciZ = EQ
  compare SciZ (Sci s _ _) = case s of
                                  Positive => LT
                                  Negative => GT
  compare (Sci s _ _) SciZ = case s of
                                  Positive => GT
                                  Negative => LT
  compare (Sci s c e) (Sci s' c' e') =
    case (s, s') of
         (Positive, Positive) => case compare e e' of
                                      EQ => compare c c'
                                      comp => comp
         (Positive, Negative) => GT
         (Negative, Positive) => LT
         (Negative, Negative) => case compare e' e of
                                      EQ => compare c' c
                                      comp => comp

infixl 9 ^
private
(^) : Nat -> Nat -> Nat
x ^ Z = 1
x ^ (S k) = x * (x ^ k)

private
digitsToNat : {b : _} -> List (Fin (S (S b))) -> Nat
digitsToNat [] = 0
digitsToNat (x::xs) = finToNat x + (S (S b)) * digitsToNat xs

export
toInteger : {b : _} -> Scientific b -> Maybe Integer
toInteger SciZ = Just 0
toInteger (Sci s c e) =
  if e >= 0
     then case c of
               CoeffInt x => Just $ withSign $ finToNat (FS x) * (b ^ integerToNat e)
               CoeffFloat x xs x' => let digits = reverse $ (FS x) :: xs ++ [FS x']
                                         e' = e - natToInteger (length (xs ++ [FS x']))
                                     in if e' >= 0
                                           then Just $ withSign $ digitsToNat digits * (b ^ integerToNat e')
                                           else Nothing
     else Nothing
where
  withSign : Nat -> Integer
  withSign = case s of
                  Negative => negate . natToInteger
                  Positive => natToInteger

export
negate : Scientific b -> Scientific b
negate SciZ = SciZ
negate (Sci s c e) = let s' = case s of
                                   Positive => Negative
                                   Negative => Positive
                     in Sci s' c e

export
abs : Scientific b -> Scientific b
abs SciZ = SciZ
abs (Sci _ c e) = Sci Positive c e

-- TODO: What happens, when Integer is negative? Low priority, since this is private.
||| The digits of an Integer, least significant first.
private
integerDigits : {b : _} -> Integer -> List (Fin (S (S b)))
integerDigits 0 = []
integerDigits x = d :: integerDigits r where
  d : Fin (S (S b))
  d = restrict (S b) x
  r : Integer
  r = x `div` natToInteger (S (S b))

||| Remove the zeros near the head of a list.
private
removeLeadingZeros : List (Fin (S (S b))) -> Maybe (Fin (S b), List (Fin (S (S b))))
removeLeadingZeros [] = Nothing
removeLeadingZeros (FZ :: xs) = removeLeadingZeros xs
removeLeadingZeros (FS x :: xs) = Just (x, xs)

private
fromDigits : List (Fin (S (S b))) -> Scientific (S (S b))
fromDigits ys =
  case removeLeadingZeros $ reverse ys of
       Nothing => SciZ
       Just (x, ys') => case removeLeadingZeros $ reverse ys' of
                            Nothing => Sci Positive (CoeffInt x) (cast $ length ys')
                            Just (x', xs) => Sci Positive (CoeffFloat x (reverse xs) x') (cast $ length ys')

export
fromFin : Fin (S (S b)) -> Scientific (S (S b))
fromFin FZ = SciZ
fromFin (FS x) = Sci Positive (CoeffInt x) 0

export
fromInteger : {b : _} -> Integer -> Scientific (S (S b))
fromInteger x = if x < 0
                   then negate $ fromIntegerPositive x
                   else fromIntegerPositive x
where
  fromIntegerPositive : Integer -> Scientific (S (S b))
  fromIntegerPositive = fromDigits . integerDigits . abs

export
fromNat : {b : _} -> Nat -> Scientific (S (S b))
fromNat = fromInteger . natToInteger

||| Single bit full adder in base (S (S b)).
private
plusBit : (op : Sign) ->
          {b : _} ->
          (carry : Bool) ->
          Fin (S (S b)) ->
          Fin (S (S b)) ->
          ((Fin (S (S b))), Bool)
plusBit op False x FZ = (x, False)
plusBit Positive True x FZ = case strengthen $ FS FZ of
                                  Nothing => (FZ, True)
                                  Just z => (z, False)
plusBit Negative True x FZ = case x of
                                  FZ => (last, True)
                                  FS z => (weaken z, False)
plusBit Positive carry x (FS y) = case strengthen $ FS x of
                                       Nothing => (fst $ plusBit Positive carry FZ (weaken y), True)
                                       Just z => plusBit Positive carry z (weaken y)
plusBit Negative carry x (FS y) = case x of
                                       FZ => (fst $ plusBit Negative carry last (weaken y), True)
                                       FS z => plusBit Negative carry (weaken z) (weaken y)

||| N bit full adder in base (S (S b)).
export
plusBits : (op : Sign) ->
           {b : _} ->
           (carry : Bool) ->
           Vect n (Fin (S (S b))) ->
           Vect n (Fin (S (S b))) ->
           (Vect n (Fin (S (S b))), Bool)
plusBits op carry [] [] = ([], carry)
plusBits op carry (x :: xs) (y :: ys) =
  let (z, carry') = plusBit op carry x y
      (zs, sign) = plusBits op carry' xs ys
  in (z :: zs, sign)

-- TODO: Add NonEmpty to result type.
||| All bits of a Coefficient, least significant first.
export
coefficientBits : Coefficient (S (S b)) -> List (Fin (S (S b)))
coefficientBits (CoeffInt x) = [FS x]
coefficientBits (CoeffFloat x xs x') = reverse $ FS x :: xs ++ [FS x']

-- TODO: get a definiton like this working:
--equalizeLength : a ->
--                 (xs : List a) ->
--                 (ys : List a) ->
--                 (Vect (max (length xs) (length ys)) a, Vect (max (length xs) (length ys)) a)
private
equalizeLength : a ->
                (n : _) ->
                (xs : List a) ->
                (ys : List a) ->
                (Vect n a, Vect n a)
equalizeLength a Z _ _ = ([],[])
equalizeLength a (S k) [] [] = let (ps, qs) = equalizeLength a k [] []
                               in (a :: ps, a :: qs)
equalizeLength a (S k) [] (y::ys) = let (ps, qs) = equalizeLength a k [] ys
                                    in (a :: ps, y :: qs)
equalizeLength a (S k) (x::xs) [] = let (ps, qs) = equalizeLength a k xs []
                                    in (x :: ps, a :: qs)
equalizeLength a (S k) (x::xs) (y::ys) = let (ps, qs) = equalizeLength a k xs ys
                                         in (x :: ps, y :: qs)

||| Wrapper for plusBits, adding padding regarding the exponent and trailing zeros.
private
plusBits' : (op : Sign) ->
            {b : _} ->
            (List (Fin (S (S b))), Integer) ->
            (List (Fin (S (S b))), Integer) ->
            (List (Fin (S (S b))), Bool)
plusBits' op (xs,xe) (ys,ye) =
  let n = max (length xs) (length ys)
      (xs'', ys'') = equalizeLength FZ n xs' ys'
      (zs, overflow) = plusBits op False (reverse xs'') (reverse ys'')
  in (toList zs, overflow) where
    xs' : List (Fin (S (S b)))
    xs' = reverse $ xs ++ replicate (integerToNat ye `minus` integerToNat xe) FZ
    ys' : List (Fin (S (S b)))
    ys' = reverse $ ys ++ replicate (integerToNat xe `minus` integerToNat ye) FZ

-- TODO: remove this or removeLeadingZeros
private
removeLeadingZeros' : List (Fin (S (S b))) -> (Nat, Maybe (Fin (S b), List (Fin (S (S b)))))
removeLeadingZeros' [] = (Z, Nothing)
removeLeadingZeros' (FZ :: xs) = let (n, res) = removeLeadingZeros' xs
                                 in (S n, res)
removeLeadingZeros' (FS x :: xs) = (Z, Just (x, xs))

||| Requires the digits to be ordered, least significant first.
||| Returns Coefficient and number of significant zeros.
private
fromDigits' : List (Fin (S (S b))) -> (Maybe (Coefficient (S (S b))), Nat)
fromDigits' ys =
  let (n, removedLeading) = removeLeadingZeros' $ reverse ys
  in case removedLeading of
          Nothing => (Nothing, n)
          Just (x, ys') => case removeLeadingZeros $ reverse ys' of
                               Nothing => (Just (CoeffInt x), n)
                               Just (x', xs) => (Just (CoeffFloat x (reverse xs) x'), n)

export
(+) : {b : _} -> Scientific (S (S b)) -> Scientific (S (S b)) -> Scientific (S (S b))
SciZ + y = y
x + SciZ = x
x@(Sci s c e) + y@(Sci s' c' e') =
  let (zs, bit) = plusBits' op (xs, e) (ys, e')
  in case op of
          Positive => let s'' = s
                          bits = if bit then [FS FZ] else [FZ]
                      in case fromDigits' $ zs ++ bits of
                              (Nothing, _) => SciZ
                              (Just c'', bitShift) => let e'' = max e e' + 1 - natToInteger bitShift
                                                      in Sci s'' c'' e''
          Negative => let s'' = if bit then s' else s
                      in case fromDigits' zs of
                              (Nothing, _) => SciZ
                              (Just c'', bitShift) => let e'' = max e e' - natToInteger bitShift
                                                      in Sci s'' c'' e''
where
  op : Sign
  op = if s == s'
          then Positive
          else Negative
  xs : List (Fin (S (S b)))
  xs = coefficientBits c
  ys : List (Fin (S (S b)))
  ys = coefficientBits c'

(-) : {b : _} -> Scientific (S (S b)) -> Scientific (S (S b)) -> Scientific (S (S b))
x - y = x + negate y

-- TODO
||| Multiply two Coefficients and return True in the Bool, when the product is greater than the base.
private
multCoefficents : {b : _} -> Coefficient (S (S b)) -> Coefficient (S (S b)) -> (Coefficient (S (S b)), Bool)
multCoefficents (CoeffInt x) (CoeffInt y) =
  case integerToFin res (S b) of
       Nothing => (CoeffInt $ restrict b res, True)
       Just fin => (CoeffInt fin, False)
where
  res : Integer
  res = (finToInteger x + 1) * (finToInteger y + 1) - 1
multCoefficents a@(CoeffInt x) b@(CoeffFloat y ys y') = multCoefficents b a
-- TODO: finish multCoefficents
multCoefficents (CoeffFloat x xs x') (CoeffInt y) = ?multCoefficents_rhs_2
multCoefficents (CoeffFloat x xs x') (CoeffFloat y ys y') = ?multCoefficents_rhs_3

export
(*) : {b : _} -> Scientific (S (S b)) -> Scientific (S (S b)) -> Scientific (S (S b))
SciZ * y = SciZ
x * SciZ = SciZ
(Sci s c e) * (Sci s' c' e') = Sci s'' c'' e'' where
  coefficientPair : (Coefficient (S (S b)), Bool)
  coefficientPair = multCoefficents c c'
  s'' : Sign
  s'' = if s == s'
           then Positive
           else Negative
  c'' : Coefficient (S (S b))
  c'' = fst coefficientPair
  e'' : Integer
  e'' = if snd coefficientPair
           then e + e' + 1
           else e + e'

-- -- TODO: implementations don't work because the base (S (S b)) isn't accessible in the method's context.
-- -- TODO: consider other implementations:
-- -- - Fractional might not terminate, because of infinite representation
-- -- - Integral doesn't sound like it would fit, but mod and div make still make sense
-- public export
-- Num (Scientific b) where
--   -- (+) = (+)
--   -- (*) = (*)
--   -- fromInteger = fromInteger

-- public export
-- Neg (Scientific b) where
--   -- negate = negate
--   -- (-) = (-)

-- public export
-- Abs (Scientific b) where
--   -- abs = abs

||| Create string representing using scientific notation.
export
prettyShowScientific : Scientific 10 -> String
prettyShowScientific SciZ = "0"
prettyShowScientific (Sci s c e) = prettyShowSign s ++ prettyShowCoefficient c ++ prettyExponent where
  prettyExponent : String
  prettyExponent = case e of
                        0 => ""
                        x => "e" ++ show x


module Metamorphic

-- Based on https://bitbucket.org/josh-hs-ko/MetamorphismsInAgda/raw/master/MetamorphismsInAgda.pdf

data AlgList : (a : Type) -> {s : Type} -> (f : a -> s -> s) -> (e : s) -> s -> Type where
  Nil : AlgList a f e e
  (::) : (x : a) -> {st : s} -> AlgList a f e st -> AlgList a f e (f x st)

codata CoAlgList : (b : Type) -> {s : Type} -> (g : s -> Maybe (b, s)) -> s -> Type where
  Empty : {st : s} -> g st = Nothing -> CoAlgList b g st
  Cons : (x : b) -> {st, st' : s} -> g st = Just (x, st') -> CoAlgList b g st' -> CoAlgList b g st

testAlgList : AlgList Nat (\x, s => x + s) 0 3
testAlgList = 1 :: 1 :: 1 :: Nil

testCoAlgList : (st : Nat) -> CoAlgList Nat (\x => Just (x, S x)) st
testCoAlgList st = Cons st Refl (testCoAlgList (S st))

fromLeftAlg : {a, s : Type} -> (s -> a -> s) -> a -> (s -> s) -> (s -> s)
fromLeftAlg f a s = s . flip f a

parameters (a : Type, b : Type, s : Type, f : s -> a -> s, g : s -> Maybe (b, s),
            sc : {x : a} -> {y : b} -> {st, st' : s} -> g st = Just (y, st') -> g (f st x) = Just (y, f st' x))

  cbp : (st : s) -> {h : s -> s} -> AlgList a (fromLeftAlg f) (\x => x) h -> CoAlgList b g (h st)
  cbp s [] with (g s) proof prf
    cbp s [] | Nothing = Empty (sym prf)
    cbp s [] | Just (y, s') = Cons y (sym prf) (cbp s' [])
  cbp s (a :: as) = cbp (f s a) as

  lemma : {st : s} -> {y : b} -> {st' : s} -> {h : s -> s} -> AlgList a (fromLeftAlg f) (\x => x) h -> g st = Just (y, st') -> g (h st) = Just (y, h st')
  lemma [] eq = eq
  lemma (a :: as) eq = lemma as (sc eq)

  stream : (st : s) -> {h : s -> s} -> AlgList a (fromLeftAlg f) (\x => x) h -> CoAlgList b g (h st)
  stream s as with (g s) proof prf
    stream s [] | Nothing  = Empty (sym prf)
    stream s (a :: as) | Nothing  = stream (f s a) as
    stream s as | Just (y, s') = Cons y (lemma as (sym prf)) (stream s' as)


-- WordLength.idr
--

import Data.Vect

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


||| An open union implementation as first introduced
||| in chapter *Predicates and Proof Search*
module Data.Union

import Data.Vect

%default total

--------------------------------------------------------------------------------
--          Predicates
--------------------------------------------------------------------------------

||| Predicate witnessing that a value is an element
||| of a vector.
public export
data Has : (v : a) -> (vs : Vect n a) -> Type where
  Z : Has v (v :: vs)
  S : Has v vs -> Has v (w :: vs)

||| Predicate witnessing that a value is an element
||| of a vector and listing the result of removing
||| said element from the vector.
public export
data Rem : (v : a) -> (vs : Vect (S n) a) -> (rem : Vect n a) -> Type where
  [search v vs]
  RZ : Rem v (v :: vs) vs
  RS : Rem v vs rem -> Rem v (w :: vs) (w :: rem)

--------------------------------------------------------------------------------
--          Union
--------------------------------------------------------------------------------

||| An *open union*, holding a single value of one
||| of the types listed in the index.
public export
data Union : (ts : Vect n Type) -> Type where
  U : (prf : Has t ts) -> (v : t) -> Union ts

||| Inject a value into an open union.
public export
inj : (v : t) -> Has t ts => Union ts
inj v = U %search v

--------------------------------------------------------------------------------
--          Decomposing Unions
--------------------------------------------------------------------------------

projImpl : Has t1 ts -> Has t2 ts -> t2 -> Maybe t1
projImpl Z     Z     v = Just v
projImpl (S x) (S y) v = projImpl x y v
projImpl Z     (S _) _ = Nothing
projImpl (S _)  Z    _ = Nothing

||| Try to extract a value of the given type
||| from a union.
public export
proj : (0 t : Type) -> Has t ts => Union ts -> Maybe t
proj _ (U ix v) = projImpl %search ix v

||| Like `proj` but with an implicit type argument.
public export
proj' : Has t ts => Union ts -> Maybe t
proj' = proj t

||| Decomposes a union: Either returns a value
||| of the given type or a new union where the
||| given type is no longer in the index.
public export
decomp :  (0 t : Type)
       -> (prf : Rem t ts rem )
       => Union ts
       -> Either t (Union rem)
decomp _ {prf = RZ}   (U Z v)     = Left v
decomp _ {prf = RZ}   (U (S x) v) = Right (U x v)
decomp _ {prf = RS x} (U Z v)     = Right (U Z v)
decomp t {prf = RS x} (U (S y) v) = case decomp t (U y v) of
  Left z          => Left z
  Right (U prf z) => Right (U (S prf) z)

||| Like `decomp` but with an implicit type argument.
public export
decomp' : Rem t ts rem => Union ts -> Either t (Union rem)
decomp' = decomp t

--------------------------------------------------------------------------------
--          Embedding Unions
--------------------------------------------------------------------------------

extendHasR : Has v vs -> Has v (vs ++ r)
extendHasR Z     = Z
extendHasR (S x) = S (extendHasR x)

||| Extends a union by appending additional types
||| to the list of possibilities.
public export
extendR : Union ts -> Union (ts ++ r)
extendR (U prf v) = U (extendHasR prf) v

extendHasL : {n : _} -> {0 r : Vect n _} -> Has v vs -> Has v (r ++ vs)
extendHasL {n = Z}   {r = []}     prf = prf
extendHasL {n = S k} {r = _ :: _} prf = S (extendHasL prf)

||| Extends a union by prepending additional types
||| to the list of possibilities. In order to implement this,
||| we need to shift the current index, therefore the
||| number of new types must be known a runtime.
public export
extendL : {n : _} -> {0 r : Vect n _} -> Union ts -> Union (r ++ ts)
extendL (U prf v) = U (extendHasL prf) v


import Data.Vect
import Data.Fin
import Language.Reflection

%language ElabReflection

data Ty : Type where
     Base : Type -> Ty
     Arrow : Ty -> Ty -> Ty

-- Ty can be translated to a host language type

interpTy : Ty -> Type
interpTy (Base t) = t
interpTy (Arrow s t) = (argTy : interpTy s) -> interpTy t

data HasType : Fin k -> Ty -> Vect k Ty -> Type where
     Stop : HasType FZ t (t :: gam)
     Pop  : HasType i t gam -> HasType (FS i) t (u :: gam)

data Lang : Vect k Ty -> Ty -> Type where
     Var : HasType i t gam -> Lang gam t
     Val : (x : interpTy a) -> Lang gam a
     Lam : (scope : Lang (s :: gam) t) -> Lang gam (Arrow s t)
     App : Lang gam (Arrow s t) -> Lang gam s -> Lang gam t;
     Op  : (interpTy a -> interpTy b -> interpTy c) ->
           Lang gam a -> Lang gam b -> Lang gam c

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

-- Find a value in an environment
lookupEnv : HasType i t gam -> Env gam -> Elab (interpTy t)
lookupEnv Stop (x :: xs) = pure x
lookupEnv (Pop var) (x :: env) = lookupEnv var env

interp : Env gam -> Lang gam t -> Elab (interpTy t)
interp env (Var x)
    = do res <- lookupEnv x env
         pure res
interp env (Val x) = pure x
interp env (Lam scope)
    = lambda _ (\val => interp (val :: env) scope)
interp env (App f a)
    = interp env f <*> interp env a
interp env (Op f x y) = f <$> interp env x <*> interp env y

%macro
eval : Env gam -> Lang gam t -> Elab (interpTy t)
eval = interp

testAdd : Lang gam (Arrow (Base Nat) (Arrow (Base Nat) (Base Nat)))
testAdd = Lam (Lam (Op plus (Var Stop) (Var (Pop Stop))))

evalAdd : Nat -> Nat -> Nat
evalAdd x y =let add = eval [] testAdd in add x y

testBlock : Lang gam (Base Nat)
testBlock = Op {a=Base Nat} {b=Base Nat} plus (Val 3) (Val 4)

evalBlock : Nat
evalBlock = eval [] testBlock


module Data.SOP.NS

import Data.List.Elem
import Data.SOP.Interfaces
import Data.SOP.NP
import Data.SOP.Utils

import Decidable.Equality

%default total

||| An n-ary sum.
|||
||| The sum is parameterized by a type constructor f and indexed by a
||| type-level list xs. The length of the list determines the number of choices
||| in the sum and if the i-th element of the list is of type x, then the i-th
||| choice of the sum is of type f x.
|||
||| The constructor names are chosen to resemble Peano-style natural numbers,
||| i.e., Z is for "zero", and S is for "successor". Chaining S and Z chooses
||| the corresponding component of the sum.
|||
||| Note that empty sums (indexed by an empty list) have no non-bottom
||| elements.
|||
||| Two common instantiations of f are the identity functor I and the constant
||| functor K. For I, the sum becomes a direct generalization of the Either
||| type to arbitrarily many choices. For K a, the result is a homogeneous
||| choice type, where the contents of the type-level list are ignored, but its
||| length specifies the number of options.
|||
||| In the context of the SOP approach to generic programming, an n-ary sum
||| describes the top-level structure of a datatype, which is a choice between
||| all of its constructors.
|||
||| Examples:
|||
||| ```idris example
||| the (NS_ Type I [Char,Bool]) (Z 'x')
||| the (NS_ Type I [Char,Bool]) (S $ Z False)
||| ```
public export
data NS_ : (k : Type) -> (f : k -> Type) -> (ks : List k) -> Type where
  Z : (v : f t)  -> NS_ k f (t :: ks)
  S : NS_ k f ks -> NS_ k f (t :: ks)

||| Type alias for `NS_` with type parameter `k` being
||| implicit. This reflects the kind-polymorphic data type
||| in Haskell.
public export
NS : {k : Type} -> (f : k -> Type) -> (ks : List k) -> Type
NS = NS_ k

||| Changes an n-ary sum to the identity context `I`
||| by adjusting the types of stored values accordingly.
public export
toI : NS_ k f ks -> NS I (map f ks)
toI (Z v) = Z v
toI (S x) = S $ toI x

--------------------------------------------------------------------------------
--          Specialized Interface Functions
--------------------------------------------------------------------------------

||| Specialiced version of `hmap`
public export
mapNS : (fun : forall a . f a -> g a) -> NS f ks -> NS g ks
mapNS fun (Z v) = Z $ fun v
mapNS fun (S x) = S $ mapNS fun x

||| Specialization of `hfoldl`
public export
foldlNS : (fun : acc -> el -> acc) -> acc -> NS (K el) ks -> acc
foldlNS fun acc (Z v) = fun acc v
foldlNS fun acc (S x) = foldlNS fun acc x

||| Specialization of `hfoldr`
public export %inline
foldrNS : (fun : el -> Lazy acc -> acc) -> Lazy acc -> NS (K el) ks -> acc
foldrNS fun acc (Z v) = fun v acc
foldrNS fun acc (S x) = foldrNS fun acc x

||| Specialization of `hsequence`
public export
sequenceNS : Applicative g => NS (\a => g (f a)) ks -> g (NS f ks)
sequenceNS (Z v) = map Z v
sequenceNS (S x) = S <$> sequenceNS x

||| Specialization of `hap`
public export
hapNS : NP (\a => f a -> g a) ks -> NS f ks -> NS g ks
hapNS (fun :: _)    (Z v) = Z $ fun v
hapNS (_   :: funs) (S y) = S $ hapNS funs y

||| Specialization of `hcollapse`
public export
collapseNS : NS (K a) ks -> a
collapseNS (Z v) = v
collapseNS (S x) = collapseNS x

--------------------------------------------------------------------------------
--          Injections
--------------------------------------------------------------------------------

||| An injection into an n-ary sum takes a value of the correct
||| type and wraps it in one of the sum's possible choices.
public export
0 Injection : (f : k -> Type) -> (ks : List k) -> (v : k) -> Type
Injection f ks v = f v -> K (NS f ks) v

||| The set of injections into an n-ary sum `NS f ks` can
||| be wrapped in a corresponding n-ary product.
public export
injectionsNP : NP g ks -> NP (Injection f ks) ks
injectionsNP []       = []
injectionsNP (_ :: t) = Z :: mapNP (S .) (injectionsNP t)

||| The set of injections into an n-ary sum `NS f ks` can
||| be wrapped in a corresponding n-ary product.
public export
injections : {ks : _} -> NP (Injection f ks) ks
injections = injectionsNP (pureNP ())

||| Applies all injections to an n-ary product of values.
|||
||| This is not implemented in terms of injections for the
||| following reason: Since we have access to the structure
||| of the n-ary product and thus `ks`, we do not need a
||| runtime reference of `ks`. Therefore, when applying
||| injections to an n-ary product, prefer this function
||| over a combination involving `injections`.
public export
apInjsNP_ : NP f ks -> NP (K $ NS f ks) ks
apInjsNP_ []        = []
apInjsNP_ (v :: vs) = Z v :: mapNP S (apInjsNP_ vs)

||| Alias for `collapseNP . apInjsNP_`
public export
apInjsNP : NP f ks -> List (NS f ks)
apInjsNP = collapseNP . apInjsNP_

--------------------------------------------------------------------------------
--          Extracting and injecting values
--------------------------------------------------------------------------------

||| Injects a value into an n-ary sum.
public export
inject : {0 t : k} -> (v : f t) -> {auto prf : Elem t ks} -> NS f ks
inject v {prf = Here}    = Z v
inject v {prf = There _} = S $ inject v

||| Tries to extract a value of the given type from an n-ary sum.
public export
extract : (0 t : k) -> NS f ks -> {auto prf : Elem t ks} -> Maybe (f t)
extract _ (Z v) {prf = Here}    = Just v
extract _ (S _) {prf = Here}    = Nothing
extract _ (Z _) {prf = There y} = Nothing
extract t (S x) {prf = There y} = extract t x

||| Converts an n-ary sum into the corresponding n-ary product
||| of alternatives.
public export
toNP : {ks : _} -> Alternative g => NS f ks -> NP (g . f) ks
toNP {ks = _ :: _} (Z v) = pure v :: hpure empty
toNP {ks = _ :: _} (S x) = empty  :: toNP x

--------------------------------------------------------------------------------
--          Expanding sums
--------------------------------------------------------------------------------

||| Injects an n-ary sum into a larger n-ary sum.
public export
expand : NS f ks -> {auto prf: Sublist ks ks'} -> NS f ks'
expand (Z v) {prf = SLSame y} = Z v
expand (S x) {prf = SLSame y} = S $ expand x
expand v     {prf = SLDiff y} = S $ expand v
expand _     {prf = SLNil} impossible

||| Tries to narrow down an n-ary sum to a subset of
||| choices. `ks'` must be a sublist (values in the same order) of `ks`.
public export
narrow : NS f ks -> {auto prf: Sublist ks' ks} -> Maybe (NS f ks')
narrow _     {prf = SLNil}    = Nothing
narrow (Z v) {prf = SLSame x} = Just $ Z v
narrow (Z v) {prf = SLDiff x} = Nothing
narrow (S x) {prf = SLSame y} = S <$> narrow x
narrow (S x) {prf = SLDiff y} = narrow x

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

public export %inline
HFunctor k (List k) (NS_ k) where hmap = mapNS

public export %inline
HAp k (List k) (NP_ k) (NS_ k) where hap = hapNS

public export %inline
HFold k (List k) (NS_ k) where
  hfoldl = foldlNS
  hfoldr = foldrNS

public export
HSequence k (List k) (NS_ k) where hsequence = sequenceNS

public export
HCollapse k (List k) (NS_ k) I where hcollapse = collapseNS

public export
(all : NP (Eq . f) ks) => Eq (NS_ k f ks) where
  (==) {all = _::_} (Z v) (Z w) = v == w
  (==) {all = _::_} (S x) (S y) = x == y
  (==) {all = _::_} _     _     = False

public export
(all : NP (Ord . f) ks) => Ord (NS_ k f ks) where
  compare {all = _::_} (Z v) (Z w) = compare v w
  compare {all = _::_} (S x) (S y) = compare x y
  compare {all = _::_} (Z _) (S _) = LT
  compare {all = _::_} (S _) (Z _) = GT

||| Sums have instances of `Semigroup` and `Monoid`
||| only when they consist of a single choice, which must itself be
||| a `Semigroup` or `Monoid`.
public export
(all : NP (Semigroup . f) [k']) =>
Semigroup (NS_ k f [k']) where
  (<+>) {all = _ :: _} (Z l) (Z r) = Z $ l <+> r
  (<+>) {all = _ :: _} (S _) _    impossible
  (<+>) {all = _ :: _} _    (S _) impossible

public export
(all : NP (Show . f) ks) => Show (NS_ k f ks) where
  showPrec {all = _::_} p (Z v) = showCon p "Z" (showArg v)
  showPrec {all = _::_} p (S x) = showCon p "S" (showPrec App x)

||| Sums have instances of `Semigroup` and `Monoid`
||| only when they consist of a single choice, which must itself be
||| a `Semigroup` or `Monoid`.
public export
(all : NP (Monoid . f) [k']) => Monoid (NS_ k f [k']) where
  neutral {all = _ :: _} = Z neutral

public export
Uninhabited (Data.SOP.NS.Z x = Data.SOP.NS.S y) where
  uninhabited Refl impossible

public export
Uninhabited (Data.SOP.NS.S x = Data.SOP.NS.Z y) where
  uninhabited Refl impossible

private
zInjective : Data.SOP.NS.Z x = Data.SOP.NS.Z y -> x = y
zInjective Refl = Refl

private
sInjective : Data.SOP.NS.S x = Data.SOP.NS.S y -> x = y
sInjective Refl = Refl

public export
(all : NP (DecEq . f) ks) => DecEq (NS_ k f ks) where
  decEq {all = _::_} (Z x) (Z y) with (decEq x y)
    decEq {all = _::_} (Z x) (Z x) | Yes Refl = Yes Refl
    decEq {all = _::_} (Z x) (Z y) | No contra = No (contra . zInjective)
  decEq {all = _::_} (Z x) (S y) = No absurd
  decEq {all = _::_} (S x) (Z y) = No absurd
  decEq {all = _::_} (S x) (S y) with (decEq x y)
    decEq {all = _::_} (S x) (S x) | Yes Refl = Yes Refl
    decEq {all = _::_} (S x) (S y) | No contra = No (contra . sInjective)

--------------------------------------------------------------------------------
--          Examples and Tests
--------------------------------------------------------------------------------

Ex1 : let T = NS I [Char,Bool] in (T,T)
Ex1 = (Z 'x', S $ Z False)


module Test.Int16

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

allInt16 : Gen Int16
allInt16 = int16 (linear (-0x8000) 0xffff)

prop_ltMax : Property
prop_ltMax = property $ do
  b8 <- forAll allInt16
  (b8 <= MaxInt16) === True

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allInt16
  (b8 >= MinInt16) === True

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

export
props : Group
props = MkGroup "Int16" $
  [ ("prop_ltMax",  prop_ltMax)
  , ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  ] ++ ringProps allInt16


-- Challenge 229 Hard In Idris

-- | Reverses a number
reverse : Integer -> Integer
reverse = cast . reverse . show

solution : Integer -> Integer
solution max = solution' 0 0
  where solution' : Integer -> Integer -> Integer
        solution' n sum =
          if nextN > max
            then sum
            else solution' nextN newSum
          where nextN = n + 7
                newSum = if ((reverse nextN) `mod` 7) == 0
                          then sum + nextN
                          else sum
main : IO()
main = print $ solution $ cast $ power 10 11


module PLFI.Part1.Connectives

import Data.Fin
import PLFI.Part1.Isomorphism
import Syntax.PreorderReasoning.Generic

-- data _×_ (A B : Set) : Set where

--   ⟨_,_⟩ :
--       A
--     → B
--       -----
--     → A × B

test : (Int,Nat)
test = (0,0)

total
test2 : (Void,Nat)
test2 = (?x,0)

-- data TT : Type where
--   MkTT : TT

-- data TF : Type where

-- test3 : TF
-- test3 = ?x1

-- test4 : (TT, TT)
-- test4 = (MkTT, MkTT)

-- test5 : (TF, TT)
-- test5 = (?test5_rhs_1, MkTT)

-- test6 : (,) Nat Nat
-- test6 = (3,3)

data Sx : Nat -> Type where
  MkSx : Sx n

test7 : (x : Nat ** Sx x)
test7 = (3 ** MkSx)

test8 : DPair Nat (\x => Sx x)
test8 = MkDPair 3 MkSx

-- test8 : Sigma Nat (\x => Sx x)
-- test8 = MkSigma 3 MkSx

-- η-× : ∀ {A B : Set} (w : A × B) → ⟨ proj₁ w , proj₂ w ⟩ ≡ w
etaTuple : {a,b : Type} -> (w : (a, b)) -> (fst w, snd w) === w
etaTuple (x, y) = Refl

-- data Bool : Set where
--   true  : Bool
--   false : Bool

-- data Tri : Set where
--   aa : Tri
--   bb : Tri
--   cc : Tri

data B : Type where
  True : B
  False : B

enumB : B -> Fin 2
enumB True = 0
enumB False = 1

-- data T : Type where
--   AA, BB, CC : T

-- enumT : T -> Fin 3
-- enumT AA = 0
-- enumT BB = 1
-- enumT CC = 2

tupleX : (a -> Fin n) -> (b -> Fin m) -> (a,b) -> Fin (n * m)
tupleX f s x = ?xy

-- timesCountBetween1and6 : (x: (Bool, Tri)) -> (timesCount x <= 6 && timesCount x >= 1) = True
-- timesCountBetween1and6 (False, Aa) = Refl
-- timesCountBetween1and6 (False, Bb) = Refl
-- timesCountBetween1and6 (False, Cc) = Refl
-- timesCountBetween1and6 (True, Aa) = Refl
-- timesCountBetween1and6 (True, Bb) = Refl
-- timesCountBetween1and6 (True, Cc) = Refl

-- ×-comm : ∀ {A B : Set} → A × B ≃ B × A
-- ×-comm =
--   record
--     { to       =  λ{ ⟨ x , y ⟩ → ⟨ y , x ⟩ }
--     ; from     =  λ{ ⟨ y , x ⟩ → ⟨ x , y ⟩ }
--     ; from∘to  =  λ{ ⟨ x , y ⟩ → refl }
--     ; to∘from  =  λ{ ⟨ y , x ⟩ → refl }
--     }

prodComm : Iso (a,b) (b,a)
prodComm =
  MkIso
    { to     = (\(x,y) => (y,x))
    , from   = (\(y,x) => (x,y))
    , fromTo = (\(x,y) => Refl)
    , toFrom = (\(y,x) => Refl)
    }

-- ×-assoc : ∀ {A B C : Set} → (A × B) × C ≃ A × (B × C)
-- ×-assoc =
--   record
--     { to      = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → ⟨ x , ⟨ y , z ⟩ ⟩ }
--     ; from    = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → ⟨ ⟨ x , y ⟩ , z ⟩ }
--     ; from∘to = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → refl }
--     ; to∘from = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → refl }
--     }

prodAssoc : Iso ((a,b),c) (a,(b,c))
prodAssoc = MkIso
  { to      = \((x,y),z) => (x,(y,z))
  , from    = \(x,(y,z)) => ((x,y),z)
  , fromTo  = \((x,y),z) => Refl
  , toFrom  = \(x,(y,z)) => Refl
  }

-- data ⊤ : Set where
--   tt :
--     --
--     ⊤

data T : Type where
  TT : T

-- ------ T-I
-- TT : T

--  T , c
-- ------- T-E
--    c

-- elim:
-- c -> (T -> c)
-- c -> T -> c
-- c -> c

-- ⊤-identityˡ : ∀ {A : Set} → ⊤ × A ≃ A
-- ⊤-identityˡ =
--   record
--     { to      = λ{ ⟨ tt , x ⟩ → x }
--     ; from    = λ{ x → ⟨ tt , x ⟩ }
--     ; from∘to = λ{ ⟨ tt , x ⟩ → refl }
--     ; to∘from = λ{ x → refl }
--     }

ttIdentityL : {a : Type} -> Iso (T, a) a
ttIdentityL = MkIso
  { to     = \(TT,y) => y
  , from   = \x => (TT, x)
  , fromTo = \(TT,y) => Refl
  , toFrom = \y => Refl
  }

-- ⊤-identityʳ : ∀ {A : Set} → (A × ⊤) ≃ A
-- ⊤-identityʳ {A} =
--   ≃-begin
--     (A × ⊤)
--   ≃⟨ ×-comm ⟩
--     (⊤ × A)
--   ≃⟨ ⊤-identityˡ ⟩
--     A
--   ≃-∎

-- 0
test3 : {a,b,c : Type} -> Iso a b -> Iso b c -> Iso a c
test3 ab bc = CalcWith {leq = Iso} $
  |~ a
  <~ b ... (ab)
  <~ c ... (bc)

ttIdentityR : {a : Type} -> Iso (a,T) a
ttIdentityR = CalcWith {leq = Iso} $
  |~ (a, T)
  <~ (T, a)  ... prodComm
  <~ a       ... ttIdentityL

-- Same as Either, we are going to use Either
data Sum : Type -> Type -> Type where
  L : a -> Sum a b
  R : b -> Sum a b

-- the first introduces a formula for the connective, which appears in the conclusion but not in the hypotheses
--     x : a
-- ------------- Sum-I1
-- L x : Sum a b
--
--     x : b
-- ------------- Sum-I2
-- R x : Sum a b

-- the second eliminates a formula for the connective, which appears in a hypothesis but not in the conclusion
-- Sum a b , (a -> c) , (b -> c)
-- ----------------------------- Sum-E
--              c

-- case-⊎ : ∀ {A B C : Set}
--   → (A → C)
--   → (B → C)
--   → A ⊎ B
--     -----------
--   → C
-- case-⊎ f g (inj₁ x) = f x
-- case-⊎ f g (inj₂ y) = g y

-- either

-- η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → case-⊎ inj₁ inj₂ w ≡ w

either2 : (b -> c) -> (a -> c) -> Either a b -> c
either2 f g (Left x) = g x
either2 f g (Right x) = f x

etaEither : {a,b : Type} -> (w : Either a b) -> either Left Right w = w
etaEither (Left x) = Refl
etaEither (Right x) = Refl

testData1 : Either () Nat
testData1 = Right 1

test1 : Bool
test1 = either Left Right testData1 == (Right 1)

testData2 : Either Nat ()
testData2 = Left 2

test4 : Bool
test4 = either Left Right testData2 == (Left 2)

-- uniq-⊎ : ∀ {A B C : Set} (h : A ⊎ B → C) (w : A ⊎ B) →
uniqEither
  :  {a,b,c : Type} -> (h : Either a b -> c) -> (w : Either a b)
  -> either (h . Left) (h . Right) w = h w
uniqEither h (Left x) = Refl
uniqEither h (Right x) = Refl

-- test5 : let t = Nat = Nat in Either t t
-- test5 = Left Refl

commEither : Iso (Either a b) (Either b a)
commEither = MkIso
  { to     = either Right Left
  , from   = either Right Left
  , fromTo = \case
                (Left x) => Refl
                (Right x) => Refl
  , toFrom = \case
                (Left x) => Refl
                (Right x) => Refl
  }

assocEither : Iso (Either (Either a b) c) (Either a (Either b c))
assocEither = MkIso
  { to     = either (either Left (Right . Left)) (Right . Right)
  , from   = either (Left . Left) (either (Left . Right) Right)
  , fromTo = \case
                (Left (Left x))   => Refl
                (Left (Right x))  => Refl
                (Right x)         => Refl
  , toFrom = \case
                (Left x)          => Refl
                (Right (Left x))  => Refl
                (Right (Right x)) => Refl
  }

-- Couldn't parse any alternatives:
-- 1: Expected name.
-- ... (1 others)idris2
-- data G : Type where
--   { MkG : G
--   } -- c)

-- Without where clause it means something else, we declare this type, but we don't define it yet.
-- data F : Type          a)
-- declare data F : Type  a)

-- Suggestions for definition of empty type
-- data F : Type where -- b)

-- data F : Type where -- c)
--   impossible

-- data F : Type empty -- d)

-- data F : Type impossible -- e)

-- data F : Type where {}

data F : Type where -- c)

fElim : {0 a : Type} -> F -> a
fElim x impossible

fElim' : {a : Type} -> F -> a
fElim' = \x => case x of {} -- \case leads to a parse error

-- uniq-⊥ : ∀ {C : Set} (h : ⊥ → C) (w : ⊥) → ⊥-elim w ≡ h w
-- uniq-⊥ h ()

uniqF : {c : Type} -> (h : F -> c) -> (w : F) -> fElim w = h w
uniqF h w impossible

-- ⊥-identityˡ

fIdentityL : Iso (Either F a) a
fIdentityL = MkIso
  { to     = either fElim id
  , from   = Right
  , fromTo = \case
                (Left x) => fElim x
                (Right x) => Refl
  , toFrom = \y => Refl
  }

fIdentityR : Iso (Either a F) a
fIdentityR = isoTrans commEither fIdentityL

-- η-→ : ∀ {A B : Set} (f : A → B) → (λ (x : A) → f x) ≡ f
-- η-→ f = refl

-- TODO: Ask
--    a : Type
--    b : Type
--    f : a -> b
-- ------------------------------
-- xx : (\x => f x) = f
etaFun : {a,b : Type} -> (f : a -> b) -> (\x => f x) = f
etaFun f = Refl

--    a : Type
--    b : Type
--    f : a -> b
-- ------------------------------
-- xRefl : (\x => f x) = (\y => f y)
alphaFun : {a,b : Type} -> (f : a -> b) -> (\x => f x) = (\y => f y)
alphaFun f = Refl

-- Under the hood terms are normalized for alpha/eta equivalence?
alphaFun2 : {a,b,c : Type} -> (f : a -> b -> c) -> (z : b) -> (\x => f x z) = (\y => f y z)
alphaFun2 f z = Refl

betaFun : (y : Nat) -> (\x => x * x) y = y * y
betaFun y = Refl

namespace Newtype12

  export
  Person : Type
  Person = (String, Int)

  public export
  mkPerson : (String, Int) -> Person
  mkPerson = id

  public export
  unPerson : Person -> (String, Int)
  unPerson = id

  export
  0
  samePersonLemma : (p : Person) -> (mkPerson (unPerson p)) = p
  samePersonLemma p = Refl

  -- export
  -- samePersonLemma

test5 : Person
test5 = mkPerson ("Andor", 23)

-- samePersonLemma : (p : Person) -> (mkPerson (unPerson p)) = p
-- samePersonLemma p = Refl

samePersonLemmaR : (p : (String, Int)) -> (unPerson (mkPerson p) = p)
samePersonLemmaR p = ?h1_0

handwaving : {t : Type} -> (a : t) -> (b : t) -> (a = b)
handwaving a b = believe_me (the (a=a) Refl)

namespace Postulate

  export
  extensionality : {a,b : Type} -> {f,g : a -> b} -> ((x : a) -> f x = g x) -> f = g
  extensionality _ = handwaving f g

-- currying : ∀ {A B C : Set} → (A → B → C) ≃ (A × B → C)
currying : {a,b,c : Type} -> Iso (a -> b -> c) ((a,b) -> c)
currying = MkIso
  { to      = \f => \(x,y) => f x y
  , from    = \f => \x => \y => f (x, y)
  , fromTo  = \f => Refl
  , toFrom  = \g => extensionality (\(x,y) => Refl)
  }

-- c ^ (a + b) ~ c ^ a * c ^ b
-- →-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B → C) ≃ ((A → C) × (B → C))
distribFunOverSumR : {a,b,c : Type} -> Iso (Either a b -> c) (a -> c, b -> c)
distribFunOverSumR = MkIso
  { to     = \f     => (f . Left, f . Right)
  , from   = \(f,g) => either f g
  , fromTo = \f     => extensionality (\case { Left x => Refl ; Right y => Refl })
  , toFrom = \(f,g) => Refl
  }

-- →-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
-- (p * n) ^ m = (p ^ m) * (n ^ m)
distribFunOverProdL : {a,b,c : Type} -> Iso (a -> (b,c)) (a -> b, a -> c)
distribFunOverProdL = MkIso
  { to     = \f     => (fst . f, snd . f)
  , from   = \(f,g) => \x => (f x, g x)
  , fromTo = \f     => extensionality (\x => etaTuple (f x)) -- TODO: Next time cong
  , toFrom = \(f,g) => Refl
  }

-- →-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
-- (p * n) ^ m = (p ^ m) * (n ^ m)
distribFunOverProdL2 : {a,b,c : Type} -> Iso (a -> (b,c)) (a -> b, a -> c)
distribFunOverProdL2 = MkIso
  { to     = \f     => (fst . f, snd . f)
  , from   = \(f,g) => \x => (f x, g x)
  , fromTo = \f     => extensionality (\x => cong id (cong id (cong id (etaTuple (f x)))))
  , toFrom = \(f,g) => Refl
  }

-- ×-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B) × C ≃ (A × C) ⊎ (B × C)
distribProdOverSum  : {a,b,c : Type} -> Iso (Either a b, c) (Either (a,c) (b,c))
distribProdOverSum = MkIso
  { to = \(x,y) => bimap (,y) (,y) x
  , from = either (mapFst Left) (mapFst Right)
  -- , fromTo = \(x, y) => either (\z => ?h1) ?h2 x -- (const Refl) (const Refl) x
  , fromTo = \(x, y) => case x of
                (Left z) => Refl
                (Right z) => Refl
  , toFrom = \case
                (Left (x, y)) => Refl
                (Right (x, y)) => Refl
  }

-- ⊎-distrib-× : ∀ {A B C : Set} → (A × B) ⊎ C ≲ (A ⊎ C) × (B ⊎ C)
weakDistribSumOverProd : {a,b,c : Type} -> (Either (a,b) c) <= (Either a c, Either b c)
weakDistribSumOverProd = MkEmb
  { to = \case
            (Left (x, y)) => (Left x, Left y)
            (Right x) => (Right x, Right x)
  , from = \case
              ((Right x), y        ) => Right x
              ((Left x) , (Right y)) => Right y
              ((Left x) , (Left y) ) => Left (x, y)
  , fromTo = \case
                (Left (x, y)) => Refl
                (Right x) => Refl
  }


module Main

import Effect.Random
import Effect.StdIO
import Effects
import Data.Vect

-- import Probability.Core
-- import Probability.Monad

%default total

{- Probabilistic programming -}

data Prob : Type -> Type where
  Binomial : Nat -> Double -> Prob Nat
  Certainly : a -> Prob a
  Bind : (Prob a) -> (a -> Prob b) -> Prob b
  CustomDist : Vect (S n) (a, Double) -> Prob a

Show a => Show (Prob a) where
  show (Binomial n p) = "Binomial " ++ (show n) ++ " " ++ (show p)
  show (Certainly a) = "Certainly " ++ (show a)
  show (Bind (Binomial n p) _) = "Bind (" ++ (show $ Binomial n p) ++ ") <function>"
  show (Bind a _) = "Bind <dist> <function>"
  show (CustomDist d) = "CustomDist " ++ (show d)

-- NOTE: It seems Idris won't accept this as total unless I handle the
-- 'impossible' case (that's also why choose wasn't reducing at compile time).
zeroSum : {a: Nat} -> {b: Nat} -> (a + b = 0) -> Either Void ((a = 0), (b = 0))
zeroSum {a = Z} Refl = Right (Refl, Refl)
zeroSum {a} {b = Z} prf = Right (replace {P = \x => x = 0} (plusZeroRightNeutral a) prf, Refl)
zeroSum {a = S a} {b = S b} prf = Left $ SIsNotZ prf

factNZ : {k: Nat} -> Not (fact k = Z)
factNZ {k = Z} p = SIsNotZ p
factNZ {k = (S k)} p = case zeroSum p of
  Left v => v
  Right (q1, _) => factNZ q1

-- factBetween : Nat -> Nat -> Nat
-- factBetween n m = if n == m then n else if n > m then 0 else  (factBetween n (pred m)) * (m)

total
choose : Nat -> Nat -> Nat
choose _ Z = 1
choose (S n) (S Z) = S n
choose Z (S _) = 0
-- if n < k then n `choose` k = 0
choose n k = divNatNZ (divNatNZ (fact n) (fact (n `minus` k)) factNZ) (fact k) factNZ

chooseZero : {n: Nat} -> choose n Z = 1
chooseZero = Refl

chooseOne : {n: Nat} -> choose (S n) 1 = S n
chooseOne = Refl

-- chooseNLessK : choose n (n + m + 1) = 0
-- chooseNLessK = ?csdvsd

total
binomialPMF : Nat -> Double -> Nat -> Double
binomialPMF n p k = cast (n `choose` k) * (p `pow` k) * ((1.0 - p) `pow` (n `minus` k))

splitBy : (a -> Bool) -> List a -> (List a, List a)
splitBy _ [] = ([], [])
splitBy pred (x::xs) = let (s, t) = splitBy pred xs in
  if pred x then (x::s, t) else (s, x::t)

gatherer : (Eq a, Eq p, Num p) => List (a,p) -> List (a,p) -- copied from https://github.com/lambdacasserole/probability/blob/master/src/Probability/Core.idr
gatherer [] = []
gatherer ((x,p) :: xs) = assert_total $  -- why is assert_total needed?
   let lyln = splitBy (\(z,_) => z == x) xs
       newp = (+) p . sum $ map snd (fst lyln)
   in  (x,newp) :: gatherer (snd lyln)

-- vectNatEnumFromTo : (a, b: Nat) -> {auto prf: LTE a b} -> Vect (b - a + 1) Nat
-- vectNatEnumFromTo a b = vectNatEnumFromTo' a (b - a) where
--   vectNatEnumFromTo' a Z = [a]
--   vectNatEnumFromTo' a (S n) = a :: vectNatEnumFromTo' (a + 1) n

-- cartesianProduct : Vect n a -> (a -> Vect m b) -> Vect (n * m) (a, b)
-- cartesianProduct [] _ = []
-- cartesianProduct {n} {m = Z} _ _ = rewrite multZeroRightZero n in []
-- cartesianProduct (x::xs) fys = ((\y => (x, y)) <$> fys x) ++ cartesianProduct xs fys
--
-- cartesianProduct' : Vect n a -> (a -> (m: Nat ** Vect m b)) -> Vect (n * m) (a, b)
-- cartesianProduct' xs fys = cartesianProduct xs (DPair.snd . fys)

concatNonempty' : Vect n (m: Nat ** Vect (S m) a) -> (k: Nat ** Vect k a)
concatNonempty' [] = (_ ** [])
concatNonempty' (x1::xs) = (_ ** (snd x1) ++ (snd (concatNonempty' xs)))

concatNonempty : Vect (S n) (m: Nat ** Vect (S m) a) -> (k: Nat ** Vect (S k) a)
concatNonempty [x] = x
-- concatNonempty [x1, x2] = (_ ** (snd x1) ++ (snd x2))
concatNonempty (x1::xs) = (_ ** (snd x1) ++ (snd (concatNonempty' xs)))

total
runProb : Prob a -> (k: Nat ** Vect (S k) (a, Double))
runProb (Binomial n p) = (_ ** (\k => (k, binomialPMF n p k)) <$> 0 :: fromList [1..n])
runProb (Certainly a) = (_ ** [(a, 1.0)])
-- runProb {a} (Bind probA f) = (_ ** (\((_,w),(y,q)) => (y, q*w)) <$> cartesianProduct {m = m} (DPair.snd {x = runProb probA}) f'') where
--   f' : (a: Type) -> (b, Double) -> (l: Nat ** Vect (S l) (a, Double))
--   f' a (y,_) = runProb {a = a} ?dxdv --(f x)
--   f'' y' = DPair.snd {x = (f' a y')}
--   m = S $ DPair.fst (f' (head (DPair.snd (runProb probA))))
runProb {a} (Bind probA f) =
  concatNonempty (snd joinedPartly) -- unjoined = (\(pA,p) => (runProb pA, p)) <$> probfAs in
  where
    probfAs : (k: Nat ** Vect (S k) ((l: Nat ** Vect (S l) (a, Double)), Double))
    probfAs = assert_total (_ ** (\(x,p) => (runProb (f x), p)) <$> snd (runProb (assert_smaller (Bind probA f) probA)))
    joinedPartly : (k: Nat ** Vect (S k) (l: Nat ** Vect (S l) (a, Double)))
    joinedPartly = (_ ** (\((_**dist),p) => (_ ** (\(x,q) => (x, p*q)) <$> dist)) <$> snd probfAs)
    -- joinedPartly = (_ ** ?cbfdbdb <$> probfAs)
runProb (CustomDist d) = (_ ** d)

Functor Prob where
  map f (Certainly a) = Certainly $ f a
  map f (Bind a g) = Bind a (\x => f <$> g x)
  map f (CustomDist d) = CustomDist $ (\(x, p) => (f x, p)) <$> d
  map f p = CustomDist $ (\(x, p) => (f x, p)) <$> (snd $ runProb p)

Applicative Prob where
  pure = Certainly
  (Certainly f) <*> p = f <$> p
  (Bind pa f) <*> p = Bind pa (\a => (f a) <*> p)
  -- (CustomDist d) <*> p = CustomDist [ (f x, q*w) | (f,w) <- d, (x,q) <- runProb p ] -- copied from https://github.com/lambdacasserole/probability/blob/master/src/Probability/Core.idr
  (CustomDist d) <*> p = Bind (CustomDist d) (\f => Bind p (pure . f))

Monad Prob where
  (Certainly a) >>= f = f a
  (Bind fa f) >>= g = fa >>= (\a => (f a) >>= g)
  fa >>= f = Bind fa f

gather : (Eq a) => Prob a -> Prob a
-- FIXME: Adapt this function for vects
-- gather (CustomDist d) = CustomDist (gatherer d)
-- gather (Bind pa f) = pa >>= (\a => gather $ f a) -- FIXME: Might not gather completely because pa not gathered
gather p = p

mortalityRate : Double
mortalityRate = 0.03

binomial : Nat -> Double -> Prob Nat
binomial = Binomial

kill : (population: Nat) -> Double -> Prob Nat
kill = binomial

replace : Nat -> Nat -> Prob (Nat, Nat)
replace n1 n2 = gather $ replace' <$> binomial (n1 + n2) ((cast n1) / (cast (n1 + n2))) where
  replace' n1' = (n1', (n1 + n2) `minus` n1')

step : Nat -> Nat -> Prob (Nat, Nat)
step n1 n2 = gather $ do
  dead1 <- kill n1 mortalityRate
  dead2 <- kill n2 mortalityRate
  gather $ (\(new1,new2) => ((n1 `minus` dead1) + new1, (n2 `minus` dead2) + new2)) <$> replace dead1 dead2

simulate : Nat -> Nat -> Nat -> Prob (Nat, Nat)
simulate species1Initial species2Initial Z = pure (species1Initial, species2Initial)
simulate species1Initial species2Initial (S k) = gather $ do
  (n1, n2) <- step species1Initial species2Initial
  gather $ simulate n1 n2 k

{- Error propagation -}

data Uncertain value = MkUncertain value value

interface SquareRootable a where
  sqrt : a -> a

SquareRootable Double where
  sqrt = Doubles.sqrt

square : Num a => a -> a
square a = a * a

norm : (Num a, SquareRootable a) => List a -> a
norm values = sqrt $ sum (square <$> values)

(Fractional value, SquareRootable value) => Num (Uncertain value) where
  -- FIXME: Account for correlation
  (+) (MkUncertain a aUncertainty) (MkUncertain b bUncertainty) = MkUncertain (a + b) (norm [aUncertainty, bUncertainty])
  (*) (MkUncertain a aUncertainty) (MkUncertain b bUncertainty) = (MkUncertain (a * b) (a * b * norm [aUncertainty/a, bUncertainty/b]))
  fromInteger i = MkUncertain (fromInteger i) 0

(SquareRootable value, Fractional value) => Fractional (Uncertain value) where
  (MkUncertain a aUncertainty) / (MkUncertain b bUncertainty) = MkUncertain (a / b) (a / b * norm [aUncertainty/a, bUncertainty/b])

Show value => Show (Uncertain value) where
  show (MkUncertain a aUncertainty) = show a ++ " +- " ++ show aUncertainty

interface Scalable a where
  (*) : a -> Double -> a

Scalable Double where
  (*) = Interfaces.(*)

mean : (Scalable a, Num a) => (prob: Prob a) -> a
mean (Binomial n p) = (Main.(*) n p) -- probably not what you want
mean (Certainly a) = a
mean (CustomDist d) = sum [x * p | (x, p) <- d]
mean (Bind pa f) = sum [x * p | (x, p) <- snd $ runProb (pa >>= f)]

-- population standardDeviation (QUESTION: should it be sample instead?)
standardDeviation : (SquareRootable a, Scalable a, Neg a) => (prob: Prob a) -> a
standardDeviation (Binomial n p) = sqrt (Main.(*) (Main.(*) n p) (1.0 - p)) -- probably not what you want
standardDeviation (Certainly _) = 0
standardDeviation (CustomDist d) = let mu = mean (CustomDist d) in
  sqrt $ sum [square (mu - x) * p | (x, p) <- d]
standardDeviation (Bind pa f) = let mu = mean (Bind pa f) in
  sqrt $ sum [square (mu - x) * p | (x, p) <- snd $ runProb (pa >>= f)]

probToUncertain : (SquareRootable a, Scalable a, Neg a, Fractional a) => (prob: Prob a) -> Uncertain a
probToUncertain dist = MkUncertain (mean dist) (Main.(*) (standardDeviation dist) 0.5)

{- Estimate distributions by sampling (Monte Carlo) -}

select : Double -> Vect (S n) (a, Double) -> Double -> a
select _ [(x, p)] _ = x
select target ((x, p)::xps) current =
  if target >= current + p
    then x
    else case xps of
      [] => x
      (xp::xps') => select target (xp::xps') (current + p)

-- Copied from https://bl.ocks.org/justinmanley/f2e169feb32e06e06c2f
||| Naively generate a (pseudo)-random float between 0 and 1.
rndDouble : Integer -> Eff Double [RND]
rndDouble max = do
	rnd <- assert_total $ rndInt 0 max
	pure (fromInteger rnd / fromInteger max)

sample : Prob a -> Eff a [RND, STDIO]
sample (Bind prob f) = do
  observedFromProb <- sample prob
  putStrLn "Bind: sampled prob"
  result <- sample (f observedFromProb)
  putStrLn "Bind: sampled f _"
  pure result
sample prob = do
  putStrLn "Sampling from an arbitrary distribution"
  probability <- rndDouble (2 `pow` 20)
  (_ ** dist) <- pure (runProb prob)
  pure $ select probability dist 0.0

Applicative (Pair Int) where
  pure a = (0, a)

  f <*> fa = (fst fa, (snd f) (snd fa))

main : IO ()
main = do
  dist <- pure (simulate 1 1 3)
  putStrLn "dist"
  printLn dist
  printLn (gatherer $ toList (snd (runProb dist)))
  printLn $ (MkUncertain 0.172807 0.000008) / ((MkUncertain 13.7 0.3) * (MkUncertain 1.0 0.1)) -- 0.013 ± 0.001 (https://chem.libretexts.org/Bookshelves/Analytical_Chemistry/Supplemental_Modules_(Analytical_Chemistry)/Quantifying_Nature/Significant_Digits/Propagation_of_Error)
  printLn $ probToUncertain (cast {to=Double} <$> binomial 5 0.5) -- 2.5 +- 0.559
  -- printLn (run $ sample (simulate 1 1 3))


module FieldAxioms

import ZZ
import ZZUtils
import GCDZZ
import Divisors
import Rationals

%default total

-- The field axioms which require the custom equality EqRat type are verified here.

EqRatAddInvLeft: (x: ZZPair) -> (a: NotZero (snd x))
-> (EqRat (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a))
EqRatAddInvLeft x a = eqMeansEqRat (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (addInverseLeft x a)

EqRatAddInvRight: (x: ZZPair) -> (a: NotZero (snd x))
-> (EqRat (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a))
EqRatAddInvRight x a = eqMeansEqRat (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (addInverseRight x a)

EqRatMultInvLeft: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x))
-> (EqRat (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) ((fst x)*(snd x), (fst x)*(snd x)) (productNonZero a b))
EqRatMultInvLeft x a b = eqMeansEqRat (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) ((fst x)*(snd x), (fst x)*(snd x)) (productNonZero a b) (multInverseLeft x a b)

EqRatMultInvRight: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x))
-> (EqRat (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) ((snd x)*(fst x), (snd x)*(fst x)) (productNonZero b a))
EqRatMultInvRight x a b = eqMeansEqRat (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) ((snd x)*(fst x), (snd x)*(fst x)) (productNonZero b a) (multInverseRight x a b)

-- All of the following proofs involve the use of EqRat and its associated properties which are
-- reflexvity, symmetry, transitivity, and the fact that two elements being equal is enough to construct
-- an element of EqRat.

|||Constructs an equality between (a,b) + (c,d) and (c,d) + (a,b)
plusCommQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) ->
(EqRat (AddRationals x a y b) (productNonZero a b) (AddRationals y b x a) (productNonZero b a))
plusCommQEqRat x a y b = eqMeansEqRat (AddRationals x a y b) (productNonZero a b) (AddRationals y b x a) (productNonZero b a) (plusCommutativeQ x a y b)

|||Constructs an equality between (a,b)*(c,d) and (c,d)*(a,b)
multCommQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) ->
(EqRat (MultiplyRationals x a y b) (productNonZero a b) (MultiplyRationals y b x a) (productNonZero b a))
multCommQEqRat x a y b = eqMeansEqRat (MultiplyRationals x a y b) (productNonZero a b) (MultiplyRationals y b x a) (productNonZero b a) (multCommutativeQ x a y b)

|||Constructs an equality between (a,b) + (0,1) and (a,b).
addIdRightEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals x a (0,1) PositiveZ) (productNonZero a (PositiveZ)) x a)
addIdRightEqRat x a = eqMeansEqRat (AddRationals x a (0,1) PositiveZ) (productNonZero a (PositiveZ)) (x) (a) (zeroAddIdentityRight x a)

|||Constructs an equality between (a,b) and (a,b) + (0,1).
addIdLeftEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals (0,1) PositiveZ x a) (productNonZero (PositiveZ) a) x a)
addIdLeftEqRat x a = eqMeansEqRat (AddRationals (0,1) PositiveZ x a) (productNonZero (PositiveZ) a) (x) (a) (zeroAddIdentityLeft x a)

|||Constructs an equality between (a,b)*(1,1) and (a,b).
multIdRightEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (MultiplyRationals x a (1,1) PositiveZ) (productNonZero a (PositiveZ)) x a)
multIdRightEqRat x a = eqMeansEqRat (MultiplyRationals x a (1,1) PositiveZ) (productNonZero a (PositiveZ)) (x) (a) (oneMultIdentityRight x a)

|||Constructs an equality between (a,b)*(1,1) and (a,b).
multIdLeftEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (MultiplyRationals (1,1) PositiveZ x a) (productNonZero (PositiveZ) a) x a)
multIdLeftEqRat x a = eqMeansEqRat (MultiplyRationals (1,1) PositiveZ x a) (productNonZero (PositiveZ) a) (x) (a) (oneMultIdentityLeft x a)

|||Constructs an equality between ((a,b)+(-a,b)) and 0.
addInverseLeftEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a) ) (productNonZero a (xAndInverseNotZeroPlus x a)) (0,1) PositiveZ)
addInverseLeftEqRat x a = EqRatTrans (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (0,1) (PositiveZ) (EqRatAddInvLeft x a) (reducedFormZeroRight ((snd x)*(snd x)) (productNonZero a a))

|||Constructs an equality between 0 and ((a,b)+(-a,b)).
addInverseRightEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) (0,1) PositiveZ)
addInverseRightEqRat x a = EqRatTrans (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (0,1) (PositiveZ) (EqRatAddInvRight x a) (reducedFormZeroRight ((snd x)*(snd x)) (productNonZero a a))

|||Constructs an equality between (a,b)*(b,a) and (1,1).
multInverseLeftEqRat: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x)) ->
(EqRat (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) (1,1) (PositiveZ))
multInverseLeftEqRat x a b = EqRatTrans (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) ((fst x)*(snd x), (fst x)*(snd x)) (productNonZero a b) (1,1) (PositiveZ) (EqRatMultInvLeft x a b) (reducedFormOneRight ((fst x)*(snd x)) (productNonZero a b))

|||Constructs an equality between (1,1) and (a,b)*(b,a).
multInverseRightEqRat: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x)) ->
(EqRat (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) (1,1) (PositiveZ))
multInverseRightEqRat x a b = EqRatTrans (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) ((snd x)*(fst x), (snd x)*(fst x)) (productNonZero b a) (1,1) (PositiveZ) (EqRatMultInvRight x a b) (reducedFormOneRight ((snd x)*(fst x)) (productNonZero b a))

|||Constructs an EqRat element of associativity for addition.
plusAssocQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (z: ZZPair) -> (c: NotZero (snd z)) ->
(EqRat (AddRationals (AddRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (AddRationals x a (AddRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)))
plusAssocQEqRat x a y b z c = eqMeansEqRat (AddRationals (AddRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (AddRationals x a (AddRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)) (plusAssociativeQ x a y b z c)

|||Constructs an EqRat element of associativity for multiplication.
multAssocQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (z: ZZPair) -> (c: NotZero (snd z)) ->
(EqRat (MultiplyRationals (MultiplyRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (MultiplyRationals x a (MultiplyRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)))
multAssocQEqRat x a y b z c = eqMeansEqRat (MultiplyRationals (MultiplyRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (MultiplyRationals x a (MultiplyRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)) (multAssociativeQ x a y b z c)


module PatternMatching

zahlen : List Nat
zahlen = [1,2,3,4,5]

person : (String, Nat)
person = ("Max", 40)

data Farbe
  = Rot
  | Blau

data Expression : Type -> Type where
  Falsch : Expression Bool
  Wahr : Expression Bool
  Zahl : Nat -> Expression Nat
  Plus : Expression Nat -> Expression Nat -> Expression Nat
  Gleich : Expression Nat -> Expression Nat -> Expression Bool
  Falls : Expression Bool -> Expression a -> Expression a -> Expression a

istLeer : List a -> Bool
istLeer [] = True
istLeer (x :: xs) = False

name : (String, Nat) -> String
name (n, _) = n

eval : Expression a -> a
eval Falsch = False
eval Wahr = True
eval (Zahl k) = k
eval (Plus x y) = eval x + eval y
eval (Gleich x y) = eval x == eval y
eval (Falls b t e) = if (eval b) then eval t else eval e


module Verified.Functor

%default total

class Functor f => VerifiedFunctor (f : Type -> Type) where
  functorIdentity : {a : Type} -> (x : f a) -> map id x = id x
  functorComposition : {a : Type} -> {b : Type} -> (x : f a) ->
                   (g1 : a -> b) -> (g2 : b -> c) ->
                   map (g2 . g1) x = (map g2 . map g1) x


module Vec

import Data.Fin

%default total

%logging 1
%logging declare.def 2

Vec : Type -> Nat -> Type
Vec a n = Fin n -> a

Nil : Vec a Z
Nil = absurd

(::) : a -> Vec a n -> Vec a (S n)
(x :: xs) FZ = x
(x :: xs) (FS i) = xs i

test : Vec (List Nat) 2
test = [[], [0]]


module Flexidisc.Dec.IsNo

%default total

||| Build at type level the proof that a decidable property is valid
public export
data IsNo : prop -> Type where
  SoFalse : IsNo (No prop)

%name IsNo no, prf, xx, ko

||| Demote an absurd proof from the type level to the value level
export
getContra : {witness : Dec prop} -> IsNo witness -> (Not prop)
getContra x {witness = (Yes prf)} impossible
getContra x {witness = (No contra)} = contra

||| If I can prove two times that a property doesn't hold,
||| the two proofs are equal
export
uniqueNo : (prop : Dec any) -> (x, y : IsNo prop) -> x = y
uniqueNo (Yes _) SoFalse _ impossible
uniqueNo (No contra) SoFalse SoFalse = Refl