module Data.InSet

import Data.Bool
import Data.Bool.Xor

import public Data.InSet.Equality

import Decidable.Equality

%default total

---------------------
---------------------
---               ---
---  DEFINITIONS  ---
---               ---
---------------------
---------------------

infix 6 ==
infix 7 `isin`, `notin`
infixl 8 +, -, ^
infixl 9 *, #

-------------------
--- Type itself ---
-------------------

public export
InSet : Type -> Type
InSet a = a -> Bool

-- TODO To think, maybe equality relation should be shown in the `InSet` type as a parameter?
--      However, if this is only in the append operation, this gives an ability to union sets with different equalities.

------------------------------------
--- Intesional test of existence ---
------------------------------------

export
isin : a -> InSet a -> Bool
isin = flip apply

public export %inline
notin : a -> InSet a -> Bool
notin x y = not $ isin x y

----------------
--- Creation ---
----------------

--- Syntax for list-like literals ---

public export
Nil : InSet a
Nil _ = False

public export
(::) : Equality a => a -> InSet a -> InSet a
(::) added parent x = if x =?= added then True else x `isin` parent

--- Constants

public export %inline
Empty : InSet a
Empty = []

public export
Universe : InSet a
Universe _ = True

---------------------------
--- Basic set relations ---
---------------------------

public export
(==) : InSet a -> InSet a -> Type
sa == sb = (x : a) -> x `isin` sa = x `isin` sb

public export
(<=) : InSet a -> InSet a -> Type
sa <= sb = (x : a) -> x `isin` sa = True -> x `isin` sb = True

public export
NotEmpty : {a : Type} -> InSet a -> Type
NotEmpty s = (x ** x `isin` s = True)

----------------------------
--- Basic set operations ---
----------------------------

export
(+) : InSet a -> InSet a -> InSet a -- union
(+) sa sb x = x `isin` sa || x `isin` sb

export
(#) : InSet a -> InSet a -> InSet a -- intersection
(#) sa sb x = x `isin` sa && x `isin` sb

export
(-) : InSet a -> InSet a -> InSet a -- set difference
(-) sa sb x = x `isin` sa && x `notin` sb

export
(^) : InSet a -> InSet a -> InSet a -- symmetrical difference
(^) sa sb x = (x `isin` sa) `xor` (x `isin` sb)

export %inline
complement : InSet a -> InSet a
complement s x = x `notin` s

------------------------------------
--- Non-algebraic set operations ---
------------------------------------

export
(*) : InSet a -> InSet b -> InSet (a, b)
(*) sx sy (x, y) = x `isin` sx && y `isin` sy

--------------
--------------
---        ---
---  LAWS  ---
---        ---
--------------
--------------

------------------------
--- Laws of equality ---
------------------------

export
eq_reflexivity : (0 s : InSet a) -> s == s
eq_reflexivity _ _ = Refl

export
eq_symmerty : {0 sa, sb : InSet a} -> (0 _ : sa == sb) -> sb == sa
eq_symmerty f x = rewrite f x in Refl

export
eq_transitivity : {0 sa, sb, sc : InSet a} -> (0 _ : sa == sb) -> (0 _ : sb == sc) -> sa == sc
eq_transitivity f g x = rewrite f x in
                        rewrite g x in
                        Refl

-- Definition above can be written as
--   sa <= sb = (x : a) -> So (x `isin` sa) -> So (x `isin` sb)
-- but this leads to constant using `soToEq` and `eqToSo` in proofs.

--- Negative equality-related laws ---

trueNotFalse : Not (True = False)
trueNotFalse Refl impossible

export
non_empty_is_not_empty : NotEmpty s -> Not (s = Empty)
non_empty_is_not_empty (x ** prf_t) prf_f = trueNotFalse $ rewrite sym prf_t in rewrite prf_f in Refl

export
non_empty_not_eq_empty : NotEmpty s -> Not (s == Empty)
non_empty_not_eq_empty (x ** prf_t) prf_f = trueNotFalse $ rewrite sym prf_t in rewrite prf_f x in Refl

export
cant_in_and_not_in : (s : InSet a) -> (x : a) -> Not (x `isin` s = x `notin` s)
cant_in_and_not_in s x prf with (s x)
  cant_in_and_not_in _ _ Refl | True impossible

-------------------------------
--- Laws of subset relation ---
-------------------------------

--- Order laws of subset relation ---

export
subset_equal : {0 sa, sb : InSet a} -> (0 _ : sa == sb) -> sa <= sb
subset_equal f x prf = rewrite sym $ f x in
                       rewrite prf in
                       Refl

export
subset_reflexivity : (0 s : InSet a) -> s <= s
subset_reflexivity _ _ = id

export
subset_antisymmetry : {sa, sb : InSet a} -> sa <= sb -> sb <= sa -> sa == sb
subset_antisymmetry f g x with (decEq (sa x) True)
  subset_antisymmetry f _ x | Yes pa with (decEq (sb x) True)
    subset_antisymmetry _ _ _ | Yes pa | Yes pb = rewrite pa in
                                                  rewrite pb in
                                                  Refl
    subset_antisymmetry f _ x | Yes pa | No nb = absurd . nb $ f x pa
  subset_antisymmetry _ g x | No pa with (decEq (sb x) True)
    subset_antisymmetry _ _ _ | No na | No nb = rewrite notTrueIsFalse na in
                                                rewrite notTrueIsFalse nb in
                                                Refl
    subset_antisymmetry _ g x | No na | Yes pb = absurd . na $ g x pb

export
subset_transitivity : {0 sa, sb, sc : InSet a} -> (0 _ : sa <= sb) -> (0 _ : sb <= sc) -> sa <= sc
subset_transitivity f g x y = rewrite g x (f x y) in Refl

-- Subset relation's totality seems to be unprovable for intensional sets neither in
--   `Either (sa <= sb) (sb <= sa)`, nor in `Not $ sa <= sb => sb <= sa` variant.

--- Alternative subset representations with unions and intersections ---

export
subset_thru_union : {sa, sb : InSet a} -> (0 _ : sa <= sb) -> sa + sb == sb
subset_thru_union f x with (decEq (sa x) True)
  subset_thru_union f x | Yes pa = rewrite pa in
                                   rewrite f x pa in
                                   Refl
  subset_thru_union _ _ | No na = rewrite notTrueIsFalse na in Refl

export
union_thru_subset : {0 sa, sb : InSet a} -> (0 _ : sa + sb == sb) -> sa <= sb
union_thru_subset f x y = rewrite sym $ f x in
                          rewrite y in
                          Refl

export
subset_thru_intersection : {sa, sb : InSet a} -> (0 _ : sa <= sb) -> sa # sb == sa
subset_thru_intersection f x with (decEq (sa x) True)
  subset_thru_intersection f x | Yes pa = rewrite pa in
                                          rewrite f x pa in
                                          Refl
  subset_thru_intersection _ _ | No na = rewrite notTrueIsFalse na in Refl

export
intersection_thru_subset : {0 sa, sb : InSet a} -> (0 _ : sa # sb == sa) -> sa <= sb
intersection_thru_subset f x pa = rewrite sym pa in
                                  rewrite sym $ f x in
                                  rewrite pa in
                                  Refl

--- Subset with binary set operations ---

export
subset_for_unioned_right : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa <= sb) -> sa <= sb + sc
subset_for_unioned_right sc f x prf = rewrite f x prf in Refl

and_true_left_true : (a, b : Bool) -> a && b = True -> a = True
and_true_left_true True _ _ = Refl

export
subset_for_intersected_left : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa <= sb) -> (sa # sc) <= sb
subset_for_intersected_left sc f x prf = rewrite f x $ and_true_left_true (sa x) (sc x) prf in Refl

export
subset_for_diffed_left : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa <= sb) -> (sa - sc) <= sb
subset_for_diffed_left sc f x prf = rewrite f x $ and_true_left_true (sa x) (x `notin` sc) prf in Refl

-- Particular cases for the properties from above, where `sb = sa`

export
subset_refl_unioned_right : (0 sa, sc : InSet a) -> sa <= sa + sc
subset_refl_unioned_right sa sc = subset_for_unioned_right sc $ subset_reflexivity sa

export
subset_refl_intersected_left : (0 sa, sc : InSet a) -> (sa # sc) <= sa
subset_refl_intersected_left sa sc = subset_for_intersected_left sc $ subset_reflexivity sa

export
subset_refl_diffed_left : (0 sa, sc : InSet a) -> (sa - sc) <= sa
subset_refl_diffed_left sa sc = subset_for_diffed_left sc $ subset_reflexivity sa

--- Subset with complement ---

export
subset_of_complements : {0 sa, sb : InSet a} -> (0 _ : sa <= sb) -> complement sb <= complement sa
subset_of_complements f x prf = rewrite sym $ subset_thru_intersection f x in
                                rewrite the (sb x = False) $ rewrite sym $ notInvolutive $ sb x in cong not prf in
                                rewrite andFalseFalse $ sa x in
                                Refl

export
subset_of_complements_back : {0 sa, sb : InSet a} -> (0 _ : complement sb <= complement sa) -> sa <= sb
subset_of_complements_back f x prf = rewrite sym $ subset_of_complements f x (rewrite notInvolutive $ sa x in prf) in
                                     rewrite notInvolutive $ sb x in
                                     Refl

--------------------------------------------------
--- Congruence of relations in specializations ---
--------------------------------------------------

--- Append ---

export
append_eq_cong_l : Equality a => (0 s : InSet a) -> {0 n, m : a} -> (0 _ : n = m) -> n::s == m::s
append_eq_cong_l _ prf _ = rewrite prf in Refl

export
append_eq_cong_r : Equality a => {0 sa, sb : InSet a} -> (n : a) -> (0 _ : sa == sb) -> n::sa == n::sb
append_eq_cong_r n f x with (x =?= n)
  append_eq_cong_r _ _ _ | True = Refl
  append_eq_cong_r _ f x | False = rewrite f x in Refl

--- Union ---

export
union_eq_cong_l : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa == sb) -> sa + sc == sb + sc
union_eq_cong_l _ f x = rewrite f x in Refl

export
union_eq_cong_r : {0 sa, sb : InSet a} -> (0 sc : InSet a) -> (0 _ : sa == sb) -> sc + sa == sc + sb
union_eq_cong_r _ f x = rewrite f x in Refl

-- particular case for `append_eq_cong_l`
export
union_singleton_eq_cong_l : Equality a => (0 s : InSet a) -> {0 n, m : a} -> (0 _ : n = m) -> [n] + s == [m] + s
union_singleton_eq_cong_l _ prf x = rewrite append_eq_cong_l [] prf x in Refl

-- TODO to add for subset

--- Intersection ---

-- TODO to add for equality

-- TODO to add for subset

--- Difference ---

-- TODO to add for equality

-- TODO to add for subset

--- Symmetrical difference ---

-- TODO to add for equality

-- TODO to add for subset

--- Complement ---

-- TODO to add for equality

-- TODO to add for subset

--- Cartesian product ---

export
cart_eq_cong_l : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa == sb) -> sc * sa == sc * sb
cart_eq_cong_l _ f (_, y) = rewrite f y in Refl

export
cart_eq_cong_r : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa == sb) -> sa * sc == sb * sc
cart_eq_cong_r _ f (x, _) = rewrite f x in Refl

and_true_then_left_true : (a : Bool) -> {b : Bool} -> a && b = True -> a = True
and_true_then_left_true True {b=True} Refl = Refl

and_true_then_right_true : {a : Bool} -> (b : Bool) -> a && b = True -> b = True
and_true_then_right_true {a=True} True Refl = Refl

export
cart_subset_cong_l : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa <= sb) -> sc * sa <= sc * sb
cart_subset_cong_l sc f (y, x) prf = rewrite f x $ and_true_then_right_true _ prf in
                                     rewrite and_true_then_left_true (sc y) prf in
                                     Refl

export
cart_subset_cong_r : {0 sa, sb : InSet a} -> (0 sc : InSet c) -> (0 _ : sa <= sb) -> sa * sc <= sb * sc
cart_subset_cong_r sc f (x, y) prf = rewrite f x $ and_true_then_left_true _ prf in
                                     rewrite and_true_then_right_true (sc y) prf in
                                     Refl

----------------------
--- Laws of `isin` ---
----------------------

export
not_in_empty : Equality a => (0 x : a) -> x `isin` [] = False
not_in_empty _ = Refl

export
x_in_x_etc : Equality a => (0 x : a) -> (0 s : InSet a) -> x `isin` (x::s) = True
x_in_x_etc x s = rewrite equ_reflexive x in Refl

export
x_in_same_etc : Equality a => (0 x, y : a) -> (0 s : InSet a) -> (0 _ : x =?= y = True) -> x `isin` (y::s) = True
x_in_same_etc _ _ _ prf = rewrite prf in Refl

export
not_x_not_in_x_etc : Equality a => (x, y : a) -> NeqPrf x y -> x `isin` [y] = False
not_x_not_in_x_etc x y neq = case @@(x =?= y) of
  (False ** prf) => rewrite prf in Refl
  (True ** prf) => absurd $ cant_eq_neq (eq_val_to_prf prf) neq

export
not_in_both : Equality a => (0 x, y : a) -> (0 ys : InSet a) -> (0 _ : x =?= y = False) -> (0 _ : x `isin` ys = False) -> x `isin` (y::ys) = False
not_in_both x y ys xy xys = rewrite xy in
                            rewrite xys in
                            Refl

export
is_in_tail : Equality a => (0 x, y : a) -> (0 ys : InSet a) -> (0 _ : x =?= y = False) -> (0 _ : x `isin` (y::ys) = True) -> x `isin` ys = True
is_in_tail _ _ _ xy xyys = rewrite sym xyys in
                           rewrite xy in
                           Refl

----------------------
--- Laws of append ---
----------------------

export
append_is_union : Equality a => (n : a) -> (0 s : InSet a) -> n::s == [n] + s
append_is_union n _ x with (x =?= n)
  append_is_union _ _ _ | True = Refl
  append_is_union _ _ _ | False = Refl

---------------------
--- Laws of union ---
---------------------

export
union_of_self : (0 s : InSet a) -> s + s == s
union_of_self s x = rewrite orSameNeutral $ s x in Refl

export
union_commutative : (0 sa, sb : InSet a) -> sa + sb == sb + sa
union_commutative sa sb x = rewrite orCommutative (sa x) (sb x) in Refl

export
union_associative : (0 sa, sb, sc : InSet a) -> sa + (sb + sc) == (sa + sb) + sc
union_associative sa sb sc x = rewrite orAssociative (sa x) (sb x) (sc x) in Refl

export
union_empty_neutral : (0 s : InSet a) -> s + [] == s
union_empty_neutral s x = rewrite orFalseNeutral $ s x in Refl

export
union_preserves_universe : (0 s : InSet a) -> s + Universe == Universe
union_preserves_universe s x = rewrite orTrueTrue $ s x in Refl

-- ... with intersection

export
union_distributes_over_intersection : (0 sa, sb, sc : InSet a) -> sa + (sb # sc) == (sa + sb) # (sa + sc)
union_distributes_over_intersection sa sb sc x = rewrite orDistribAndR (sa x) (sb x) (sc x) in Refl

-- ... with diff

export
union_with_diff : (0 sa, sb, sc : InSet a) -> sa + (sb - sc) == (sa + sb) - (sc - sa)
union_with_diff sa sb sc x = rewrite orDistribAndR (sa x) (sb x) (not $ sc x) in
                             rewrite notAndIsOr (sc x) (not $ sa x) in
                             rewrite notInvolutive $ sa x in
                             rewrite orCommutative (sa x) (not $ sc x) in
                             Refl

-- ... with symdiff

-- TODO To make this functon to have `(0 sa, sb : InSet a)` in the signature.
export
union_thru_symdiff_and_intersection : (sa, sb : InSet a) -> sa + sb == (sa ^ sb) ^ (sa # sb)
union_thru_symdiff_and_intersection sa sb x = case (decEq (sa x) True, decEq (sb x) True) of
  (Yes pa, Yes pb) => rewrite pa in                 rewrite pb in                 Refl
  (Yes pa, No  nb) => rewrite pa in                 rewrite notTrueIsFalse nb in  Refl
  (No  na, Yes pb) => rewrite notTrueIsFalse na in  rewrite pb in                 Refl
  (No  na, No  nb) => rewrite notTrueIsFalse na in  rewrite notTrueIsFalse nb in  Refl

-- ... with complement

export
union_with_its_complement : (0 s : InSet a) -> s + complement s == Universe
union_with_its_complement s x = rewrite orNotTrue $ s x in Refl

----------------------------
--- Laws of intersection ---
----------------------------

export
intersection_of_self : (0 s : InSet a) -> s # s == s
intersection_of_self s x = rewrite andSameNeutral $ s x in Refl

export
intersection_commutative : (0 sa, sb : InSet a) -> sa # sb == sb # sa
intersection_commutative sa sb x = rewrite andCommutative (sa x) (sb x) in Refl

export
intersection_associative : (0 sa, sb, sc : InSet a) -> sa # (sb # sc) == (sa # sb) # sc
intersection_associative sa sb sc x = rewrite andAssociative (sa x) (sb x) (sc x) in Refl

export
intersection_universe_neutral : (0 s : InSet a) -> s # Universe == s
intersection_universe_neutral s x = rewrite andTrueNeutral $ s x in Refl

export
intersection_preserves_empty : (0 s : InSet a) -> s # [] == []
intersection_preserves_empty s x = rewrite andFalseFalse $ s x in Refl

-- ... with union

export
intersection_distributes_over_union : (0 sa, sb, sc : InSet a) -> sa # (sb + sc) == (sa # sb) + (sa # sc)
intersection_distributes_over_union sa sb sc x = rewrite andDistribOrR (sa x) (sb x) (sc x) in Refl

-- ... with set diff

export
intersection_diff_swap : (0 sa, sb, sc : InSet a) -> sa # (sb - sc) == sb # (sa - sc)
intersection_diff_swap sa sb sc x = rewrite andAssociative (sa x) (sb x) (not $ sc x) in
                                    rewrite andAssociative (sb x) (sa x) (not $ sc x) in
                                    rewrite andCommutative (sa x) (sb x) in
                                    Refl

export
intersection_diff_assoc : (0 sa, sb, sc : InSet a) -> sa # (sb - sc) == (sa # sb) - sc
intersection_diff_assoc sa sb sc x = rewrite sym $ andAssociative (sa x) (sb x) (not $ sc x) in Refl

-- ... with symmetrical diff

-- TODO To make this functon to have `(0 sa, sb, sc : InSet a)` in the signature.
export
intersection_distributes_over_symdiff : (sa, sb, sc : InSet a) -> sa # (sb ^ sc) == (sa # sb) ^ (sa # sc)
intersection_distributes_over_symdiff sa sb sc x = case decEq (sa x) True of
  Yes pa => rewrite pa in Refl
  No na => rewrite notTrueIsFalse na in Refl

-- ... with complement

export
intersection_with_complement : (0 sa, sb : InSet a) -> sa # complement sb == sa - sb
intersection_with_complement _ _ _ = Refl

export
intersection_with_its_complement : (0 s : InSet a) -> s # complement s == []
intersection_with_its_complement s x = rewrite andNotFalse $ s x in Refl

------------------------------
--- Laws of set difference ---
------------------------------

export
diff_of_intersection : (0 sa, sb, sc : InSet a) -> sc - (sa # sb) == (sc - sa) + (sc - sb)
diff_of_intersection sa sb sc x = rewrite notAndIsOr (sa x) (sb x) in
                                  rewrite andDistribOrR (sc x) (not $ sa x) (not $ sb x) in
                                  Refl

export
diff_of_union : (0 sa, sb, sc : InSet a) -> sc - (sa + sb) == (sc - sa) # (sc - sb)
diff_of_union sa sb sc x = rewrite notOrIsAnd (sa x) (sb x) in
                           rewrite andAssociative (sc x && not (sa x)) (sc x) (not $ sb x) in
                           rewrite sym $ andAssociative (sc x) (not $ sa x) (sc x) in
                           rewrite andCommutative (not $ sa x) (sc x) in
                           rewrite andAssociative (sc x) (sc x) (not $ sa x) in
                           rewrite andSameNeutral $ sc x in
                           rewrite andAssociative (sc x) (not $ sa x) (not $ sb x) in
                           Refl

export
diff_of_diff : (0 sa, sb, sc : InSet a) -> sc - (sb - sa) == (sc # sa) + (sc - sb)
diff_of_diff sa sb sc x = rewrite notAndIsOr (sb x) (not $ sa x) in
                          rewrite notInvolutive $ sa x in
                          rewrite orCommutative (not $ sb x) (sa x) in
                          rewrite andDistribOrR (sc x) (sa x) (not $ sb x) in
                          Refl

export
diff_of_self : (0 s : InSet a) -> s - s == []
diff_of_self s x = rewrite andNotFalse $ s x in Refl

export
diff_of_empty_left : (0 s : InSet a) -> [] - s == []
diff_of_empty_left _ _ = Refl

export
diff_of_empty_right : (0 s : InSet a) -> s - [] == s
diff_of_empty_right s x = rewrite andTrueNeutral $ s x in Refl

export
diff_of_universe : (0 s : InSet a) -> s - Universe == []
diff_of_universe s x = rewrite andFalseFalse $ s x in Refl

export
diff_of_complements : (0 sa, sb : InSet a) -> complement sa - complement sb == sb - sa
diff_of_complements sa sb x = rewrite andCommutative (sb x) (not $ sa x) in
                              rewrite notInvolutive $ sb x in
                              Refl

--------------------------------------
--- Laws of symmetrical difference ---
--------------------------------------

-- TODO To make this functon to have `(0 sa, sb : InSet a)` in the signature.
export
symdiff_as_union_of_diffs : (sa, sb : InSet a) -> sa ^ sb == (sa - sb) + (sb - sa)
symdiff_as_union_of_diffs sa sb x = case (decEq (sa x) True, decEq (sb x) True) of
  (Yes pa, Yes pb) => rewrite pa in                 rewrite pb in                 Refl
  (Yes pa, No  nb) => rewrite pa in                 rewrite notTrueIsFalse nb in  Refl
  (No  na, Yes pb) => rewrite notTrueIsFalse na in  rewrite pb in                 Refl
  (No  na, No  nb) => rewrite notTrueIsFalse na in  rewrite notTrueIsFalse nb in  Refl

-- TODO To make this functon to have `(0 sa, sb : InSet a)` in the signature.
export
symdiff_as_diff_of_ui : (sa, sb : InSet a) -> sa ^ sb == (sa + sb) - (sa # sb)
symdiff_as_diff_of_ui sa sb x = case (decEq (sa x) True, decEq (sb x) True) of
  (Yes pa, Yes pb) => rewrite pa in                 rewrite pb in                 Refl
  (Yes pa, No  nb) => rewrite pa in                 rewrite notTrueIsFalse nb in  Refl
  (No  na, Yes pb) => rewrite notTrueIsFalse na in  rewrite pb in                 Refl
  (No  na, No  nb) => rewrite notTrueIsFalse na in  rewrite notTrueIsFalse nb in  Refl

export
symdiff_commutative : (0 sa, sb : InSet a) -> sa ^ sb == sb ^ sa
symdiff_commutative sa sb x = rewrite xorCommutative (sa x) (sb x) in Refl

export
symdiff_associative : (0 sa, sb, sc : InSet a) -> sa ^ (sb ^ sc) == (sa ^ sb) ^ sc
symdiff_associative sa sb sc x = rewrite xorAssociative (sa x) (sb x) (sc x) in Refl

export
symdiff_with_empty : (0 s : InSet a) -> s ^ [] == s
symdiff_with_empty s x = rewrite xorCommutative (s x) False in
                         rewrite xorFalseNeutral $ s x in
                         Refl

export
symdiff_with_self : (0 s : InSet a) -> s ^ s == []
symdiff_with_self s x = rewrite xorSameFalse $ s x in Refl

-- TODO To make this functon to have `(0 sa, sb, sc : InSet a)` in the signature.
export
symdiff_twice_negates : (sa, sb, sc : InSet a) -> (sa ^ sb) ^ (sb ^ sc) == sa ^ sc
symdiff_twice_negates sa sb sc x = rewrite xorCommutative (sa x) (sb x) in
                                   case decEq (sb x) True of
                                     Yes pb => rewrite pb in
                                               rewrite xorTrueNot $ sa x in
                                               rewrite xorTrueNot $ sc x in
                                               rewrite notXorCancel (sa x) (sc x) in
                                               Refl
                                     No nb => rewrite notTrueIsFalse nb in
                                              rewrite xorFalseNeutral $ sa x in
                                              rewrite xorFalseNeutral $ sc x in
                                              Refl

export
symdiff_of_complements : (0 sa, sb : InSet a) -> sa ^ sb == complement sa ^ complement sb
symdiff_of_complements sa sb x = rewrite notXorCancel (sa x) (sb x) in Refl

--------------------------
--- Laws of complement ---
--------------------------

export
comp_of_union : (0 sa, sb : InSet a) -> complement (sa + sb) == complement sa # complement sb
comp_of_union sa sb x = rewrite notOrIsAnd (sa x) (sb x) in Refl

export
comp_of_intersection : (0 sa, sb : InSet a) -> complement (sa # sb) == complement sa + complement sb
comp_of_intersection sa sb x = rewrite notAndIsOr (sa x) (sb x) in Refl

export
comp_of_empty : complement [] == Universe
comp_of_empty _ = Refl

export
comp_of_universe : complement Universe == []
comp_of_universe _ = Refl

export
comp_involutive : (0 s : InSet a) -> complement (complement s) == s
comp_involutive s x = rewrite notInvolutive $ s x in Refl

export
comp_of_diff : (0 sa, sb : InSet a) -> complement (sa - sb) == complement sa + sb
comp_of_diff sa sb x = rewrite notAndIsOr (sa x) (not $ sb x) in
                       rewrite notInvolutive $ sb x in
                       Refl

---------------------------------
--- Laws of cartesian product ---
---------------------------------

--- Operations over cartesian products at both sides:

export
intersection_of_carts : (0 sa, sb : InSet a) -> (0 sc, sd : InSet c) -> (sa * sc) # (sb * sd) == (sa # sb) * (sc # sd)
intersection_of_carts sa sb sc sd (x, y) = rewrite sym $ andAssociative (sa x) (sc y) (sb x && sd y) in
                                           rewrite sym $ andAssociative (sa x) (sb x) (sc y && sd y) in
                                           rewrite andAssociative (sc y) (sb x) (sd y) in
                                           rewrite andAssociative (sb x) (sc y) (sd y) in
                                           rewrite andCommutative (sb x) (sc y) in
                                           Refl

export
diff_of_carts : (0 sa, sb : InSet a) -> (0 sc, sd : InSet c) -> (sa * sc) - (sb * sd) == sa * (sc - sd) + (sa - sb) * sc

export
union_of_carts : (0 sa, sb : InSet a) -> (0 sc, sd : InSet c) -> (sa * sc) + (sb * sd) == ((sa - sb) * sc) # ((sa # sb) * (sc + sd)) # ((sb - sa) * sd)

--- Distributivity:

export
cart_distributes_over_intersection : (0 sa : InSet a) -> (0 sb, sc : InSet b) -> sa * (sb # sc) == (sa * sb) # (sa * sc)
cart_distributes_over_intersection sa sb sc (x, y) = rewrite sym $ andAssociative (sa x) (sb y) (sa x && sc y) in
                                                     rewrite andAssociative (sb y) (sa x) (sc y) in
                                                      rewrite andCommutative (sb y) (sa x) in
                                                     rewrite sym $ andAssociative (sa x) (sb y) (sc y) in
                                                     rewrite andAssociative (sa x) (sa x) (sb y && sc y) in
                                                      rewrite andSameNeutral (sa x) in
                                                     Refl

export
cart_distributes_over_union : (0 sa : InSet a) -> (0 sb, sc : InSet b) -> sa * (sb + sc) == (sa * sb) + (sa * sc)

export
cart_distributes_over_diff : (0 sa : InSet a) -> (0 sb, sc : InSet b) -> sa * (sb - sc) == (sa * sb) - (sa * sc)

export
complement_of_cart : (0 sa : InSet a) -> (0 sb : InSet b) -> complement (sa * sb) = (complement sa * complement sb) + (complement sa * sb) + (sa * complement sb)

--- Cartesian products with relations

export
subset_of_carts_drops_l : {0 sa, sb : InSet a} -> {0 sc, sd : InSet c} -> (0 _ : NotEmpty sa) -> (0 _ : NotEmpty sc) ->
                          (0 _ : (sa * sc) <= (sb * sd)) -> sa <= sb

export
subset_of_carts_drops_r : {0 sa, sb : InSet a} -> {0 sc, sd : InSet c} -> (0 _ : NotEmpty sa) -> (0 _ : NotEmpty sc) ->
                          (0 _ : (sa * sc) <= (sb * sd)) -> sc <= sd

export
cart_of_subsets : {0 sa, sb : InSet a} -> {0 sc, sd : InSet c} -> (0 _ : sa <= sb) -> (0 _ : sc <= sd) -> (sa * sc) <= (sb * sd)


module Eq

data Matter : Type where
     Solid : Matter
     Liquid : Matter
     Gas : Matter

Eq Matter where
   (==) Solid Solid = True
   (==) Liquid Liquid = True
   (==) Gas Gas = True
   (==) _ _ = False
   (/=) x y = not (x == y)

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


import Data.Vect

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

{-
transposeHelper : (x : Vect n elem)
               -> (xTrans : Vect n (Vect k elem))
               -> Vect n (Vect (S k) elem)
transposeHelper [] [] = []
transposeHelper (x :: xs) (y :: ys) = (x :: y) :: transposeHelper xs ys
-}

transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = let xTrans = transposeMat xs in
                             zipWith (::) x xTrans

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

addMatrix' : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
addMatrix' mat1 mat2 = zipWith (zipWith (+)) mat1 mat2

(+) : Num a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a)
(+) = addMatrix

-- Exercise 3
multVecs : Num a => (xs : Vect n a) -> (ys : Vect n a) -> a
multVecs xs ys = sum (zipWith (*) xs ys)

makeRow : Num a => (x : Vect n a)
                -> (ysTrans : Vect p (Vect n a))
                -> Vect p a
makeRow x [] = []
makeRow x (y :: xs) = multVecs x y :: makeRow x xs

multMatrixHelper : Num a => (xs : Vect m (Vect n a))
                         -> (ysTrans : Vect p (Vect n a))
                         -> Vect m (Vect p a)
multMatrixHelper [] ysTrans = []
multMatrixHelper (x :: xs) ysTrans
     = makeRow x ysTrans :: multMatrixHelper xs ysTrans

multMatrix : Num a => Vect m (Vect n a)
                   -> Vect n (Vect p a)
                   -> Vect m (Vect p a)
multMatrix xs ys = let ysTrans = transposeMat ys
                   in  multMatrixHelper xs ysTrans


module Raytracer
import Units
import Vector
import PPM

%default total

data Point = P (Dim Meters) (Dim Meters) (Dim Meters)

data Ray = R Point Vector

(+) : Point -> Vector -> Point
(P (M x) (M y) (M z)) + (V a b c) = P (M (x + a)) (M (y + b)) (M (z + c))

data Object : Type where
  Sphere : (center : Point) -> (radius : Dim Meters) -> Object

toRad : Dim Degrees -> Dim Radians
toRad (Deg d) = Rad $ d * (pi / 180)

tan : Dim Radians -> Float
tan (Rad r) = tan r

record Scene : Type where
  MkScene : (objects : List Object) ->
            (lights : List Point) -> -- light sources
            (camera : Point) -> -- camera location
            (lookingAt : Point) ->
            (fieldOfView : Dim Degrees) ->
            (background : Color) ->
            Scene

width : Scene -> Float
width s = tan (toRad (fieldOfView s)) * 2

height : Scene -> Float
height = width

--trace : Ray -> Scene -> Color
--


import Data.Vect

-- Defining functions by pattern matching
invert : Bool -> Bool
invert True = False
invert False = True

describeList : List Int -> String
describeList [] = "Empty"
describeList (x :: xs) = "Non-empty, tail = " ++ show xs

-- Given just the type declaration below, can use Ctrl-Alt-A in Atom to add a
-- definition.
allLengths_list : List String -> List Nat
-- allLengths_list list = ?rhs -- put the cursor on list and do ctrl-alt-c in
-- Atom to expand the cases as below:
-- allLengths_list [] = ?rhs_1
-- allLengths_list (x :: xs) = ?rhs_2
allLengths_list [] = []
allLengths_list (x :: xs) = length x :: allLengths_list xs
-- Check if allLengths_list is total
-- :total allLengths_list -> Main.allLengths_list is Total

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

-- :doc List pulls up the documentation for List.
-- In Atom, ctrl-alt-D

-- Data types are defined in terms of their constructors, a bit like Java enum
-- members but often with parameters.

-- mutual lets you define functions that call each other, otherwise Idris
-- requires everything to be top-down.

mutual
  isEven : Nat -> Bool
  isEven Z = True
  isEven (S k) = not $ isOdd k

  isOdd : Nat -> Bool
  isOdd Z = False
  isOdd (S k) = not $ isEven k

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

sixInts : Vect 6 Int
sixInts = [4, 5, 6, 7, 8, 9]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

insert : Ord elem => (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: ys) = if (x < y) then (x :: y :: ys) else (y :: insert x ys)

insertSort : (Ord elem) => Vect n elem -> Vect n elem
insertSort [] = []
insertSort (x :: xs) = insert x (insertSort xs)

my_length : List a -> Nat
my_length [] = Z
my_length (x :: xs) = S (my_length xs)

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

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

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

-- total makes sure it won't compile if it's not total, total meaning every
-- scenario is accounted for.

-- I struggled with this, something about two-dimensional arrays seems to cause
-- me problems. Transposing means taking the top row, transposing the rest
-- recursively, then prefixing each transposed row with the values from the top
-- row to form a new column.

-- Ctrl-Alt-T in Atom to find types, only works on the right hand side.
-- Ctrl-Alt-A to add missing cases
-- Ctrl-Alt-C to split out a case by destructuring a particular variable
-- Ctrl-Alt-S to do an expression search, if the type is specific enough it
-- can fill in a right hand side.

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

prefixEach : (x : Vect n elem) -> Vect n (Vect k elem) -> Vect n (Vect (S k) elem)
prefixEach [] [] = []
prefixEach (x :: xs) (y :: ys) = (x :: y) :: prefixEach xs ys

total transposeMat : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat [] = createEmpties
transposeMat (x :: xs) = prefixEach x (transposeMat xs)

-- Exercise 1 - reimplement using zipWith

total transposeMat_zipWith : Vect m (Vect n elem) -> Vect n (Vect m elem)
transposeMat_zipWith [] = replicate _ []
transposeMat_zipWith (x :: xs) = zipWith (::) x (transposeMat_zipWith xs)

-- Exercise 2

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

-- Exercise 3

-- [1 2]     [ 7  8  9 10]   [1*7 + 2*11 = 29] -- sum(row 1 * column 1)
-- [3 4]  x  [11 12 13 14] =
-- [5 6]

-- Transposing:
-- [1 2]     [ 7 11]   [1*7 + 2*11, 1*8 + 2*12, 1*9 + 2*13, 1*10 + 2*14]
-- [3 4]  x  [ 8 12] = [3*7 + 4*11, 3*8 + 4*12, 3*9 + 4*13, 3*10 + 4*14]
-- [5 6]     [ 9 13]   [5*7 + 6*11, 5*8 + 6*12, 5*9 + 6*13, 5*10 + 6*14]
--           [10 14]

multMatrix : Num a => Vect n (Vect m a) -> Vect m (Vect p a) -> Vect n (Vect p a)
multMatrix xs ys = multHelper xs (transposeMat_zipWith ys)
  where
    sumOneRow : Num a => Vect m a -> Vect m a -> a
    sumOneRow xs ys = sum (zipWith (*) xs ys)

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

-- Implicit values: _ means infer the value.
-- Implicit parameters: {param: Type} means infer the parameter.

vect_length : Vect n elem -> Nat
vect_length {n} xs = n -- {n} brings the argument into scope

createEmpties_inferred : Vect n (Vect 0 a)
createEmpties_inferred {n = Z} = []
createEmpties_inferred {n = (S k)} = [] :: createEmpties


module NewEden.Natural

import Prelude.Either
import public Prelude.Uninhabited

import public NewEden.Algebra
import public NewEden.NaturalAxioms
import public NewEden.NaturalPropertiesHelpers -- compiler bug #144; can't use private in types

{- Natural

   Natural p is a natural number expressed in terms of operations on a given
   set of NaturalProperties p.

   Everything else in this module is expressing the axioms given in
   NaturalProperties in terms of operations on Natural p, so now
   we can use Natural p much the same as we would the 'normal' numeric types.
-}

data Natural : NaturalProperties t -> Type where
  MkNatural : (n:NaturalProperties t) -> (a:t) -> Natural n

value : {p:NaturalProperties t} -> Natural p -> t
value {p} (MkNatural p x) = x

properties : {p:NaturalProperties t} -> Natural p -> NaturalProperties t
properties (MkNatural p _) = p

(+) : {p:NaturalProperties t} -> Natural p -> Natural p -> Natural p
(+) {p} (MkNatural p x) (MkNatural p y) =
  MkNatural p $ privatePlus p x y

(*) : {p:NaturalProperties t} -> Natural p -> Natural p -> Natural p
(*) {p} (MkNatural p x) (MkNatural p y) =
  MkNatural p $ privateMultiply p x y

{- fromInteger

   This is the first place we see the real power of an axiomatic implementation.
   Here we are able to construct arbitrary natural numbers and put them in the
   compiler's head in *logarithmic* space (rather than linear space, like the Peano Nat).
-}

fromInteger : Integer -> Natural p
fromInteger rem =
  let z = MkNatural p (zero p) in
  let o = MkNatural p (one p) in
  case rem of
    0 => z
    1 => o
    _ =>
         case (assert_total $ prim__sremBigInt rem 2) of
           0 => (o + o) * (assert_total $ fromInteger (prim__sdivBigInt rem 2))
           1 => o + (assert_total $ fromInteger (prim__subBigInt rem 1))
           _ => o -- impossible

-- force resolution of 0 to Natural p, since occasionally 0 is
-- ambiguous (e.g., right below in zeroIsNotOne)
Z : (p:NaturalProperties t) -> Natural p
Z p = 0

zeroIsNotOne : (p:NaturalProperties t) -> (Z p = 1 -> Void)
zeroIsNotOne p =
  let prf = NewEden.NaturalPropertiesHelpers.privateZeroIsNotOne p in
  (\given => prf $ equalityMap value given)

plusCommutative : (p:NaturalProperties t) -> CommutativeFunction (Natural p) (+)
plusCommutative p =
  let (MkCommutativeFunction _ prf) = NewEden.NaturalPropertiesHelpers.privatePlusCommutative p in
  MkCommutativeFunction
    (+)
    (\(MkNatural p x),(MkNatural p y) => equalityMap (MkNatural p) $ prf x y)

plusAssociative : (p:NaturalProperties t) -> AssociativeFunction (Natural p) (+)
plusAssociative p =
  let (MkMonoid af _ _ _) = NewEden.NaturalPropertiesHelpers.privatePlusMonoid p in
  let (MkAssociativeFunction _ prf) = af in
  MkAssociativeFunction
    (+)
    (\(MkNatural p x),(MkNatural p y),(MkNatural p z) => equalityMap (MkNatural p) $ prf x y z)

plusMonoid : (p:NaturalProperties t) -> NewEden.Algebra.Monoid (Natural p) (+) 0
plusMonoid P =
  let (MkMonoid _ _ p1 p2) = NewEden.NaturalPropertiesHelpers.privatePlusMonoid P in
  MkMonoid
    (plusAssociative P)
    (Z P)
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p1 x)
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p2 x)

plusLacksInverses : (p:NaturalProperties t) -> StrictMonoid $ NewEden.Natural.plusMonoid p
plusLacksInverses P =
  let (MkStrictMonoid _ prf) = NewEden.NaturalPropertiesHelpers.privatePlusLacksInverses P in
  MkStrictMonoid
    (plusMonoid P)
    (\(MkNatural P x),(MkNatural P y),given =>
      let given' = equalityMap value $ given in
      equalityMap (MkNatural P) $ prf x y given'
    )

plusMonomorphic : (p:NaturalProperties t) -> ((n:Natural p) -> MonomorphicFunction $ (+) n)
plusMonomorphic p =
  let g = NewEden.NaturalPropertiesHelpers.privatePlusMonomorphic p in
  (\(MkNatural p x) =>
    let (MkMonomorphicFunction _ prf) = g x in
    MkMonomorphicFunction
      ((+) (MkNatural p x))
      (\(MkNatural p y),(MkNatural p z),given =>
        equalityMap (MkNatural p) $ prf y z (equalityMap value given)
      )
  )

multiplyCommutative : (p:NaturalProperties t) -> CommutativeFunction (Natural p) (*)
multiplyCommutative p =
  let (MkCommutativeFunction _ prf) = NewEden.NaturalPropertiesHelpers.privateMultiplyCommutative p in
  MkCommutativeFunction
    (*)
    (\(MkNatural p x),(MkNatural p y) => equalityMap (MkNatural p) $ prf x y)

multiplyAssociative : (p:NaturalProperties t) -> AssociativeFunction (Natural p) (*)
multiplyAssociative p =
  let (MkMonoid af _ _ _) = NewEden.NaturalPropertiesHelpers.privateMultiplyMonoid p in
  let (MkAssociativeFunction _ prf) = af in
  MkAssociativeFunction
    (*)
    (\(MkNatural p x),(MkNatural p y),(MkNatural p z) => equalityMap (MkNatural p) $ prf x y z)

multiplyMonoid : (p:NaturalProperties t) -> NewEden.Algebra.Monoid (Natural p) (*) 1
multiplyMonoid P =
  let (MkMonoid _ _ p1 p2) = NewEden.NaturalPropertiesHelpers.privateMultiplyMonoid P in
  MkMonoid
    (multiplyAssociative P)
    1
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p1 x)
    (\(MkNatural P x) => equalityMap (MkNatural P) $ p2 x)

multiplyLacksInverses : (p:NaturalProperties t) -> StrictMonoid $ NewEden.Natural.multiplyMonoid p
multiplyLacksInverses P =
  let (MkStrictMonoid _ prf) = NewEden.NaturalPropertiesHelpers.privateMultiplyLacksInverses P in
  MkStrictMonoid
    (multiplyMonoid P)
    (\(MkNatural P x),(MkNatural P y),given =>
      let given' = equalityMap value $ given in
      equalityMap (MkNatural P) $ prf x y given'
    )

multiplyMonomorphic : (p:NaturalProperties t) -> ((n:Natural p) -> MonomorphicFunction $ (*) n)
multiplyMonomorphic p =
  let g = NewEden.NaturalPropertiesHelpers.privateMultiplyMonomorphic p in
  (\(MkNatural p x) =>
    let (MkMonomorphicFunction _ prf) = g x in
    MkMonomorphicFunction
      ((*) (MkNatural p x))
      (\(MkNatural p y),(MkNatural p z),given =>
        equalityMap (MkNatural p) $ prf y z (equalityMap value given)
      )
  )

multiplyByZeroIsZero : (p:NaturalProperties t) -> ((a:(Natural p)) -> a * 0 = 0)
multiplyByZeroIsZero P =
  let prf = NewEden.NaturalPropertiesHelpers.privateMultiplyByZero P in
  (\(MkNatural P x) => equalityMap (MkNatural P) $ prf x)

multiplyDistributive : (p:NaturalProperties t) -> ((a:Natural p) -> (b:Natural p) -> (c:Natural p) -> a * (b + c) = (a * b) + (a * c))
multiplyDistributive p =
  let prf = NewEden.NaturalPropertiesHelpers.privateDistributiveProperty p in
  (\(MkNatural p x),(MkNatural p y),(MkNatural p z) =>
    equalityMap (MkNatural p) $ prf x y z
  )

naturalNoNumbersBetweenZeroAndOne : (p:NaturalProperties t) -> ((a:Natural p) -> (b:Natural p) -> (p1:(a = 0 -> Void)) -> (p2: a + b = 1) -> a = 1)
naturalNoNumbersBetweenZeroAndOne P =
  let lemmaSequence = NewEden.NaturalPropertiesHelpers.privateSequenceProperty P in
  (\(MkNatural P x),(MkNatural P y),given1,given2 =>
    let given1' = (\lemma => given1 $ equalityMap (MkNatural P) lemma) in
    let given2' = equalityMap value given2 in
    equalityMap (MkNatural P) $ lemmaSequence x y given1' given2'
  )

data LessThan : (a:Natural p) -> (b:Natural p) -> Type where
  MkLessThan : (a:Natural p) -> (b:Natural p) -> (c ** ((a + c = b), (c = 0 -> Void))) -> LessThan a b

data Trichotomy : (a:Type) -> (b:Type) -> (c:Type) -> Type where
  Left : {a:Type} -> {b:Type} -> {c:Type} -> (x:a) -> Trichotomy a b c
  Middle : {a:Type} -> {b:Type} -> {c:Type} -> (x:b) -> Trichotomy a b c
  Right : {a:Type} -> {b:Type} -> {c:Type} -> (x:c) -> Trichotomy a b c

compare : ((a:Natural p) -> (b:Natural p) -> Trichotomy (LessThan a b) (a = b) (LessThan b a))
compare (MkNatural p x) (MkNatural p y) =
  let prf = NewEden.NaturalPropertiesHelpers.privateCompare p in
  case prf x y of
    Left h => Middle $ equalityMap (MkNatural p) h
    Right r => case r of
      Left (c**(h,prf')) =>
        let lt = MkLessThan (MkNatural p x) (MkNatural p y) in
        Left $ lt ((MkNatural p c) ** ((equalityMap (MkNatural p) h),
                  (\prf'' => prf' $ equalityMap value prf'')))
      Right (c**(r,prf')) =>
        let lt = MkLessThan (MkNatural p y) (MkNatural p x) in
        Right $ lt ((MkNatural p c) ** ((equalityMap (MkNatural p) r),(\prf'' => prf' $ equalityMap value prf'')))

(-) : (a:Natural p) -> (b:Natural p) -> {auto prf:((LessThan a b) -> Void)} -> Natural p
(-) {prf} a b = case compare a b of
  Left x => absurd (prf x)
  Middle _ => 0
  Right (MkLessThan _ _ (c ** _)) => c


module FibGCD

import Data.Nat

import Decidable.Equality

fib : Nat -> Nat
fib 0 = 0
fib 1 = 1
fib (S $ S n) = fib (S n) + fib n

%hint
fib_isSucc : (n : Nat) -> IsSucc n => IsSucc (fib n)

fib_gcd : {n, m : Nat} -> case fib_isSucc (S n) of ItIsSucc => gcd {ok=LeftIsNotZero} (fib $ S n) (fib $ S m) = fib (gcd (S n) (S m))


-- Example of a union type.
||| Represents shapes.
data Shape = ||| A triangle, with its base length and height
             Triangle Double Double
           | ||| A rectangle, with its lengths and height
             Rectangle Double Double
           | ||| A circle, with its radius
             Circle Double

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


module NewEden.Algebra

%default total

data AssociativeFunction : (t:Type) -> (f:(t -> t -> t)) -> Type where
  MkAssociativeFunction :
      (f:(t -> t -> t))
   -> (prf:((a:t) -> (b:t) -> (c:t) -> f a (f b c) = f (f a b) c))
   -> AssociativeFunction t f

data CommutativeFunction : (t:Type) -> (f:(t -> t -> t)) -> Type where
  MkCommutativeFunction :
      (f:(t -> t -> t))
   -> (prf:((a:t) -> (b:t) -> f a b = f b a))
   -> CommutativeFunction t f

data MonomorphicFunction : (t1 -> t2) -> Type where
  MkMonomorphicFunction :
      (f:(t1 -> t2))
   -> ((a:t1) -> (b:t1) -> f a = f b -> a = b)
   -> MonomorphicFunction f

data Monoid : (t:Type) -> (f:(t -> t -> t)) -> (zero:t) -> Type where
  MkMonoid :
      (lemma:AssociativeFunction t f)
   -> (zero:t)
   -> (prf1:((a:t) -> f a zero = a))
   -> (prf2:((a:t) -> f zero a = a))
   -> Monoid t f zero

-- monoid which is strictly not strong enough to be a group (proven lack of inverses)
data StrictMonoid : (m:Monoid t f z) -> Type where
  MkStrictMonoid :
      (m:Monoid t f z)
   -> (prfNoInverses:((a:t) -> (b:t) -> (p:(f a b = z)) -> (a = z)))
   -> StrictMonoid m

data Group : Monoid t f z -> Type where
  MkGroup :
      (m:Monoid t f z)
   -> (prfInverse:((a:t) -> (b : t ** (f a b = z))))
   -> Group m

data Coproduct : (C : Type) -> Type where
  MkCoproduct :
      {C : Type}
   -> (coproduct : C -> C -> C)
   -> ((x1 : C) -> (x2 : C) ->
        (
           i1 : C -> C **
           (
             i2 : C -> C **
             (
               i1 x1 = coproduct x1 x2
             , i2 x2 = coproduct x1 x2
             , (x : C) ->
               (
                 f1 : C -> C **
                 (
                   f2 : C -> C **
                   (
                     f1 x1 = x
                   , f2 x2 = x
                   , (f : C -> C **
                     (
                       f $ coproduct x1 x2 = x
                     , ((c : C) -> f1 c = f (i1 c))
                     , ((c : C) -> f2 c = f (i2 c))
                     , ((f' : C -> C)
                         -> f' $ coproduct x1 x2 = x
                         -> ((c : C) -> f1 c = f' (i1 c))
                         -> ((c : C) -> f2 c = f' (i2 c))
                         -> ((n : C) -> f' c = f c)
                       )
                     ))
                   )
                 )
               )
             )
           )
        )
      )
   -> Coproduct C

data Product : (C : Type) -> Type where
  MkProduct :
      {C : Type}
   -> (product : C -> C -> C)
   -> ((x1 : C) -> (x2 : C) ->
       (
         p1 : C -> C **
         (
           p2 : C -> C **
           ((y : C) ->
            (f1 : C -> C) ->
            f1 y = x1 ->
            (f2 : C -> C) ->
            f2 y = x2 ->
            (
              f : C -> C **
              (
                f y = product x1 x2
              , ((c : C) -> p1 (f c) = f1 c)
              , ((c : C) -> p2 (f c) = f2 c)
              , ((f' : C -> C) ->
                 f' y = product x1 x2 ->
                 ((c : C) -> p1 (f' c) = f1 c) ->
                 ((c : C) -> p2 (f' c) = f2 c) ->
                 ((c : C) -> f' c = f c)
                )
              )
            )
           )
         )
       )
      )
   -> Product C

data InitialObject : (C : Type) -> Type where
  MkInitialObject :
      {C : Type}
   -> (initialObject : C)
   -> ((x : C) ->
       (f : C -> C **
        ( (f initialObject = x)
        , ((f' : C -> C) ->
           f' initialObject = x ->
           ((c : C) -> f' c = f c)
          )
        )
       )
      )
   -> InitialObject C

data TerminalObject : (C : Type) -> Type where
  MkTerminalObject :
      {C : Type}
   -> (terminalObject : C)
   -> ((x : C) ->
       (f : C -> C **
        ((f x = terminalObject)
        , ((f' : C -> C) ->
           f' x = terminalObject ->
           ((c : C) -> f' c = f c)
          )
        )
       )
      )
   -> TerminalObject C

data Isomorphism : (t:Type) -> (u:Type) -> (f:(t -> u)) -> (g:(u -> t)) -> Type where
  MkIsomorphism : (t:Type) -> (u:Type) -> (f:(t -> u)) -> (g:(u -> t)) -> ((a:t) -> g (f a) = a) -> ((a:u) -> f (g a) = a) -> Isomorphism t u f g

equalityMap : (f:(t -> u)) -> a = b -> f a = f b
equalityMap f Refl = Refl

transitivity : a = b -> b = c -> a = c
transitivity Refl Refl = Refl

symmetric : a = b -> b = a
symmetric Refl = Refl

substitution : {t1:Type} -> {t2:Type} -> {a:t1} -> {b:t1} -> {c:t2} -> (f:t1 -> t2) -> a = b -> f a = c -> f b = c
substitution _ Refl Refl = Refl


import Data.Vect

append_nil : Vect m elem -> Vect (plus m 0) elem
append_nil {m} xs = rewrite plusZeroRightNeutral m in xs

append_xs : Vect (S (m + k)) elem -> Vect (plus m (S k)) elem
append_xs {m} {k} xs = rewrite sym
                       (plusSuccRightSucc m k) in xs

append : Vect n elem -> Vect m elem -> Vect (m + n) elem
append [] ys = append_nil ys
append (x :: xs) ys = append_xs (x :: append xs ys)


module Control.Algebra.ZZVerifiedInstances
-- We will forego treating this as Control.Algebra.NumericVerifiedInstances

import Data.ZZ
import Control.Algebra
import Classes.Verified
import Control.Algebra.NumericInstances

%default total

-- These can be proven through an isomorphism with the free ring on the empty type.

monoidNeutralIsNeutralL_ZZ : (l : ZZ) -> l <+> Algebra.neutral = l
monoidNeutralIsNeutralL_ZZ (Pos n) = cong {f=Pos} $ plusZeroRightNeutral n
monoidNeutralIsNeutralL_ZZ (NegS n) = Refl

monoidNeutralIsNeutralR_ZZ : (r : ZZ) -> Algebra.neutral <+> r = r
monoidNeutralIsNeutralR_ZZ (Pos n) = cong {f=Pos} $ plusZeroLeftNeutral n
monoidNeutralIsNeutralR_ZZ (NegS n) = Refl

negPlusNegnatToNegnatPlus : (l, r : Nat) -> (NegS l) <+> negNat r = negNat $ S $ l `plus` r
negPlusNegnatToNegnatPlus l Z = rewrite plusZeroRightNeutral l in Refl
negPlusNegnatToNegnatPlus l (S predr) = cong {f=NegS} $ plusSuccRightSucc l predr

onePlusMinusNatReduction : (a, b : Nat) -> Pos 1 <+> minusNatZ a (S b) = minusNatZ a b
onePlusMinusNatReduction Z b = Refl
onePlusMinusNatReduction (S preda) Z = Refl
onePlusMinusNatReduction (S preda) (S predb) = onePlusMinusNatReduction preda predb

plusNegOneMinusNatProduction : (a, b : Nat) -> minusNatZ a b <+> NegS 0 = minusNatZ a (S b)
plusNegOneMinusNatProduction Z Z = Refl
plusNegOneMinusNatProduction Z (S predb) = rewrite plusZeroRightNeutral predb in Refl
plusNegOneMinusNatProduction (S preda) Z = Refl
plusNegOneMinusNatProduction (S preda) (S predb) = plusNegOneMinusNatProduction preda predb

abelianGroupOpIsCommutative_ZZ : (l, r : ZZ) -> l <+> r = r <+> l
abelianGroupOpIsCommutative_ZZ (Pos n) (Pos m) = cong $ plusCommutative _ _
abelianGroupOpIsCommutative_ZZ (NegS n) (NegS m) = cong {f=NegS . S} $ plusCommutative _ _
abelianGroupOpIsCommutative_ZZ (Pos n) (NegS m) = Refl
abelianGroupOpIsCommutative_ZZ (NegS n) (Pos m) = Refl

total
semigroupOpIsAssociative_ZZ : (l, c, r : ZZ) -> l <+> (c <+> r) = l <+> c <+> r
semigroupOpIsAssociative_ZZ (Pos l) (Pos c) (Pos r) = cong $ plusAssociative _ _ _
semigroupOpIsAssociative_ZZ (Pos l) (Pos Z) (NegS r) = rewrite plusZeroRightNeutral l in Refl
semigroupOpIsAssociative_ZZ (Pos l) (Pos (S predc)) (NegS Z) = rewrite sym $ plusSuccRightSucc l predc in Refl
semigroupOpIsAssociative_ZZ (Pos l) (Pos (S predc)) (NegS (S predr)) = rewrite sym $ plusSuccRightSucc l predc in assert_total $ semigroupOpIsAssociative_ZZ (Pos l) (Pos predc) (NegS predr)
semigroupOpIsAssociative_ZZ (Pos l) (NegS Z) (Pos Z) = sym $ monoidNeutralIsNeutralL_ZZ _
semigroupOpIsAssociative_ZZ (Pos Z) (NegS Z) (Pos (S predr)) = Refl
semigroupOpIsAssociative_ZZ (Pos (S predl)) (NegS Z) (Pos (S predr)) = rewrite plusSuccRightSucc predl predr in Refl
semigroupOpIsAssociative_ZZ (Pos Z) (NegS (S predc)) (Pos r) = monoidNeutralIsNeutralR_ZZ _
semigroupOpIsAssociative_ZZ (Pos (S predl)) (NegS (S predc)) (Pos Z) = sym $ monoidNeutralIsNeutralL_ZZ _
semigroupOpIsAssociative_ZZ (Pos l) (NegS (S predc)) (Pos (S predr)) = trans (assert_total $ semigroupOpIsAssociative_ZZ (Pos l) (NegS predc) (Pos predr))
	$ trans (cong {f=(<+> Pos predr)}
		$ trans (sym $ onePlusMinusNatReduction l (S predc))
		$ abelianGroupOpIsCommutative_ZZ (Pos 1) (minusNatZ l $ S $ S predc))
	$ sym $ assert_total $ semigroupOpIsAssociative_ZZ _ (Pos 1) (Pos predr)
semigroupOpIsAssociative_ZZ (Pos Z) (NegS c) (NegS r) = Refl
semigroupOpIsAssociative_ZZ (Pos (S predl)) (NegS Z) (NegS r) = Refl
semigroupOpIsAssociative_ZZ (Pos (S predl)) (NegS (S predc)) (NegS r) = assert_total $ semigroupOpIsAssociative_ZZ (Pos predl) (NegS predc) (NegS r)
semigroupOpIsAssociative_ZZ (NegS l) (Pos Z) (Pos r) = Refl
semigroupOpIsAssociative_ZZ (NegS Z) (Pos (S predc)) (Pos r) = Refl
semigroupOpIsAssociative_ZZ (NegS (S predl)) (Pos (S predc)) (Pos r) = assert_total $ semigroupOpIsAssociative_ZZ (NegS predl) (Pos predc) (Pos r)
semigroupOpIsAssociative_ZZ (NegS l) (Pos Z) (NegS Z) = Refl
semigroupOpIsAssociative_ZZ (NegS l) (Pos Z) (NegS (S predr)) = Refl
semigroupOpIsAssociative_ZZ (NegS l) (Pos (S predc)) (NegS Z) = sym $ plusNegOneMinusNatProduction predc l
{-
* Recurses to case [ (NegS l) (Pos predc) (NegS predr) ]
* Depends on cases for [ x (NegS 0) (NegS predr) ]
-}
semigroupOpIsAssociative_ZZ (NegS l) (Pos (S predc)) (NegS (S predr)) = trans (assert_total $ semigroupOpIsAssociative_ZZ (NegS l) (Pos predc) (NegS predr))
	$ trans (cong {f=flip plusZ $ NegS predr} $ sym $ plusNegOneMinusNatProduction predc l)
	$ sym $ assert_total $ semigroupOpIsAssociative_ZZ ((NegS l)<+>(Pos (S predc))) (NegS 0) (NegS predr)
semigroupOpIsAssociative_ZZ (NegS l) (NegS Z) (Pos Z) = Refl
semigroupOpIsAssociative_ZZ (NegS l) (NegS Z) (Pos (S predr)) = rewrite plusZeroRightNeutral l in Refl
semigroupOpIsAssociative_ZZ (NegS l) (NegS c) (Pos Z) = Refl
semigroupOpIsAssociative_ZZ (NegS l) (NegS (S predc)) (Pos (S predr)) = rewrite sym $ plusSuccRightSucc l predc in assert_total $ semigroupOpIsAssociative_ZZ (NegS l) (NegS predc) (Pos predr)
semigroupOpIsAssociative_ZZ (NegS l) (NegS c) (NegS r) = rewrite sym $ plusSuccRightSucc l (c+r) in cong {f=NegS . S . S} $ plusAssociative l c r

minusNatZSelfZ : (n : Nat) -> minusNatZ n n = Pos 0
minusNatZSelfZ Z = Refl
minusNatZSelfZ (S predn) = minusNatZSelfZ predn

groupInverseIsInverseL_ZZ : (l : ZZ) -> l <+> inverse l = Algebra.neutral
groupInverseIsInverseL_ZZ (Pos Z) = Refl
groupInverseIsInverseL_ZZ (Pos (S predn)) = trans (cong {f=minusNatZ predn} $ multOneRightNeutral predn) $ minusNatZSelfZ predn
groupInverseIsInverseL_ZZ (NegS n) = trans (cong {f=flip minusNatZ n} $ multOneRightNeutral n) $ minusNatZSelfZ n

groupInverseIsInverseR_ZZ : (r : ZZ) -> inverse r <+> r = Algebra.neutral
groupInverseIsInverseR_ZZ (Pos Z) = Refl
groupInverseIsInverseR_ZZ (Pos (S predn)) = trans (cong {f=minusNatZ predn} $ multOneRightNeutral predn) $ minusNatZSelfZ predn
groupInverseIsInverseR_ZZ (NegS n) = trans (cong {f=flip minusNatZ n} $ multOneRightNeutral n) $ minusNatZSelfZ n

multZPosZRightZero : (left : ZZ) -> multZ left (Pos 0) = Pos 0
multZPosZRightZero (Pos n) = cong {f=Pos} $ multZeroRightZero _
multZPosZRightZero (NegS n) = cong {f=negNat} $ multZeroRightZero _

multZPosZLeftZero : (right : ZZ) -> multZ (Pos 0) right = Pos 0
multZPosZLeftZero (Pos n) = Refl
multZPosZLeftZero (NegS n) = Refl

ringOpIsAssociative_ZZ : (l, c, r : ZZ) -> l <.> (c <.> r) = l <.> c <.> r
ringOpIsAssociative_ZZ (Pos l) (Pos c) (Pos r) = cong $ multAssociative _ _ _
ringOpIsAssociative_ZZ (NegS l) (Pos Z) (Pos r) = rewrite cong {f=negNat} $ multZeroRightZero l in Refl
ringOpIsAssociative_ZZ (NegS l) (Pos c) (Pos Z) = trans (rewrite multZeroRightZero c in rewrite multZeroRightZero l in Refl) $ sym $ multZPosZRightZero _
ringOpIsAssociative_ZZ (NegS l) (Pos (S predc)) (Pos (S predr)) = cong {f=negNat} $ multAssociative (S l) (S predc) (S predr)
ringOpIsAssociative_ZZ (NegS l) (NegS c) (Pos Z) = rewrite multZeroRightZero c in trans (cong {f=negNat} $ multZeroRightZero l) $ cong {f=Pos} $ sym $ multZeroRightZero $ _
ringOpIsAssociative_ZZ (NegS l) (NegS c) (Pos (S predr)) = cong {f=Pos} $ multAssociative (S l) (S c) (S predr)
ringOpIsAssociative_ZZ (NegS l) (Pos Z) (NegS r) = rewrite multZeroRightZero l in Refl
ringOpIsAssociative_ZZ (NegS l) (Pos (S predc)) (NegS r) = cong {f=Pos} $ multAssociative (S l) (S predc) (S r)
ringOpIsAssociative_ZZ (NegS l) (NegS c) (NegS r) = cong {f=negNat} $ multAssociative (S l) (S c) (S r)
ringOpIsAssociative_ZZ (Pos Z) (NegS c) (Pos r) = multZPosZLeftZero _
ringOpIsAssociative_ZZ (Pos l) (NegS c) (Pos Z) = rewrite multZeroRightZero c in trans (multZPosZRightZero (Pos l)) $ sym $ multZPosZRightZero _
ringOpIsAssociative_ZZ (Pos (S predl)) (NegS c) (Pos (S predr)) = cong {f=negNat} $ multAssociative (S predl) (S c) (S predr)
ringOpIsAssociative_ZZ (Pos Z) (Pos c) (NegS r) = multZPosZLeftZero _
ringOpIsAssociative_ZZ (Pos l) (Pos Z) (NegS r) = rewrite (multZeroRightZero l) in Refl
ringOpIsAssociative_ZZ (Pos (S predl)) (Pos (S predc)) (NegS r) = cong {f=negNat} $ multAssociative (S predl) (S predc) (S r)
ringOpIsAssociative_ZZ (Pos Z) (NegS c) (NegS r) = Refl
ringOpIsAssociative_ZZ (Pos (S predl)) (NegS c) (NegS r) = cong {f=Pos} $ multAssociative (S predl) (S c) (S r)

negativeIsNegOneTimesRight : (right : ZZ) -> inverse right = (inverse Algebra.unity) <.> right
negativeIsNegOneTimesRight (Pos r) = cong {f=negNat} $ trans (multOneRightNeutral r) $ sym $ plusZeroRightNeutral r
negativeIsNegOneTimesRight (NegS r) = cong {f=Pos . S} $ trans (multOneRightNeutral r) $ sym $ plusZeroRightNeutral r

minusNatZNegOneTimesFlip : multZ (NegS 0) $ minusNatZ a b = minusNatZ b a
minusNatZNegOneTimesFlip {a=Z} {b=Z} = Refl
minusNatZNegOneTimesFlip {a=Z} {b=S predb} = cong {f=Pos . S} $ plusZeroRightNeutral predb
minusNatZNegOneTimesFlip {a=S preda} {b=Z} = cong {f=NegS} $ plusZeroRightNeutral preda
minusNatZNegOneTimesFlip {a=S preda} {b=S predb} = minusNatZNegOneTimesFlip {a=preda} {b=predb}

negOneDistributesL_ZZ : (c, r : ZZ) -> (inverse Algebra.unity) <.> (c <+> r) = (inverse Algebra.unity)<.>c <+> (inverse Algebra.unity)<.>r
negOneDistributesL_ZZ (Pos Z) r = rewrite monoidNeutralIsNeutralR_ZZ (NegS 0 <.> r) in rewrite monoidNeutralIsNeutralR_ZZ r in Refl
negOneDistributesL_ZZ (Pos (S predc)) (Pos Z) = rewrite plusZeroRightNeutral predc in rewrite plusZeroRightNeutral predc in Refl
negOneDistributesL_ZZ (Pos (S predc)) (Pos (S predr)) = rewrite plusZeroRightNeutral predr in rewrite plusZeroRightNeutral predc in rewrite plusZeroRightNeutral (predc+(S predr)) in cong {f=NegS} $ sym $ plusSuccRightSucc predc predr
negOneDistributesL_ZZ (Pos (S Z)) (NegS Z) = Refl
negOneDistributesL_ZZ (Pos (S $ S predc)) (NegS Z) = Refl
negOneDistributesL_ZZ (Pos (S predc)) (NegS (S predr)) = trans minusNatZNegOneTimesFlip $ rewrite plusZeroRightNeutral predc in rewrite plusZeroRightNeutral predr in Refl
negOneDistributesL_ZZ (NegS c) (Pos Z) = rewrite plusZeroRightNeutral c in rewrite plusZeroRightNeutral c in Refl
negOneDistributesL_ZZ (NegS c) (Pos (S predr)) = rewrite plusZeroRightNeutral c in rewrite plusZeroRightNeutral predr in minusNatZNegOneTimesFlip
negOneDistributesL_ZZ (NegS c) (NegS r) = cong {f=Pos . S} $ rewrite plusZeroRightNeutral (c+r) in rewrite plusZeroRightNeutral c in rewrite plusZeroRightNeutral r in plusSuccRightSucc c r

total
ringOpIsDistributiveL_ZZ : ( l, c, r : ZZ ) -> l <.> (c <+> r) = l <.> c <+> l <.> r
ringOpIsDistributiveL_ZZ (Pos l) (Pos c) (Pos r) = cong {f=Pos} $ multDistributesOverPlusRight _ _ _
ringOpIsDistributiveL_ZZ (NegS l) (Pos Z) (Pos r) = rewrite (multZeroRightZero l) in sym $ plusZeroLeftNeutralZ _
ringOpIsDistributiveL_ZZ (NegS l) (Pos (S predc)) (Pos r) = trans (cong {f=negNat} $ multDistributesOverPlusRight (S l) (S predc) r) $ sym $ negPlusNegnatToNegnatPlus _ _
ringOpIsDistributiveL_ZZ (Pos l) (NegS c) (Pos Z) = rewrite multZeroRightZero l in sym $ plusZeroRightNeutralZ _
-- if (r) is a successor, induce from the theorem on its predecessor.
ringOpIsDistributiveL_ZZ (Pos l) (NegS c) (Pos (S predr)) = trans (trans (cong $ sym $ onePlusMinusNatReduction predr c) $
	trans (assert_total $ ringOpIsDistributiveL_ZZ (Pos l) (Pos 1) (minusNatZ predr (S c))) $ rewrite multOneRightNeutral l in Refl)
	$ trans (cong {f=((Pos l)<+>)} $ assert_total $ ringOpIsDistributiveL_ZZ (Pos l) (NegS c) (Pos predr))
	$ trans (semigroupOpIsAssociative_ZZ (Pos l) (negNat $ mult l $ S c) $ Pos $ mult l predr)
	$ trans ( trans (cong {f=flip plusZ $ Pos $ mult l predr} $ abelianGroupOpIsCommutative_ZZ (Pos l) (negNat $ mult l $ S c))
		$ sym $ semigroupOpIsAssociative_ZZ (negNat $ mult l $ S c) (Pos l) (Pos $ mult l predr))
	$ cong {f=(plusZ $ negNat $ mult l $ S c) . Pos}
		$ trans (cong {f=flip plus $ mult l predr} $ sym $ multOneRightNeutral l)
		$ sym $ multDistributesOverPlusRight l 1 predr
-- reduces to 3 and the special case (negOneDistributesL_ZZ)
ringOpIsDistributiveL_ZZ (NegS l) (NegS c) (Pos r) = trans (cong {f=(flip multZ $ minusNatZ r $ S c) . NegS} $ sym $ plusZeroRightNeutral l)
	$ trans (sym $ ringOpIsAssociative_ZZ (inverse Algebra.unity) (Pos (S l)) $ minusNatZ r (S c))
	$ trans (cong {f=multZ $ inverse unity} $ assert_total $ ringOpIsDistributiveL_ZZ (Pos (S l)) (NegS c) (Pos r))
	$ trans (negOneDistributesL_ZZ (Pos (S l) <.> NegS c) (Pos (S l) <.> Pos r))
	$ trans (cong $ sym $ negativeIsNegOneTimesRight (Pos (S l) <.> Pos r))
	$ trans (cong {f=(flip plusZ $ negNat (mult (plus r (mult l r)) 1)) . Pos . S} $ plusZeroRightNeutral _)
	$ cong {f=plusZ $ Pos $ S $ plus c $ mult l $ S c} $ cong {f=negNat} $ multOneRightNeutral _
-- reduces to 3
ringOpIsDistributiveL_ZZ (Pos l) (Pos c) (NegS r) = trans (cong {f=((Pos l) <.>)} $ abelianGroupOpIsCommutative_ZZ (Pos c) (NegS r))
	$ trans (assert_total $ ringOpIsDistributiveL_ZZ (Pos l) (NegS r) (Pos c))
	$ abelianGroupOpIsCommutative_ZZ ((Pos l)<.>(NegS r)) ((Pos l)<.>(Pos c))
-- reduces to 4
ringOpIsDistributiveL_ZZ (NegS l) (Pos c) (NegS r) = trans (cong {f=((NegS l) <.>)} $ abelianGroupOpIsCommutative_ZZ (Pos c) (NegS r))
	$ trans (assert_total $ ringOpIsDistributiveL_ZZ (NegS l) (NegS r) (Pos c))
	$ abelianGroupOpIsCommutative_ZZ ((NegS l)<.>(NegS r)) ((NegS l)<.>(Pos c))
ringOpIsDistributiveL_ZZ (Pos Z) (NegS c) (NegS r) = Refl
ringOpIsDistributiveL_ZZ (Pos (S predl)) (NegS c) (NegS r) = cong {f=NegS . S}
	$ trans (cong
		$ trans (cong $ plusSuccRightSucc (S c) r)
		$ multDistributesOverPlusRight predl (S c) (S r))
	$ trans (sym $ plusAssociative c r _)
	$ trans (cong {f=plus c}
		$ trans (plusCommutative r _)
		$ trans (sym $ plusAssociative (mult predl $ S c) (mult predl $ S r) r)
		$ cong $ plusCommutative _ r)
	$ plusAssociative c (mult predl $ S c) $ plus r $ mult predl $ S r
-- Reduces to 7 and the special case (negOneDistributesL_ZZ)
-- mirrors the proof of case [(NegS l) (NegS c) (Pos r)].
ringOpIsDistributiveL_ZZ (NegS l) (NegS c) (NegS r) = trans (rewrite sym $ plusZeroRightNeutral l in Refl)
	-- THIS LINE HERE IS CLEARER THAN IN case [(NegS l) (NegS c) (Pos r)]'s proof! Change (NegS r) to (Pos r).
	$ trans (sym $ ringOpIsAssociative_ZZ (inverse Algebra.unity) (Pos (S l)) $ NegS c <+> NegS r)
	$ trans (cong {f=multZ $ inverse unity} $ assert_total $ ringOpIsDistributiveL_ZZ (Pos (S l)) (NegS c) (NegS r))
	$ trans (negOneDistributesL_ZZ (Pos (S l) <.> NegS c) (Pos (S l) <.> NegS r))
	$ trans ( cong {f=plusZ (multZ (NegS 0) (Pos (S l) <.> NegS c))} $ sym $ negativeIsNegOneTimesRight (Pos (S l) <.> NegS r) )
	{-
	HERE THE PROOF IS DIFFERENT BECAUSE THE CONGs ON THE (multOneRightNeutral)
	WOULD HAVE TO BE DIFFERENT.
	-}
	$ trans (rewrite plusZeroRightNeutral $ c+l*(S c) in Refl)
	$ rewrite multOneRightNeutral (r+l*(S r)) in Refl

ringOpIsCommutative_ZZ : ( l, r : ZZ ) -> l <.> r = r <.> l
ringOpIsCommutative_ZZ (Pos l) (Pos r) = cong $ multCommutative l r
ringOpIsCommutative_ZZ (NegS l) (Pos r) = cong {f=negNat} $ multCommutative (S l) r
ringOpIsCommutative_ZZ (Pos l) (NegS r) = cong {f=negNat} $ multCommutative l (S r)
ringOpIsCommutative_ZZ (NegS l) (NegS r) = cong {f=Pos} $ multCommutative (S l) (S r)

ringOpIsDistributiveR_ZZ : ( l, c, r : ZZ ) -> (l <+> c) <.> r = l <.> r <+> c <.> r
ringOpIsDistributiveR_ZZ l c r = trans (ringOpIsCommutative_ZZ (l<+>c) r)
	$ trans (ringOpIsDistributiveL_ZZ r l c)
	$ trans (cong {f=((r<.>l) <+>)} $ ringOpIsCommutative_ZZ r c)
	$ cong {f=(<+> (c<.>r))} $ ringOpIsCommutative_ZZ r l

ringWithUnityIsUnityL_ZZ : ( l : ZZ ) -> l <.> Algebra.unity = l
ringWithUnityIsUnityL_ZZ (Pos l) = cong $ multOneRightNeutral l
ringWithUnityIsUnityL_ZZ (NegS l) = cong $ multOneRightNeutral l

ringWithUnityIsUnityR_ZZ : ( r : ZZ ) -> Algebra.unity <.> r = r
ringWithUnityIsUnityR_ZZ (Pos r) = cong $ multOneLeftNeutral r
ringWithUnityIsUnityR_ZZ (NegS r) = cong $ multOneLeftNeutral r

instance VerifiedSemigroup ZZ where
	semigroupOpIsAssociative = semigroupOpIsAssociative_ZZ

instance VerifiedMonoid ZZ where {
	monoidNeutralIsNeutralL = monoidNeutralIsNeutralL_ZZ
	monoidNeutralIsNeutralR = monoidNeutralIsNeutralR_ZZ
}

instance VerifiedGroup ZZ where {
	groupInverseIsInverseL = groupInverseIsInverseL_ZZ
	groupInverseIsInverseR = groupInverseIsInverseR_ZZ
}

instance VerifiedAbelianGroup ZZ where {
	abelianGroupOpIsCommutative = abelianGroupOpIsCommutative_ZZ
}

instance VerifiedRing ZZ where {
	ringOpIsAssociative = ringOpIsAssociative_ZZ
	ringOpIsDistributiveL = ringOpIsDistributiveL_ZZ
	ringOpIsDistributiveR = ringOpIsDistributiveR_ZZ
}

instance VerifiedRingWithUnity ZZ where {
	ringWithUnityIsUnityL = ringWithUnityIsUnityL_ZZ
	ringWithUnityIsUnityR = ringWithUnityIsUnityR_ZZ
}


module Marginalization

import Semiring
import HetVect
import Data.Morphisms

%default total
%access public export

prodFuncsV
  : Semiring n
  => {xs, ys: List Type}
  -> (Vect xs -> n)
  -> (Vect ys -> n)
  -> Vect (xs++ys)
  -> n
prodFuncsV {xs=[]} f g vs = f Nil * g vs
prodFuncsV {xs=x::xs} f g (y :: z) = prodFuncsV (f . (y::)) g z

||| A proof that every type in a given list belongs to a finite, bounded,
||| enumerable domain. Possibly better modelled in a more generic way (ie for
||| arbitrary constraints).
data AllFinite : List Type -> Type where
  Empty : AllFinite []
  Extra
    :  (rest : AllFinite xs)
    -> (MinBound x, MaxBound x, Enum x)
    => AllFinite (x::xs)

||| Maybe reformulate this in a tail-recursive way.
marg : (Semiring n, MinBound a, MaxBound a, Enum a) => (a -> n) -> n
marg f = sum (map f [minBound .. maxBound])

margOnce
  : (Semiring n, MinBound t, MaxBound t, Enum t)
  => (Vect (t::ts) -> n) -> (Vect ts -> n)
margOnce f = (applyMor . marg) (\x => Mor (f . (x::)))

margVec
  : Semiring n
  => {xs : List Type}
  -> {auto prf : AllFinite xs}
  -> (Vect xs -> n) -> n
margVec {xs=[]} f = f []
margVec {xs=x::xs} {prf=Extra rest} f = margVec (margOnce f)

margVecL
  : Semiring n
  => {xs, ys: List Type}
  -> {auto prf : AllFinite ys}
  -> (Vect (xs++ys) -> n)
  -> Vect xs -> n
margVecL f [] =  margVec f
margVecL f (x :: xs) = margVecL (\ys => f (x::ys)) xs

margVecR
  : Semiring n
  => {xs, ys: List Type}
  -> (Vect (xs++ys) -> n)
  -> {auto prf : AllFinite xs}
  -> Vect ys
  -> n
margVecR f = applyMor (margVec (\xs => Mor (\ys => f (xs++ys))))

finiteDistL
  : {xs, ys : List Type}
  -> (prf : AllFinite (xs++ys))
  -> AllFinite xs
finiteDistL {xs=[]} prf = Empty
finiteDistL {xs=x::xs} (Extra rest) = Extra (finiteDistL rest)

finiteDistR
  : {xs,ys : List Type}
  -> (prf : AllFinite (xs++ys))
  -> AllFinite ys
finiteDistR {xs=[]} prf = prf
finiteDistR {xs=x::xs} (Extra rest) = finiteDistR {xs} rest

-- elemConforms : {x : Type} -> {xs : List Type} -> (conform : AllFinite xs) -> (el : Elem x xs) -> Enum x
-- elemConforms (Extra rest) Here = Enum x
-- elemConforms conform (There x) = ?elemConforms_rhs_2

margVecAny
  :  Semiring n
  => {x : Type}
  -> {xs : List Type}
  -> (fin : AllFinite xs)
  -> (elem : Elem x xs)
  -> (Vect xs -> n)
  -> x -> n
margVecAny (Extra rest) Here f x = margVec {prf = rest} (f . (x::))
margVecAny (Extra rest) (There z) f x = margVecAny rest z (margOnce f) x

-- Can almost certainly be written quicker.
margAll
  :  Semiring s
  => {xs : List Type}
  -> {auto finite : AllFinite xs}
  -> curried xs s
  -> s
margAll = go where
  go
    :  Semiring s
    => {xs : List Type}
    -> {auto finite : AllFinite xs}
    -> curried xs s
    -> s
  go {finite = Empty} m = m
  go {finite = (Extra rest)} m =
    sum (map (go . m) [minBound .. maxBound])

prodFuncs
  : Semiring n
  => {xs: List Type}
  -> curried xs n
  -> curried xs n
  -> curried xs n
prodFuncs {xs=[]} x y = x * y
prodFuncs {n} {xs=x::xs} f g
  = \y => prodFuncs {n} {xs} (f y) (g y)


data Natural = Zero | S Natural

eval : Natural -> Int
eval Zero = 0
eval (S n) = succ (eval n)

fromInt : Int -> Natural
fromInt n = case n <= 0 of
  True      => Zero
  otherwise => S (fromInt (pred n))


data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)
%name Tree left, val, right

Eq elem => Eq (Tree elem) where
    (==) Empty Empty = ?Eq_rhs1_2
    (==) (Node left e right) (Node left' e' right') = left == left' && e == e' && right == right'
    (==) _ _ = False

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

listToTree : Ord a => List a -> Tree a
listToTree [] = Empty
listToTree (x :: xs) = let tree = listToTree xs in insert x tree

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


\iffalse
SPDX-License-Identifier: AGPL-3.0-only

This file is part of `idris-ct` Category Theory in Idris library.

Copyright (C) 2019 Stichting Statebox <https://statebox.nl>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public License
along with this program.  If not, see <https://www.gnu.org/licenses/>.
\fi

> module Monoid.MonoidMorphismAsFunctor
>
> import Basic.Category
> import Basic.Functor
> import Monoid.Monoid
> import Monoid.MonoidAsCategory
> import Monoid.MonoidMorphism
>
> -- contrib
> import Interfaces.Verified
>
> %access public export
> %default total
>
> monoidMorphismToFunctor :
>      (monoid1, monoid2 : Monoid)
>   -> MonoidMorphism monoid1 monoid2
>   -> CFunctor (monoidAsCategory monoid1) (monoidAsCategory monoid2)
> monoidMorphismToFunctor monoid1 monoid2 (MkMonoidMorphism fun frOp frId) =
>   MkCFunctor
>     id
>     (\_, _ => fun)
>     (\_ => frId)
>     (\_, _, _, f, g => frOp f g)


> module Main

> import Data.List

> import EscardoOliva.SelectionFunction
> import EscardoOliva.Quantifier
> import EscardoOliva.Operations

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

> data Player =  X | O

> Outcome : Type
> Outcome = Int

> Move : Type
> Move = Int

> Board : Type
> Board = (List Move, List Move)

> contained : {X : Type} -> Ord X => List X -> List X -> Bool
> contained       []        ys  = True
> contained       xs        []  = False
> contained (x :: xs) (y :: ys) = if x == y
>                                 then contained xs ys
>                                 else if x >= y
>                                      then contained (x :: xs) ys
>                                      else False

> someContained : {X : Type} -> Ord X =>
>                 List (List X) -> List X -> Bool
> someContained         []  ys  = False
> someContained        xss  []  = False
> someContained (xs :: xss) ys = contained xs ys || someContained xss ys

> wins : List Move -> Bool
> wins = someContained [[0,1,2],[3,4,5],[6,7,8],
>                       [0,3,6],[1,4,7],[2,5,8],
>                       [0,4,8],[2,4,6]]

> value : Board -> Outcome
> value (xs, os) = if wins xs
>                  then 1
>                  else if wins os
>                       then -1
>                       else 0

> insert : {X : Type} -> Ord X => X -> List X -> List X
> insert x [] = [x]
> insert x (y :: ys) = if x == y
>                      then (y :: ys)
>                      else if x < y
>                           then x :: (y :: ys)
>                           else y :: (insert x ys)

> outcome : Player -> List Move -> Board -> Board
> outcome _      Nil     board = board
> outcome X (m :: ms) (xs, os) = if wins os
>                                then (xs, os)
>                                else outcome O ms (insert m xs, os)
> outcome O (m :: ms) (xs, os) = if wins xs
>                                then (xs, os)
>                                else outcome X ms (xs, insert m os)

> delete : {X : Type} -> Ord X => X -> List X -> List X
> delete x [] = []
> delete x (y :: ys) = if x == y
>                      then ys
>                      else if x < y
>                           then y :: ys
>                           else y :: Main.delete x ys

> setMinus : {X : Type} -> Ord X =>
>            List X -> List X -> List X
> setMinus xs       []  = xs
> setMinus xs (y :: ys) = setMinus (Main.delete y xs) ys

> partial
> epsilons : List (List Move -> J Outcome Move)
> epsilons = take 3 all where
>   partial
>   eX  :  List Move -> J Outcome Move
>   eX  =  \ h => argsup (setMinus [0..8] h)
>   partial
>   eO  :  List Move -> J Outcome Move
>   eO  =  \ h => arginf (setMinus [0..8] h)
>   partial
>   all :  List (List Move -> J Outcome Move)
>   all =  [eX, eO, eX, eO, eX, eO, eX, eO, eX, eO]

> p : List Move -> Outcome
> p ms = value (outcome X ms (Nil, Nil))

> partial
> optimalPlay : List Move
> optimalPlay = bigotimes epsilons p

> partial
> optimalOutcome : Outcome
> optimalOutcome = p optimalPlay

> partial
> main : IO ()
> main =
>   do putStr ("An optimal play for Tic-Tac-Toe is "
>              ++
>              show optimalPlay ++ "\n"
>              ++
>              "and the optimal outcome is "
>              ++
>              show optimalOutcome ++ "\n"
>              )

> {-

> ---}


module Data.List.Equalities

import Data.List

%default total

||| A list constructued using snoc cannot be empty.
export
snocNonEmpty : {x : a} -> {xs : List a} -> Not (xs ++ [x] = [])
snocNonEmpty {xs = []} prf = uninhabited prf
snocNonEmpty {xs = y :: ys} prf = uninhabited prf

||| Proof that snoc'ed list is not empty in terms of `NonEmpty`.
export %hint
SnocNonEmpty : (xs : List a) -> (x : a) -> NonEmpty (xs `snoc` x)
SnocNonEmpty []     _ = IsNonEmpty
SnocNonEmpty (_::_) _ = IsNonEmpty

||| Two lists are equal, if their heads are equal and their tails are equal.
export
consCong2 : {x : a} -> {xs : List a} -> {y : b} -> {ys : List b} ->
            x = y -> xs = ys -> x :: xs = y :: ys
consCong2 Refl Refl = Refl

||| Equal non-empty lists should result in equal components after destructuring 'snoc'.
export
snocInjective : {x : a} -> {xs : List a} -> {y : a} -> {ys : List a} ->
            (xs `snoc` x) = (ys `snoc` y) -> (xs = ys, x = y)
snocInjective {xs = []} {ys = []} Refl = (Refl, Refl)
snocInjective {xs = []} {ys = z :: zs} prf =
  let nilIsSnoc = snd $ consInjective {xs = []} {ys = zs ++ [y]} prf
   in void $ snocNonEmpty (sym nilIsSnoc)
snocInjective {xs = z :: xs} {ys = []} prf =
  let snocIsNil = snd $ consInjective {x = z} {xs = xs ++ [x]} {ys = []} prf
   in void $ snocNonEmpty snocIsNil
snocInjective {xs = w :: xs} {ys = z :: ys} prf =
  let (wEqualsZ, xsSnocXEqualsYsSnocY) = consInjective prf
      (xsEqualsYS, xEqualsY) = snocInjective xsSnocXEqualsYsSnocY
   in (consCong2 wEqualsZ xsEqualsYS, xEqualsY)

||| Appending pairwise equal lists gives equal lists
export
appendCong2 : {x1 : List a} -> {x2 : List a} ->
              {y1 : List b} -> {y2 : List b} ->
              x1 = y1 -> x2 = y2 -> x1 ++ x2 = y1 ++ y2
appendCong2 {x1=[]} {y1=(_ :: _)} Refl _ impossible
appendCong2 {x1=(_ :: _)} {y1=[]} Refl _ impossible
appendCong2 {x1=[]} {y1=[]} _ eq2 = eq2
appendCong2 {x1=(_ :: _)} {y1=(_ :: _)} eq1 eq2 =
  let (hdEqual, tlEqual) = consInjective eq1
   in consCong2 hdEqual (appendCong2 tlEqual eq2)

||| List.map is distributive over appending.
export
mapDistributesOverAppend
  : (f : a -> b)
  -> (xs : List a)
  -> (ys : List a)
  -> map f (xs ++ ys) = map f xs ++ map f ys
mapDistributesOverAppend _ [] _ = Refl
mapDistributesOverAppend f (x :: xs) ys =
  cong (f x ::) $ mapDistributesOverAppend f xs ys

||| List.length is distributive over appending.
export
lengthDistributesOverAppend
  : (xs, ys : List a)
  -> length (xs ++ ys) = length xs + length ys
lengthDistributesOverAppend [] ys = Refl
lengthDistributesOverAppend (x :: xs) ys =
  cong S $ lengthDistributesOverAppend xs ys

||| Length of a snoc'd list is the same as Succ of length list.
export
lengthSnoc : (x : _) -> (xs : List a) -> length (snoc xs x) = S (length xs)
lengthSnoc x [] = Refl
lengthSnoc x (_ :: xs) = cong S (lengthSnoc x xs)

||| Appending the same list at left is injective.
export
appendSameLeftInjective : (xs, ys, zs : List a) -> zs ++ xs = zs ++ ys -> xs = ys
appendSameLeftInjective xs ys []      = id
appendSameLeftInjective xs ys (_::zs) = appendSameLeftInjective xs ys zs . snd . consInjective

||| Appending the same list at right is injective.
export
appendSameRightInjective : (xs, ys, zs : List a) -> xs ++ zs = ys ++ zs -> xs = ys
appendSameRightInjective xs ys [] = rewrite appendNilRightNeutral xs in
                                    rewrite appendNilRightNeutral ys in
                                    id
appendSameRightInjective xs ys (z::zs) = rewrite appendAssociative xs [z] zs in
                                         rewrite appendAssociative ys [z] zs in
                                         fst . snocInjective . appendSameRightInjective (xs ++ [z]) (ys ++ [z]) zs

||| List cannot be equal to itself prepended with some non-empty list.
export
appendNonEmptyLeftNotEq : (zs, xs : List a) -> NonEmpty xs => Not (zs = xs ++ zs)
appendNonEmptyLeftNotEq []      (_::_)  Refl impossible
appendNonEmptyLeftNotEq (z::zs) (_::xs) prf
  = appendNonEmptyLeftNotEq zs (xs ++ [z]) @{SnocNonEmpty xs z}
  $ rewrite sym $ appendAssociative xs [z] zs in snd $ consInjective prf

||| List cannot be equal to itself appended with some non-empty list.
export
appendNonEmptyRightNotEq : (zs, xs : List a) -> NonEmpty xs => Not (zs = zs ++ xs)
appendNonEmptyRightNotEq []      (_::_)  Refl impossible
appendNonEmptyRightNotEq (_::zs) (x::xs) prf = appendNonEmptyRightNotEq zs (x::xs) $ snd $ consInjective prf


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

import Data.Vect
import Effects
import Effect.State

-- Here we're going to include some algorithms related to Huth and Ryan's book, for practice

data Formula = Atom String | Disj Formula Formula | Conj Formula Formula
             | Imp Formula Formula | Neg Formula

-- we could do a CNF conversion to a different type but I'd also like to try seeing if
-- I can do a thing of converting to the same type and actually proving that it won't
-- produce terms outside the subset

noImp : Formula -> Formula
noImp (Atom x) = (Atom x)
noImp (Disj x y) = Disj (noImp x) (noImp y)
noImp (Conj x y) = Conj (noImp x) (noImp y)
noImp (Imp x y) = Disj (Neg x) y
noImp (Neg x) = Neg (noImp x)

-- now how do we state our property? Maybe something like

noImpCorrect : (f : Formula) -> (g : Formula) -> (h : Formula) -> (Imp g h) = (noImp f) -> Void
noImpCorrect (Atom _) _ _ Refl impossible
noImpCorrect (Disj _ _) _ _ Refl impossible
noImpCorrect (Conj _ _) _ _ Refl impossible
noImpCorrect (Imp _ _) _ _ Refl impossible
noImpCorrect (Neg _) _ _ Refl impossible

data Lit = PosAtom String | NegAtom String -- yes this is really just an either type

negLit : Lit -> Lit
negLit (PosAtom x) = NegAtom x
negLit (NegAtom x) = PosAtom x

instance Eq Lit where
  (PosAtom x) == (PosAtom y) = x == y
  (NegAtom x) == (NegAtom y) = x == y
  x == y = False

CNF : Type
CNF = List (List Lit) -- the outer ones are conjunctions the inner lists are disjunctions

aux : List Lit -> Bool
aux [] = True
aux (x :: xs) = (elem (negLit x) xs) || (aux xs)

-- Okay I'm really confused why it can't figure out the type instance if I put cnf instead of List (List Lit).
cnfValid : CNF -> Bool
cnfValid c = all aux c

data ImpFree = IConj ImpFree ImpFree | IDisj ImpFree ImpFree | INeg ImpFree
             | IAtom String

impFree : Formula -> ImpFree
impFree (Atom x) = (IAtom x)
impFree (Disj x y) = IDisj (impFree x) (impFree y)
impFree (Conj x y) = IConj (impFree x) (impFree y)
impFree (Imp x y) = IDisj (INeg (impFree x)) (impFree y)
impFree (Neg x) = INeg (impFree x)

data NNF = NConj NNF NNF | NDisj NNF NNF | NLit Lit

toNNF : ImpFree -> NNF
toNNF (IConj x y) = NConj (toNNF x) (toNNF y)
toNNF (IDisj x y) = NDisj (toNNF x) (toNNF y)
toNNF (INeg (IConj x y)) = NDisj (toNNF arg1)
                                 (toNNF arg2)
    where arg1 = assert_smaller (INeg (IConj x y)) (INeg x)
          arg2 = assert_smaller (INeg (IConj x y)) (INeg y)

toNNF (INeg (IDisj x y)) = NConj (toNNF (assert_smaller (INeg (IDisj x y)) (INeg x)))
                                  (toNNF (assert_smaller (INeg (IDisj x y)) (INeg y)))
toNNF (INeg (INeg x)) = toNNF x
toNNF (INeg (IAtom x)) = NLit (NegAtom x)
toNNF (IAtom x) = NLit (PosAtom x)

accumLits : NNF -> List Lit
accumLits (NConj x y) = accumLits x ++ accumLits y -- this case won't happen in disjLift
accumLits (NDisj x y) = accumLits x ++ accumLits y
accumLits (NLit x) = [x]

disjLift : (x : NNF) -> (y : NNF) -> List (List Lit)
disjLift (NConj x1 x2) y = (disjLift x1 y) ++ (disjLift x2 y)
disjLift x (NConj y1 y2) = (disjLift x y1) ++ (disjLift x y2)
disjLift x y = [(accumLits x) ++ (accumLits y)]

nnfTocnf : NNF -> CNF
nnfTocnf (NConj x y) = nnfTocnf x ++ nnfTocnf y
nnfTocnf (NDisj x y) = disjLift x y
nnfTocnf (NLit x) = [[x]]

isValid : Formula -> Bool
isValid = cnfValid . nnfTocnf . toNNF . impFree

-- okay then!

{-
  Now let's get to horn clauses. These are going to be built up inductively as
-}

data P = PBot | PTop | PLit Lit

data Clause p = CImp (List p) p

Horn : Type -> Type
Horn p = List (Clause p)

blah : Clause P -> List P
blah (CImp xs x) = xs ++ [x]

collectPs : Horn P -> List P
collectPs = concat . map blah

data IsMarked = Marked P | Unmarked P

satHorn : Horn (Fin n) -> Vect n IsMarked -> Bool
satHorn h v = ?rhs

{-
  Now the problem here is that the Huth and Ryan algorithm for this is a while loop that translates rather uglily from an imperative language to a functional one.

  Now, we could do a translation of the loop with just recursion, yes
-}

markTop : IsMarked -> IsMarked
markTop (Marked x) = (Marked x)
markTop a@(Unmarked PBot) = a
markTop (Unmarked PTop) = Marked PTop
markTop a@(Unmarked (PLit x)) = a

isDone : Horn (Fin n) -> Bool
isDone h = ?fdas

notBot : IsMarked -> Bool
notBot m = ?asdf

uglySatAux : (h : List (Clause (Fin n))) ->  Vect n IsMarked -> Bool
uglySatAux h vs = if (isDone h) then (and (map notBot vs)) else ?blee

uglySat : Horn (Fin n) -> Vect n IsMarked -> Bool
uglySat h v = uglySatAux h (map markTop v)


import Data.Vect

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

sixInts : Vect 6 Int
sixInts = [4, 5, 6, 7, 8, 9]

tenInts : Vect 10 Int
tenInts = fourInts ++ sixInts

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

insert : Ord elem => (x : elem) -> (xsSorted : Vect len elem) -> Vect (S len) elem
insert x [] = [x]
insert x (y :: xs) = case x < y of
                          False => y :: insert x xs
                          True =>  x :: y :: xs

insSort : Ord elem =>  Vect n elem -> Vect n elem
insSort [] = []
insSort (x :: xs) = let xsSorted = insSort xs in
                        insert x xsSorted


module Data.List.NotElem

%default total
%access public export

data NotElem : (prfEq : a -> a -> Type) -> a -> List a -> Type where
  IsEmpty : NotElem prfEq x Nil
  NotFirst : (prf : Not (prfEq x y)) -> NotElem prfEq x Nil -> NotElem prfEq x [y]
  NotThere : (prf : Not (prfEq x y))
          -> (notLater : NotElem prfEq x there)
          -> NotElem prfEq x (y::there)

isFirstElem : (decEq : (x : a) -> (y : a) -> Dec (prfSame x y))
           -> (prf : prfSame n x)
           -> NotElem prfSame n (x :: xs)
           -> Void
isFirstElem decEq prf (NotFirst f x) = f prf
isFirstElem decEq prf (NotThere f notLater) = f prf

isFoundLater : (decEq : (x : a) -> (y : a) -> Dec (prfSame x y))
            -> (contra : prfSame n x -> Void)
            -> (f : NotElem prfSame n xs -> Void)
            -> NotElem prfSame n (x :: xs)
            -> Void
isFoundLater decEq contra f (NotFirst prf x) = f x
isFoundLater decEq contra f (NotThere prf notLater) = f notLater

notElem : (decEq : (x,y : a) -> Dec (prfSame x y))
       -> (n : a)
       -> (ns : List a)
       -> Dec (NotElem prfSame n ns)
notElem decEq n [] = Yes IsEmpty
notElem decEq n (x :: xs) with (decEq n x)
  notElem decEq n (x :: xs) | (Yes prf) = No (isFirstElem decEq prf)
  notElem decEq n (x :: xs) | (No contra) with (notElem decEq n xs)
    notElem decEq n (x :: xs) | (No contra) | (Yes prf) = Yes (NotThere contra prf)
    notElem decEq n (x :: xs) | (No contra) | (No f) = No (isFoundLater decEq contra f)

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


module Addition.Digit

import Common.Util
import Common.Interfaces
import Specifications.TranslationInvariance
import Proofs.Interval

%default total
%access public export

data Digit : (leq : Binrel s) -> (neg : s -> s) -> s -> Type where
  MkDigit : (x : s) -> .InSymRange leq neg u x -> Digit leq neg u

val : Digit {s} _ _ _ -> s
val (MkDigit x _) = x

implementation Show s => Show (Digit {s} leq neg u) where
  show (MkDigit x _) = show x

||| adding two digits makes the range twice as big
addDigits : Ringops s => PartiallyOrderedGroupSpec {s} (+) Zero Ng leq ->
  OuterBinop (Digit leq Ng) u u (u + u)
addDigits spec (MkDigit x p) (MkDigit y q) =
  MkDigit (x + y) (addInSymRange spec p q)

||| To produce test input, full decidability is overkill
maybeDigit : Decidable [s,s] leq => (neg : s -> s) -> (u : s) ->
  s -> Maybe (Digit leq neg u)
maybeDigit {leq} neg u x =
  case decideBetween {leq} (neg u) u x of
    Yes prf => Just (MkDigit x prf)
    No _ => Nothing

||| To produce test input, full decidability is overkill
maybeDigits : (Traversable trav, Decidable [s,s] leq) =>
  (neg : s -> s) -> (u : s) -> trav s -> Maybe (trav (Digit leq neg u))
maybeDigits {leq} neg u = sequence . map (maybeDigit {leq} neg u)


import Data.Vect
import Data.Vect.Views

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