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)


> module Nat.OperationsProperties

> import Syntax.PreorderReasoning

> -- import NatPredicates
> import Nat.Operations
> import Nat.BasicProperties
> import Nat.LTEProperties
> import Nat.LTProperties
> import Basic.Operations
> import Functor.Predicates

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

Properties of |pred|:

> |||
> predLemma : (n : Nat) -> (prf : Z `LT` n) -> S (pred n prf) = n
> predLemma  Z    prf = absurd prf
> predLemma (S m) _   = Refl
> %freeze predLemma

Properties of |=|:

> ||| EQ is contained in LTE
> eqInLTE : (m : Nat) -> (n : Nat) -> m = n -> m `LTE` n
> eqInLTE  Z     n    prf = LTEZero
> eqInLTE (S m)  Z    prf = absurd prf
> eqInLTE (S m) (S n) prf = LTESucc (eqInLTE m n (succInjective m n prf))
> %freeze eqInLTE

Properties of |plus|:

> |||
> plusPlusElimLeft : {m1, n1, m2, n2 : Nat} -> m1 + n1 = m2 + n2 -> m1 = m2 -> n1 = n2
> plusPlusElimLeft {m1 = Z} {n1} {m2 = Z} {n2} p1 Refl = s2 where
>   s1 : n1 = Z + n2
>   s1 = replace {x = Z + n1}
>                {y = n1}
>                {P = \ ZUZU => ZUZU = Z + n2}
>                (plusZeroLeftNeutral n1)
>                p1
>   s2 : n1 = n2
>   s2 = replace {x = Z + n2}
>                {y = n2}
>                {P = \ ZUZU => n1 = ZUZU}
>                (plusZeroLeftNeutral n2)
>                s1
> plusPlusElimLeft {m1 = Z}    {n1} {m2 = S m2} {n2} p1 Refl impossible
> plusPlusElimLeft {m1 = S m1} {n1} {m2 = Z}    {n2} p1 Refl impossible
> plusPlusElimLeft {m1 = S m1} {n1} {m2 = S m2} {n2} p1 p2 = plusPlusElimLeft p1' p2' where
>   p1' : m1 + n1 = m2 + n2
>   p1' = succInjective (m1 + n1) (m2 + n2) p1
>   p2' : m1 = m2
>   p2' = succInjective m1 m2 p2
> %freeze plusPlusElimLeft

> |||
> plusElimLeft : (m1 : Nat) -> (n : Nat) -> (m2 : Nat) -> m1 + n = m2 -> m1 = m2 -> n = Z
> plusElimLeft m n m p Refl = plusLeftLeftRightZero m n p
> %freeze plusElimLeft

> {-

> |||
> idPlusAnyPreservesLT : (m : Nat) -> (n : Nat) -> m `LT` n -> (p : Nat) -> m `LT` (n + p)

> |||
> idAnyPlusPreservesLT : (m : Nat) -> (n : Nat) -> m `LT` n -> (p : Nat) -> m `LT` (p + n)

> |||
> plusPreservesLT : (m : Nat) -> (n : Nat) -> m `LT` n ->
>                   (p : Nat) -> (q : Nat) -> p `LT` q ->
>                   (m + p) `LT` (n + q)
> plusPreservesLT  Z     Z     zLTz  _ _ _    = absurd  zLTz
> plusPreservesLT  Z    (S n)  zLTsn p q pLTq = idAnyPlusPreservesLT p q pLTq (S n)
> plusPreservesLT (S m)  Z    smLTz  _ _ _    = absurd smLTz
> plusPreservesLT (S m) (S n) smLTsn p q pLTq = LTESucc (plusPreservesLT m n (fromLteSucc smLTsn) p q pLTq)

> -}

Properties of |minus|:

> ||| The difference of equal numbers is zero
> minusLemma0 : m = n -> m - n = Z
> minusLemma0 {m = Z}    {n = Z}    Refl = Refl
> minusLemma0 {m = Z}    {n = S n'} prf  = absurd prf
> minusLemma0 {m = S m'} {n = Z}    prf  = absurd prf
> minusLemma0 {m = S m'} {n = S n'} prf  = trans s1 s2 where
>   s1 : S m' - S n' = m' - n'
>   s1 = Refl
>   s2 : m' - n' = Z
>   s2 = minusLemma0 (succInjective m' n' prf)
> %freeze minusLemma0

> |||
> minusLemma1 : n - m = S l -> l = n - (S m)
> minusLemma1 {l} {m = Z}    {n = Z}    p = absurd p
> minusLemma1 {l} {m = Z}    {n = S n'} p = s5 where
>   s1 : S n' = S l
>   s1 = p
>   s2 : l = n'
>   s2 = sym (succInjective n' l s1)
>   s3 : n' = n' - Z
>   s3 = sym (minusZeroRight n')
>   s4 : n' - Z = S n' - S Z
>   s4 = Refl
>   s5 : l = S n' - S Z
>   s5 = trans s2 (trans s3 s4)
> minusLemma1 {l} {m = S m'} {n = Z}    p = absurd p
> minusLemma1 {l} {m = S m'} {n = S n'} p = s3 where
>   s1 : n' - m' = S l
>   s1 = p
>   s2 : l = n' - (S m')
>   s2 = minusLemma1 s1
>   s3 : l = S n' - S (S m')
>   s3 = trans s2 Refl
> %freeze minusLemma1

> |||
> minusLemma2 : LTE m n -> n - m = S l -> LTE (S m) n
> minusLemma2 {m = Z}    {n = Z}    p q = absurd q
> minusLemma2 {m = Z}    {n = S n'} p q = LTESucc LTEZero
> minusLemma2 {m = S m'} {n = Z}    p q = absurd p
> minusLemma2 {m = S m'} {n = S n'} (LTESucc p') q = LTESucc (minusLemma2 p' q)
> %freeze minusLemma2

> |||
> minusLemma3 : LTE m n -> Z = n - m -> m = n
> minusLemma3 {m = Z}    {n = Z}    p q = Refl
> minusLemma3 {m = Z}    {n = S n'} p q = absurd q
> minusLemma3 {m = S m'} {n = Z}    p q = absurd p
> minusLemma3 {m = S m'} {n = S n'} (LTESucc p') q =
>   eqSucc m' n' (minusLemma3 {m = m'} {n = n'} p' q') where
>     q' : Z = n' - m'
>     q' = trans q Refl
> %freeze minusLemma3

> |||
> minusLemma4 : LTE (S m) n -> S (n - S m) = n - m
> minusLemma4 {m = Z} {n = Z}    p = absurd p
> minusLemma4 {m = Z} {n = S n'} (LTESucc p') =
>     ( S (S n' - S Z) )
>   ={ Refl }=
>     ( S (n' - Z)     )
>   ={ cong (minusZeroRight n') }=
>     ( S n'           )
>   ={ Refl }=
>     ( S n' - Z       )
>   QED
> minusLemma4 {m = S m'} {n = Z} p = absurd p
> minusLemma4 {m = S m'} {n = S n'} (LTESucc p') =
>     ( S (S n' - S (S m')) )
>   ={ Refl }=
>     ( S (n' - S m')       )
>   ={ minusLemma4 p' }=
>     ( n' - m'             )
>   ={ Refl }=
>     ( S n' - S m'         )
>   QED
> %freeze minusLemma4

Properties of |plus| and |minus|:

> |||
> plusZeroLeftZero : (m : Nat) -> (n : Nat) -> m + n = Z -> m = Z
> plusZeroLeftZero  Z     Z    _   = Refl
> plusZeroLeftZero  Z    (S n) prf = absurd prf
> plusZeroLeftZero (S m)  Z    prf = absurd prf
> plusZeroLeftZero (S m) (S n) prf = absurd prf
> %freeze plusZeroLeftZero

> |||
> plusZeroRightZero : (m : Nat) -> (n : Nat) -> m + n = Z -> n = Z
> plusZeroRightZero  Z     Z    _   = Refl
> plusZeroRightZero  Z    (S n) prf = absurd prf
> plusZeroRightZero (S m)  Z    prf = absurd prf
> plusZeroRightZero (S m) (S n) prf = absurd prf
> %freeze plusZeroRightZero

> -- plusOneEither : (m : Nat) -> (n : Nat) -> m + n = S Z -> Either (m = Z) (n = Z)

> plusRightInverseMinus : (m : Nat) -> (n : Nat) -> m `LTE` n -> (n - m) + m = n
> plusRightInverseMinus  Z    n _ =
>     ( (n - Z) + Z )
>   ={ plusZeroRightNeutral (n - Z) }=
>     ( n - Z )
>   ={ minusZeroRight n }=
>     ( n )
>   QED
> plusRightInverseMinus (S m) n p =
>     ( (n - S m) + S m )
>   ={ plusCommutative (n - S m) (S m) }=
>     ( S m + (n - S m) )
>   ={ plusSuccRightSucc m (n - S m) }=
>     ( m + S (n - S m) )
>   ={ replace {x = S (n - S m)}
>              {y = n - m}
>              {P = \ ZUZU => m + S (n - S m) = m + ZUZU }
>              (minusLemma4 p) Refl}=
>     ( m + (n - m) )
>   ={ plusCommutative m (n - m) }=
>     ( (n - m) + m )
>   ={ plusRightInverseMinus m n (lteLemma1 m n p) }=
>     ( n )
>   QED
> %freeze plusRightInverseMinus

Properties of |mult|:

> ||| Multiplication of successors is not zero
> multSuccNotZero : (m : Nat) -> (n : Nat) -> Not ((S m) * (S n) = Z)
> multSuccNotZero m  n  p = absurd p
> %freeze multSuccNotZero

> ||| Multiplication of non-zeros is not zero
> multNotZeroNotZero : (m : Nat) -> (n : Nat) -> Not (m = Z) -> Not (n = Z) -> Not (m * n = Z)
> multNotZeroNotZero  Z     n    p q = void (p Refl)
> multNotZeroNotZero (S m)  Z    p q = void (q Refl)
> multNotZeroNotZero (S m) (S n) p q = multSuccNotZero m n
> %freeze multNotZeroNotZero

> ||| Multiplication not zero implies non-zero left
> multNotZeroNotZeroLeft : (m : Nat) -> (n : Nat) -> Not (m * n = Z) -> Not (m = Z)
> multNotZeroNotZeroLeft  Z     n    p = void (p (multZeroLeftZero n))
> multNotZeroNotZeroLeft (S m)  _    _ = SIsNotZ
> %freeze multNotZeroNotZeroLeft

> ||| Multiplication not zero implies non-zero right
> multNotZeroNotZeroRight : (m : Nat) -> (n : Nat) -> Not (m * n = Z) -> Not (n = Z)
> multNotZeroNotZeroRight m  Z     p = void (p (multZeroRightZero m))
> multNotZeroNotZeroRight _ (S n)  _ = SIsNotZ
> %freeze multNotZeroNotZeroRight

> ||| Multiplication of greater-than-zeros is greater than zero
> multZeroLTZeroLT : (m : Nat) -> (n : Nat) -> Z `LT` m -> Z `LT` n -> Z `LT` (m * n)
> multZeroLTZeroLT  Z     n    p _ = absurd p
> multZeroLTZeroLT (S m)  Z    _ q = absurd q
> multZeroLTZeroLT (S m) (S n) _ _ = ltZS (n + m * (S n))
> %freeze multZeroLTZeroLT

> ||| Multiplication greater than zero implies greater than zero left
> multLTZeroLeftLTZero : (m : Nat) -> (n : Nat) -> Z `LT` (m * n) -> Z `LT` m
> multLTZeroLeftLTZero Z n p = absurd p' where
>   p' : Z `LT` Z
>   p' = replace {x = Z * n}
>                {y = Z}
>                {P = \ ZUZU => Z `LT` ZUZU}
>                (multZeroLeftZero n) p
> multLTZeroLeftLTZero (S m) n _ = ltZS m
> %freeze multLTZeroLeftLTZero

> ||| Multiplication greater than zero implies greater than zero right
> multLTZeroRightLTZero : (m : Nat) -> (n : Nat) -> Z `LT` (m * n) -> Z `LT` n
> multLTZeroRightLTZero m Z p = absurd p' where
>   p' : Z `LT` Z
>   p' = replace {x = m * Z}
>                {y = Z}
>                {P = \ ZUZU => Z `LT` ZUZU}
>                (multZeroRightZero m) p
> multLTZeroRightLTZero m (S n) _ = ltZS n
> %freeze multLTZeroRightLTZero

> |||
> multZeroRightOneLeftZero : (m : Nat) -> (n : Nat) -> m * (S n) = Z -> m = Z
> multZeroRightOneLeftZero m n prf = plusZeroLeftZero m (n * m) prf' where
>   prf' : (S n) * m = Z
>   prf' = replace {x = m * (S n)} {y = (S n) * m} {P = \ ZUZU => ZUZU = Z} (multCommutative m (S n)) prf
> %freeze multZeroRightOneLeftZero

> |||
> multZeroLeftOneRightZero : (m : Nat) -> (n : Nat) -> (S m) * n = Z -> n = Z
> multZeroLeftOneRightZero m n prf = plusZeroLeftZero n (m * n) prf
> %freeze multZeroLeftOneRightZero

> |||
> multOneLeftOne : (m : Nat) -> (n : Nat) -> m * n = S Z -> m = S Z
> multOneLeftOne  Z     n    prf = absurd prf
> multOneLeftOne (S m)  Z    prf = absurd prf' where
>   prf' : Z = S Z
>   prf' = replace {x = (S m) * Z}
>                  {y = Z}
>                  {P = \ ZUZU => ZUZU = S Z}
>                  (multZeroRightZero (S m)) prf
> multOneLeftOne (S m) (S n) prf = eqSucc m Z s5 where
>   s1 : S (n + m * (S n)) = S Z
>   s1 = prf
>   s2 : n + m * (S n) = Z
>   s2 = succInjective (n + m * (S n)) Z s1
>   s3 : n = Z
>   s3 = plusZeroLeftZero n (m * (S n)) s2
>   s4 : m * (S n) = Z
>   s4 = plusZeroRightZero n (m * (S n)) s2
>   s5 : m = Z
>   s5 = multZeroRightOneLeftZero m n s4
> %freeze multOneLeftOne

> |||
> multOneRightOne : (m : Nat) -> (n : Nat) -> m * n = S Z -> n = S Z
> multOneRightOne m n prf = multOneLeftOne n m prf' where
>   prf' : n * m = S Z
>   prf' = replace {x = m * n} {y = n * m} {P = \ ZUZU => ZUZU = S Z} (multCommutative m n) prf
> %freeze multOneRightOne

> |||
> multPreservesEq : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                   m1 = m2 -> n1 = n2 -> m1 * n1 = m2 * n2
> multPreservesEq m m n n Refl Refl = Refl
> %freeze multPreservesEq

> |||
> multMultElimLeft : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                    m1 = m2 -> Not (m1 = Z) -> m1 * n1 = m2 * n2 ->
>                    n1 = n2
> multMultElimLeft _  _   Z      Z     _      _      _            = Refl
> multMultElimLeft m1 m2  Z     (S n2) m1EQm2 nm1EQZ m1ZEQm2sn2   =
>   void (nm1EQZ s4) where
>     s0  :  m1 * Z = m2 * (S n2)
>     s0  =  m1ZEQm2sn2
>     s1  :  Z = m2 * (S n2)
>     s1  =  replace {x = m1 * Z} {y = Z} {P = \ ZUZU => ZUZU = m2 * (S n2)} (multZeroRightZero m1) s0
>     s2  :  Z = m2
>     s2  =  sym (multZeroRightOneLeftZero m2 n2 (sym s1))
>     s3  :  m2 = Z
>     s3  =  sym s2
>     s4  :  m1 = Z
>     s4  =  replace (sym m1EQm2) s3
> multMultElimLeft m1 m2 (S n1)  Z     m1EQm2 nm1EQZ m1sn1EQm2Z   =
>   void (nm1EQZ s2) where
>     s0  :  m1 * (S n1) = m2 * Z
>     s0  =  m1sn1EQm2Z
>     s1  :  m1 * (S n1) = Z
>     s1  =  replace {x = m2 * Z} {y = Z} {P = \ ZUZU => m1 * (S n1) = ZUZU} (multZeroRightZero m2) s0
>     s2  :  m1 = Z
>     s2  =  multZeroRightOneLeftZero m1 n1 s1
> multMultElimLeft m1 m2 (S n1) (S n2) m1EQm2 nm1EQZ m1sn1EQm2sn2 =
>   eqSucc n1 n2 s5 where
>     s0  :  m1 * (S n1) = m2 * (S n2)
>     s0  =  m1sn1EQm2sn2
>     s1  :  (S n1) * m1 = (S n2) * m2
>     s1  =  replace2 {a = Nat} {a1 = m1 * (S n1)} {a2 = (S n1) * m1}
>                     {b = Nat} {b1 = m2 * (S n2)} {b2 = (S n2) * m2}
>                     {P = \ ZUZU => \ ZAZA => ZUZU = ZAZA}
>                     (multCommutative m1 (S n1)) (multCommutative m2 (S n2)) s0
>     s2  :  m1 + n1 * m1 = m2 + n2 * m2
>     s2  =  s1
>     s3  :  n1 * m1 = n2 * m2
>     s3  =  plusPlusElimLeft s2 m1EQm2
>     s4  :  m1 * n1 = m2 * n2
>     s4  =  replace2 {a = Nat} {a1 = n1 * m1} {a2 = m1 * n1}
>                     {b = Nat} {b1 = n2 * m2} {b2 = m2 * n2}
>                     {P = \ ZUZU => \ ZAZA => ZUZU = ZAZA}
>                     (multCommutative n1 m1) (multCommutative n2 m2) s3
>     s5  :  n1 = n2
>     s5  =  multMultElimLeft m1 m2 n1 n2 m1EQm2 nm1EQZ s4
> %freeze multMultElimLeft --

> |||
> multMultElimRight : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                     n1 = n2 -> Not (n1 = Z) -> m1 * n1 = m2 * n2 ->
>                     m1 = m2
> multMultElimRight m1 m2 n1 n2 n1EQn2 nn1EQZ prf =
>   multMultElimLeft n1 n2 m1 m2 n1EQn2 nn1EQZ prf' where
>     prf' : n1 * m1 = n2 * m2
>     prf' = replace2 (multCommutative m1 n1) (multCommutative m2 n2) prf
> %freeze multMultElimRight --

> |||
> multElim1 : (m : Nat) -> (n : Nat) -> (S m) * n = S m -> n = S Z
> multElim1 m    Z  p = absurd s1 where
>   s1 : Z = S m
>   s1 = replace {x = (S m) * Z} {y = Z} {P = \ ZUZU => ZUZU = S m} (multZeroRightZero (S m)) p
> multElim1 m (S Z) _ = Refl
> multElim1 m (S (S n)) p = void (multSuccNotZero n m s5) where
>   s1 : (S (S n)) * (S m) = S m
>   s1 = replace {x = (S m) * (S (S n))}
>                {y = (S (S n)) * (S m)}
>                {P = \ ZUZU => ZUZU = S m}
>                (multCommutative (S m) (S (S n))) p
>   s2 : S m + (S n) * (S m) = S m
>   s2 = replace {x = (S (S n)) * (S m)}
>                {y = S m + (S n) * (S m)}
>                {P = \ ZUZU => ZUZU = S m}
>                Refl s1
>   s5 : (S n) * (S m) = Z
>   s5 = plusLeftLeftRightZero (S m) ((S n) * (S m)) s2
> %freeze multElim1

> |||
> multSwapLeft : (a, b, c : Nat) -> a * b * c = b * a * c
> multSwapLeft a b c = ( a * b * c )
>                    ={ Refl }=
>                      ( (a * b) * c )
>                    ={ cong {f = \ ZUZU => ZUZU * c} (multCommutative a b) }=
>                      ( (b * a) * c )
>                    ={ Refl }=
>                      ( b * a * c )
>                    QED
> %freeze multSwapLeft

> |||
> multSwapRight : (a, b, c : Nat) -> a * b * c = a * c * b
> multSwapRight a b c = ( a * b * c )
>                     ={ Refl }=
>                       ( (a * b) * c )
>                     ={ sym (multAssociative a b c) }=
>                       ( a * (b * c) )
>                     ={ cong (multCommutative b c) }=
>                       ( a * (c * b) )
>                     ={ multAssociative a c b }=
>                       ( (a * c) * b )
>                     ={ Refl }=
>                       ( a * c * b )
>                     QED
> %freeze multSwapRight

> |||
> multSwap23 : (a, b, c, d : Nat) -> (a * b) * (c * d) = (a * c) * (b * d)
> multSwap23 a b c d = ( (a * b) * (c * d) )
>                    ={ Refl }=
>                      ( a * b * (c * d) )
>                    ={ sym (multAssociative a b (c * d)) }=
>                      ( a * (b * (c * d)) )
>                    ={ cong {f = \ ZUZU => a * ZUZU} (multAssociative b c d) }=
>                      ( a * ((b * c) * d) )
>                    ={ cong {f = \ ZUZU => a * ZUZU} (multSwapLeft b c d) }=
>                      ( a * ((c * b) * d) )
>                    ={ cong {f = \ ZUZU => a * ZUZU} (sym (multAssociative c b d)) }=
>                      ( a * (c * (b * d)) )
>                    ={ multAssociative a c (b * d) }=
>                      ( a * c * (b * d) )
>                    ={ Refl }=
>                      ( (a * c) * (b * d) )
>                    QED
> %freeze multSwap23

> |||
> multSwap24 : (a, b, c, d : Nat) -> (a * b) * (c * d) = (a * d) * (c * b)
> multSwap24 a b c d = ( (a * b) * (c * d) )
>                    ={ cong {f = \ ZUZU => (a * b) * ZUZU} (multCommutative c d) }=
>                      ( (a * b) * (d * c) )
>                    ={ multSwap23 a b d c }=
>                      ( (a * d) * (b * c) )
>                    ={ cong {f = \ ZUZU => (a * d) * ZUZU} (multCommutative b c) }=
>                      ( (a * d) * (c * b) )
>                    QED
> %freeze multSwap24

> |||
> multFlipCentre : (m1 : Nat) -> (m2 : Nat) -> (n1 : Nat) -> (n2 : Nat) ->
>                  (m1 * m2) * (n1 * n2) = (m1 * n1) * (m2 * n2)
> multFlipCentre = multSwap23
> %freeze multFlipCentre

> |||
> multOneRightNeutralPlusMultZeroLeftZero : (m : Nat) -> (n : Nat) -> m * 1 + 0 * n = m
> multOneRightNeutralPlusMultZeroLeftZero m n =
>     ( m * 1 + 0 * n )
>   ={ cong (multZeroLeftZero n) }=
>     ( m * 1 + 0 )
>   ={ cong {f = \ ZUZU => ZUZU + 0} (multOneRightNeutral m) }=
>     ( m + 0 )
>   ={ plusZeroRightNeutral m }=
>     ( m )
>   QED
> %freeze multOneRightNeutralPlusMultZeroLeftZero

Properties of |sum|:

> ||| |sum| is monotone
> -- sumMon : Monotone {B = Nat} {C = Nat} {F = List} LTE LTE sum
> sumMon : {A : Type} ->
>          (f : A -> Nat) -> (g : A -> Nat) ->
>          (p : (a : A) -> f a `LTE` g a) ->
>          (as : List A) ->
>          sum (map f as) `LTE` sum (map g as)
> sumMon {A} f g p Nil = LTEZero
> sumMon {A} f g p (a :: as) = s5 where
>   s1 : sum (map f (a :: as)) = f a + sum (map f as)
>   s1 = Refl
>   s2 : sum (map g (a :: as)) = g a + sum (map g as)
>   s2 = Refl
>   s3 : f a `LTE` g a
>   s3 = p a
>   s4 : sum (map f as) `LTE` sum (map g as)
>   s4 = sumMon f g p as
>   s5 : sum (map f (a :: as)) `LTE` sum (map g (a :: as))
>   s5 = monotoneNatPlusLTE s3 s4
> %freeze sumMon

> {-

Test:

> CLTtoLT : {m, n : Nat} -> compare m n = LT -> m `LT` n

> LTtoCLT : {m, n : Nat} -> m `LT` n -> compare m n = LT

> CEQtoEQ : {m, n : Nat} -> compare m n = EQ -> m = n

> EQtoCEQ : {m, n : Nat} -> m = n -> compare m n = EQ

> anyPlusPreservesOrd : {x, y, z : Nat} -> {ORD : Ordering} ->
>                       compare x y = ORD -> compare (z + x) (z + y) = ORD

> plusAnyPreservesOrd : {x, y, z : Nat} -> {ORD : Ordering} ->
>                       compare x y = ORD -> compare (z + x) (z + y) = ORD

> LTinLTE : {m, n : Nat} -> LT m n -> LTE m n

> pLTpEQpLTE : (LT x1 x2 -> LT y1 y2) -> (x1 = x2 -> y1 = y2) -> (LTE x1 x2 -> LTE y1 y2)

> anyPlusPreservesLT : LT x y -> LT (z + x) (z + y)
> anyPlusPreservesLT {x} {y} {z} prf = s3 where
>   s1  :  compare x y = LT
>   s1  =  LTtoCLT prf
>   s2  :  compare (z + x) (z + y) = LT
>   s2  =  anyPlusPreservesOrd s1
>   s3  :  (z + x) `LT` (z + y)
>   s3  =  CLTtoLT s2

> anyPlusPreservesEQ : {x, y, z : Nat} -> x = y -> (z + x) = (z + y)
> anyPlusPreservesEQ {x} {y} {z} prf = s3 where
>   s1  :  compare x y = EQ
>   s1  =  EQtoCEQ prf
>   s2  :  compare (z + x) (z + y) = EQ
>   s2  =  anyPlusPreservesOrd s1
>   s3  :  (z + x) = (z + y)
>   s3  =  CEQtoEQ s2

> anyPlusPreservesLTE : LTE x y -> LTE (z + x) (z + y)
> anyPlusPreservesLTE = pLTpEQpLTE anyPlusPreservesLT anyPlusPreservesEQ

> ---}


module Labelling

import Control.Monad.State

-- 12.1.4 Exercises
update : (stateType -> stateType) -> State stateType ()
update f = do state <- get
              put $ f state

increase' : Nat -> State Nat ()
increase' inc = update (+inc)

-- *Labelling> runState (increase' 5) 89
-- ((), 94) : ((), Nat)

-- Tree Labelling

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

countEmpty : Tree a -> State Nat ()
countEmpty Empty = do update (+ 1)
countEmpty (Node l v r) = do countEmpty l
                             countEmpty r

countEmptyNode : Tree a -> State (Nat, Nat) ()
countEmptyNode Empty = do update (\p => (fst p, snd p + 1))
countEmptyNode (Node l v r) = do update (\p => (fst p + 1, snd p))
                                 countEmptyNode l
                                 countEmptyNode r

 -- *Labelling> execState (countEmpty testTree) 0
 -- 7 : Nat

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

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

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

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

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

tLabelWith : Tree a -> State (Stream labelType) (Tree (labelType, a))
tLabelWith Empty = pure Empty
tLabelWith (Node left val right)
                 = do left_labelled <- tLabelWith left
                      (h :: t) <- get
                      put t
                      right_labelled <- tLabelWith right
                      pure (Node left_labelled (h, val) right_labelled)


module Decidable.Equality.Core

%default total

--------------------------------------------------------------------------------
-- Decidable equality
--------------------------------------------------------------------------------

||| Decision procedures for propositional equality
public export
interface DecEq t where
  ||| Decide whether two elements of `t` are propositionally equal
  decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

--------------------------------------------------------------------------------
-- Utility lemmas
--------------------------------------------------------------------------------

||| The negation of equality is symmetric (follows from symmetry of equality)
export
negEqSym : Not (a = b) -> Not (b = a)
negEqSym p h = p (sym h)

||| Everything is decidably equal to itself
export
decEqSelfIsYes : DecEq a => {x : a} -> decEq x x = Yes Refl
decEqSelfIsYes with (decEq x x)
  decEqSelfIsYes | Yes Refl = Refl
  decEqSelfIsYes | No contra = absurd $ contra Refl

||| If you have a proof of inequality, you're sure that `decEq` would give a `No`.
export
decEqContraIsNo : DecEq a => {x, y : a} -> Not (x = y) -> (p ** decEq x y = No p)
decEqContraIsNo uxy with (decEq x y)
  decEqContraIsNo uxy | Yes xy = absurd $ uxy xy
  decEqContraIsNo _   | No uxy = (uxy ** Refl)


> module SequentialDecisionProblems.OptDefaults

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.Utils

> import Finite.Predicates
> import Finite.Operations
> import Opt.Operations
> import Rel.TotalPreorder

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

We implement |cvalmax|, |cvalargmax|, |cvalmaxSpec| and |cvalargmaxSpec|
by exhaustive search (see |Opt|) if we can show that |LTE| is a total
preorder

> totalPreorderLTE : TotalPreorder SequentialDecisionProblems.CoreTheory.LTE

, that |GoodCtrl t x n| is finite and that, for every |t : Nat|, |x :
State t| such that |Viable (S n) x|, its cardinality is not zero.

In typical applications, finiteness and non-emptyness of |GoodCtrl t x
n| are going to be deduced (see Utils) from finiteness of |All| and
|NotEmpty| (see, for instance, NonDeterministicDefaults), finiteness of
|Viable| (see ViabilityDefaults) and finiteness of controls.

> SequentialDecisionProblems.FullTheory.cvalmax {n} x r v ps =
>  Opt.Operations.max totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.CoreTheory.cvalargmax {n} x r v ps =
>   Opt.Operations.argmax totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.FullTheory.cvalmaxSpec {n} x r v ps =
>   Opt.Operations.maxSpec totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> SequentialDecisionProblems.FullTheory.cvalargmaxSpec {n} x r v ps =
>   Opt.Operations.argmaxSpec totalPreorderLTE (finiteGoodCtrl n x) (cardNotZGoodCtrl n x v) (cval x r v ps)

> {-

> ---}


> module Functions
> %access public export

In this module we present types for basic proofs about functions between sets, such as

- injectivity, surjectivity, bijectivity
- quotienting by totality ("squashing")

> ||| The type of proofs that a given function is injective.
> ||| A function `f: t -> u` is injective if, given a proof that `f x = f y`,
> ||| we can prove `x=y`. An implementation of `Injective f` is a function that
> ||| returns an `(x = y)` proof given an `(f x = f y)` proof.
> Injective : {t,u:Type} -> (t -> u) -> Type
> Injective f {t} = (x,y:t) -> (f x = f y) -> (x = y)

> ||| The type of proofs that a given function is surjective.
> ||| A function `f: t -> u` is injective if, given any `y: u`, we can find
> ||| `x: t` with a proof `f x = y`. An implementation of `Surjective f` is a
> ||| function that returns a dependent pair `(x ** f x = y)`  given an
> ||| `(f x = f y)` proof. Note that there is no proof of uniqueness.
> Surjective : {t,u:Type} -> (t -> u) -> Type
> Surjective f {t} {u} = (y:u) -> (x:t ** f x = y)

> ||| The type of proofs that a given function is bijective.
> ||| Since this is equivalent to being both injective and surjective, that is
> ||| the definition we are using.
> Bijective : {t,u : Type} -> (t -> u) -> Type
> Bijective f {t} {u} = (Injective f, Surjective f)

> ||| The type of proofs that two types `t` and `u`, considered as simple sets
> ||| built by their constructible members, have the same cardinality. For our
> ||| purposes, this is equivalent to existential quantification on the type of
> ||| bijections between `t` and `u`.
> SameCardinality : Type -> Type -> Type
> SameCardinality t u = (f:(t->u) ** Bijective f)

Note that, for finite sets, the notion of `SameCardinality` collapses in the
obvious way; the problem of finding a bijection is equivalent to putting the
elements of the sets into two lists with the same length. We will formally prove
this later.

> ||| Proof that a type is a "mere proposition" (i.e. it only has one inhabitant
> ||| up to decidable equality.)
> Prop : (t:Type) -> Type
> Prop t = (p1:t) -> (p2:t) -> (p1=p2)

If P is a decidable proposition, we can quotient P by the totality equivalence
relation and get a "squashed" type. By "totality equivalence relation" we mean
a partition of the elements of $P : Type -> Type$ into two sets, one containing
constructible instances $P x$, the other containing unconstructible instances
$P y$. In NuPRL this is called "squash" so that is the name we will use here.

> squash : {p:Type} -> Dec p -> Type
> squash (Yes _) = Unit
> squash (No _) = Void

 Note that any two squashed values are trivially equal:

> ||| Any two squashed values of a given decidable proposition are equal.
> propSquash : {p: Type} -> (d : Dec p) -> Prop (squash d)
> propSquash (Yes prf) () () = Refl
> propSquash (No contra) v1 _ = absurd v1

> ||| Given a squashed proposition, obtain the original proposition.
> fromSquash : {p:Type} -> (d : Dec p) -> squash d -> p
> fromSquash (Yes prf) () = prf

Note that fromSquash can only ever accept a unit value since that is the only
value that is constructible.

> ||| Simple helper for projecting the first part of a dependent pair.
> proj1DP : (DPair a b) -> a
> proj1DP (x ** y) = x

> ||| Simple helper for projecting the second part of a dependent pair.
> proj2DP : (x : (DPair a b)) -> b (proj1DP x)
> proj2DP (x ** y) = y


In : (x : a) -> (l : List a) -> Type
In x [] = Void
In x (x' :: xs) = (x' = x) `Either` In x xs

appendEmpty : (xs : List a) -> xs ++ [] = xs
appendEmpty [] = Refl
appendEmpty (x :: xs) = rewrite appendEmpty xs in Refl

in_app_iff : {l : List b} -> {l' : List b} -> In a (l++l') -> (In a l `Either` In a l')
in_app_iff {l = []} {  l' = []} x = Left x
in_app_iff {l = []} {  l' = (y :: xs)} x = Right x
in_app_iff {l = (y::xs)} {  l' = []} x = rewrite sym (appendEmpty xs) in Left x
in_app_iff {l = (y::xs)} {l' = (z::ys)} (Left prf) = Left (Left prf)
in_app_iff {l = (y::xs)} {l' = (z::ys)} (Right prf) =
                                          let induc : Either (In a xs) (Either (z = a) (In a ys))= in_app_iff {l = xs} {l' = z :: ys} prf  in
                                          case induc of
                                                (Left l) => Left $ Right l
                                                (Right r) => Right r


module Addition.Adhoc

import Common.Abbrev
import Common.Interfaces
import Specifications.Ring
import Proofs.RingTheory

%default total
%access export

adhocIdentity1 : Ringops s => RingSpec {s} (+) Zero Ng (*) -> (b,x,y,z : s) ->
  a = b + c -> x + y * z + y * a = x + y * (z + b + c)
adhocIdentity1 spec {a} b {c} x y z given = o3 where
  o1 : z + a = z + b + c
  o1 = cong given === associative (monoid (group spec)) z b c
  o2 : y * z + y * a = y * (z + b + c)
  o2 = distributativeL spec y z a @== cong o1
  o3 : x + y * z + y * a = x + y * (z + b + c)
  o3 = associative (monoid (group spec)) x _ _ @== cong o2

adhocIdentity2 : Ringops s => RingSpec {s} (+) Zero Ng (*) -> (x,a : s) ->
  x = x + a * Zero
adhocIdentity2 spec x a = sym (o1 === o2) where
  o1 : x + a * Zero = x + Zero
  o1 = cong $ zeroAbsorbsR spec a
  o2 : x + Zero = x
  o2 = neutralR (monoid (group spec)) x


-- ------------------------------------------------------ [ Tree.idr<RedBlack> ]
-- Module    : Tree.idr
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
-- http://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs
module Data.RedBlack.Tree

%access export

private
data Colour = R | B

data Tree : Type -> Type where
  Empty : Tree a
  Node  : Colour -> a -> Tree a -> Tree a -> Tree a

balance : a -> Tree a -> Tree a -> Tree a
balance y (Node R x a              b) (Node R z c d) = Node R y (Node B x a b) (Node B z c d)
balance z (Node R y (Node R x a b) c) d              = Node R y (Node B x a b) (Node B z c d)
balance z (Node R x a                 (Node R y b c)) d = Node R y (Node B x a b) (Node B z c d)
balance x a                           (Node R y b (Node R z c d)) = Node R y (Node B x a b) (Node B z c d)
balance x a                           (Node R z (Node R y b c) d) = Node R y (Node B x a b) (Node B z c d)
balance x a                           b = Node B x a b

private
ins : Ord a => a -> Tree a -> Tree a
ins x Empty            = Node R x Empty Empty
ins x t@(Node B y a b) =
    case compare x y of
        LT => balance y (ins x a) b
        GT => balance y a         (ins x b)
        EQ => t
ins x t@(Node R y a b) =
    case compare x y of
        LT => Node R y (ins x a) b
        GT => Node R y a         (ins x b)
        EQ => t

foldr : (step : a -> p -> p) -> (init : p) -> Tree a -> p
foldr step init n = foldr' step init n
  where
    foldr' : (a -> p -> p) -> p -> Tree a -> p
    foldr' step' init' Empty = init'
    foldr' step' init' (Node _ val l r) = foldr' step' (step' val (foldr' step' init' r)) l

size : Tree a -> Nat
size t = Tree.foldr (\_,res => S res) Z t

contains : Ord a => a -> Tree a -> Bool
contains x Empty = False
contains x (Node _ y l r) =
  case compare x y of
    LT => contains x l
    GT => contains x r
    EQ => True

empty : Tree a
empty = Empty

insert : Ord a => a -> Tree a -> Tree a
insert x s = let Node _ z l r = ins x s in Node B z l r

toList : Tree a -> List a
toList Empty = Nil
toList (Node _ y l r) = Tree.toList l ++ [y] ++ Tree.toList r

fromList : Ord a => List a -> Tree a
fromList xs = foldl (flip $ insert) empty xs


module Foldable

data Tree elem = Empty
               | Node (Tree elem) elem (Tree elem)

totLen : List String -> Nat
totLen xs = foldr (\str, acc => acc + length str) 0 xs

Foldable Tree where
  foldr func acc Empty = acc
  foldr func acc (Node l e r)
        = let leftFold = foldr func acc l
              rightFold = foldr func leftFold r in
              func e rightFold


import Data.List -- for testing using sort

data Matter = Solid | Liquid | Gas

Eq Matter where
    (==) Solid Solid = True
    (==) Liquid Liquid = True
    (==) Gas Gas = True
    (==) _ _ = False

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

-- 7.1 exercises

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

area : Shape -> Double
area (Triangle b h) = b * h * 0.5
area (Rectangle w h) = w * h
area (Circle r) = pi * pow r 2

Eq Shape where
    (==) (Triangle b h) (Triangle b' h') = b == b' && h == h'
    (==) (Rectangle w h) (Rectangle w' h') = w == w' && h == h'
    (==) (Circle r) (Circle r') = r == r'
    (==) _ _ = False

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

testShapes : List Shape
testShapes = [Circle 3, Triangle 3 9, Rectangle 2 6, Circle 4, Rectangle 2 7]


module AddTwoNumbers

data Digit = D Int

ofIntHelp : Int -> List Digit
ofIntHelp 0 = []
ofIntHelp i = D (i `mod` 10) :: ofIntHelp (i `div` 10)

ofInt : Int -> List Digit
ofInt 0 = [D 0]
ofInt i = ofIntHelp i

addHelp : Bool -> List Digit -> List Digit -> List Digit
addHelp carry [] [] = if carry then [D 1] else []
addHelp False [] ys = ys
addHelp True [] ys = addHelp False [D 1] ys
addHelp False xs [] = xs
addHelp True xs [] = addHelp False [D 1] xs
addHelp carry (D x :: xs) (D y :: ys) =
  let sum = x + y + if carry then 1 else 0 in
  if sum >= 10 then
    D (sum `mod` 10) :: addHelp True xs ys
  else
    D sum :: addHelp False xs ys

add : List Digit -> List Digit -> List Digit
add = addHelp False

test1 : add (ofInt 342) (ofInt 465) = ofInt 807
test1 = Refl
test2 : add [D 0] [D 0] = [D 0]
test2 = Refl
test3 : add (map D [9,9,9,9,9,9,9]) (map D [9,9,9,9]) = map D [8,9,9,9,0,0,0,1]
test3 = Refl


module ABMinus

mm : (a, b : Nat) -> a `minus` b = (S a `minus` b) `minus` 1
mm Z     Z     = Refl
mm Z     (S _) = Refl
mm (S a) Z     = Refl
mm (S a) (S b) = rewrite mm a b in Refl

ms : (a, b : Nat) -> a `minus` S b = (a `minus` b) `minus` 1
ms Z     b     = Refl
ms (S _) Z     = Refl
ms (S a) (S b) = rewrite ms a b in Refl

abm : (a, b : Nat) -> a `minus` (b + 1) = (a `minus` b) `minus` 1
abm Z     Z     = Refl
abm (S k) Z     = Refl
abm Z     (S _) = Refl
abm (S a) (S b) = rewrite abm a b in Refl


-- Matrix.idr
--
-- Matrix arithmetics with dependent types

module Matrix

import Data.Vect

||| A type alias for nested Vect
||| @ n number of rows
||| @ m number of columns
Matrix : (n : Nat) -> (m : Nat) -> Type -> Type
Matrix n m elem = Vect n (Vect m elem)

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

-- matrix addition
addMatrix : Num numType =>
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType) ->
            Vect rows (Vect cols numType)

-- matrix multiplication
multMatrix : Num numType =>
             Vect n (Vect m numType) ->
             Vect m (Vect p numType) ->
             Vect n (Vect p numType)

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

transposeHelper : (x : Vect n elem) -> (xsTrans : Vect n (Vect len elem)) ->
                  Vect n (Vect (S len) 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 xsTrans = transposeMat xs in
                             transposeHelper x xsTrans


data BST : a -> Type where
  Leaf : BST a
  Node : (root : a) -> (lt : BST a) -> (rt : BST a) -> BST a

-- Checking that we can look under the @ to get rt and lt
total
insert : Ord a => a -> BST a -> BST a
insert p Leaf = Node p Leaf Leaf
insert p tree@(Node root lt rt) =
  case p `compare` root of
    GT => Node root lt (insert p rt)
    EQ => tree
    LT => Node root (insert p lt) rt


-- 依赖类型
-- 一等类型
-- 在 idris 中，类型是一等的，即它们可以像其它的语言构造那样被计算和操作

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

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

sum' : (single: Bool) -> isSingleton single -> Nat
sum' True x = x
sum' False [] = 0
sum' False (x::xs) = x + sum' False xs

-- sum' False 1
-- will return
-- When checking an application of function Main.sum:
-- isSingleton False is not a numeric type


module Dec2

import Data.Vect
import Data.String
import Utils

dec2a : (Ord a, Neg a) => List (List a) -> a
dec2a xs = foldl f 0 xs where
  g : List a -> a
  g [] = 0
  g (x :: []) = 0
  g (x :: (y :: ys)) = let xs = fromList (y :: ys) in
                           max' (x :: xs) - min' (x :: xs)

  f : a -> List a -> a
  f x xs = x + g xs

divEvenly : (Integral a, Eq a) => (dividend : a) -> (divisor : a) -> Maybe a
divEvenly dividend divisor = do divisor' <- case divisor of
                                              0 => Nothing
                                              _ => Just divisor
                                if mod dividend divisor' == 0
                                then Just (div dividend divisor')
                                else Nothing

reduceAllPairs : Monoid a => (a -> a -> Maybe a) -> Vect (S n) a -> Maybe a
reduceAllPairs f xs = let ys = map (uncurry f) $ concat $ allPairs xs in
                          foldl (<+>) neutral ys

dec2b : (Integral a, Eq a, Monoid a) => List (List a) -> a
dec2b xs = foldl f 0 xs where
  g : List a -> a
  g [] = 0
  g (x :: xs) = fromMaybe 0 $ reduceAllPairs divEvenly (x :: fromList xs)

  f : a -> List a -> a
  f x xs = x + g xs

Semigroup Int where
  (<+>) = (+)

Monoid Int where
  neutral = 0

input : String
input = """278	1689	250	1512	1792	1974	175	1639	235	1635	1690	1947	810	224	928	859
160	50	55	81	68	130	145	21	211	136	119	78	174	155	149	72
4284	185	4499	273	4750	4620	4779	4669	2333	231	416	1603	197	922	5149	2993
120	124	104	1015	1467	110	299	320	1516	137	1473	132	1229	1329	1430	392
257	234	3409	2914	2993	3291	368	284	259	3445	245	1400	3276	339	2207	233
1259	78	811	99	2295	1628	3264	2616	116	3069	2622	1696	1457	1532	268	82
868	619	139	522	168	872	176	160	1010	200	974	1008	1139	552	510	1083
1982	224	3003	234	212	1293	1453	3359	326	3627	3276	3347	1438	2910	248	2512
4964	527	5108	4742	4282	4561	4070	3540	196	228	3639	4848	152	1174	5005	202
1381	1480	116	435	980	1022	155	1452	1372	121	128	869	1043	826	1398	137
2067	2153	622	1479	2405	1134	2160	1057	819	99	106	1628	1538	108	112	1732
4535	2729	4960	241	4372	3960	248	267	230	5083	827	1843	3488	4762	2294	3932
3245	190	2249	2812	2620	2743	2209	465	139	2757	203	2832	2454	177	2799	2278
1308	797	498	791	1312	99	1402	1332	521	1354	1339	101	367	1333	111	92
149	4140	112	3748	148	815	4261	138	1422	2670	32	334	2029	4750	4472	2010
114	605	94	136	96	167	553	395	164	159	284	104	530	551	544	18"""

dec2 : String -> Maybe (Int, Int)
dec2 str = map (\xs => (dec2a xs, dec2b xs)) $ f str where
  g  : (Neg a) => String -> Maybe (List a)
  g str = traverse parseInteger $ words str

  f : (Neg a) => String -> Maybe (List (List a))
  f str = traverse g $ lines str


||| An order is a particular kind of binary relation. The order
||| relation is intended to proceed in some direction, though not
||| necessarily with a unique path.
|||
||| Orders are often defined simply as bundles of binary relation
||| properties.
|||
||| A prominent example of an order relation is LTE over Nat.

module Control.Order

import Control.Relation

||| A preorder is reflexive and transitive.
public export
interface (Reflexive ty rel, Transitive ty rel) => Preorder ty rel where

||| A partial order is an antisymmetrics preorder.
public export
interface (Preorder ty rel, Antisymmetric ty rel) => PartialOrder ty rel where

||| A relation is connex if for any two distinct x and y, either x ~ y or y ~ x.
|||
||| This can also be stated as a trichotomy: x ~ y or x = y or y ~ x.
public export
interface Connex ty rel where
  connex : {x, y : ty} -> Not (x = y) -> Either (rel x y) (rel y x)

||| A relation is strongly connex if for any two x and y, either x ~ y or y ~ x.
public export
interface StronglyConnex ty rel where
  order : (x, y : ty) -> Either (rel x y) (rel y x)

||| A linear order is a connex partial order.
public export
interface (PartialOrder ty rel, Connex ty rel) => LinearOrder ty rel where

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

||| Every equivalence relation is a preorder.
public export
[EP] Equivalence ty rel => Preorder ty rel where


module algebraic

-- Algebraic laws

data Bit = O | I

or : Bit -> Bit -> Bit
or 0 x1 = x1
or I x1 = I

orAssociative  : (a : Bit) ->
                 (b : Bit) ->
                 (c : Bit) ->
                 (a `or` b) `or` c = a `or` (b `or` c)
-- or = ?orAssociative_rhs_1
orAssociative O b c = refl
-- or = ?orAssociative_rhs_2
orAssociative I b c = refl

BitString : Type
-- list of bits
BitString = List Bit

bsor : BitString -> BitString -> BitString
bsor [] x1 = x1
bsor xs [] = xs
bsor (x :: xs) (y :: ys) = (x `or` y) :: (xs `bsor` ys)


module Term

-- Simply-typed lambda calculus with
--   (1) natural numbers as the only base type, and
--   (2) general recursion.
-- This calculus is also referred to as PCF.
--
-- Note that variables in the lambda calculus are not
-- named but identified by their de Bruijn index.

%default total
%access public export

---------------------------------------------------
-- Begin: TYPES IN THE SIMPLY-TYPED LAMBDA CALCULUS

-- Data type 'Ty' represents the types in the
-- simply-typed lambda calculus:
--   (1) Base type 'TyNat' of natural numbers.
--   (2) Type constructor 'TyFun' for forming
--       function types.
data Ty = TyNat | TyFun Ty Ty

-- Simplified syntax for function types:
infixr 10 :->:
(:->:) : Ty -> Ty -> Ty
(:->:) t1 t2 = TyFun t1 t2

-- End: TYPES IN THE SIMPLY-TYPED LAMBDA CALCULUS
-------------------------------------------------

---------------------------------------------------------
-- Begin: CONTEXT FOR TYPING TERMS IN THE LAMBDA CALCULUS

Context : Type
Context = List Ty

-- de Bruijn indices constitute proofs that type
-- 't' occurs at a certain position in context 'ctx':
data HasType : Context -> Ty -> Type where
  First : HasType (t::ctx) t
  Next  : HasType ctx t -> HasType (s::ctx) t

remove : (ctx : Context) -> HasType ctx t -> Context
remove (_::ctx') First     = ctx'
remove (s::ctx') (Next ht) = s::remove ctx' ht

-- End: CONTEXT FOR TYPING TERMS IN THE LAMBDA CALCULUS
-------------------------------------------------------

-------------------------------------------------
-- Begin: WELL-TYPED TERMS OF THE LAMBDA CALCULUS

-- Data type of well-typed terms in the
-- simply-typed lambda calculus:
data Term : Context -> Ty -> Type where
  -- Variable:
  -- The data constructor for variables ('Var') takes as
  -- argument a de Bruijn index (of type 'HasType ctx t'),
  -- which is proof that the context 'ctx' contains type
  -- 't' at the position given by the de Bruijn index:
  TVar  : HasType ctx t ->
          Term ctx t
  -- Abstraction:
  -- The data constructor for abstractions ('Abs')
  -- takes as its first (implicit) argument the
  -- type of the variable that is bound by this
  -- abstraction.
  TAbs  : {s : Ty} -> Term (s::ctx) t ->
          Term ctx (s :->: t)
  -- Application:
  TApp  : Term ctx (s :->: t) -> Term ctx s ->
          Term ctx t
  -- Fix-point operator:
  TFix  : Term ctx (t :->: t) ->
          Term ctx t
  -- Constant 'Zero' (natural number):
  TZero : Term ctx TyNat
  -- Successor:
  TSucc : Term ctx TyNat ->
          Term ctx TyNat
  -- Predecessor:
  TPred : Term ctx TyNat ->
          Term ctx TyNat
  -- Test for equality with 'Zero'
  -- (with terms for the "then" and
  -- "else" branches):
  TIfz  : Term ctx TyNat -> Term ctx t -> Term ctx t ->
          Term ctx t

-- End: WELL-TYPED TERMS OF THE LAMBDA CALCULUS
-----------------------------------------------

---------------------------------------
-- Begin: VALUES IN THE LAMBDA CALCULUS

-- The following lambda calculus terms
-- are values (i.e. normal forms for
-- reduction under the "Step" relation):
--   (1) lambda abstractions (that are
--       not applied),
--   (2) the constant 'Zero',
--   (3) the natural number constants
--       (formed by applying 'Succ' to
--       another value).
data Value : Term [] t -> Type where
  VZero : Value TZero
  VSucc : Value e -> Value (TSucc e)
  VAbs  : Value (TAbs e)

valueTerm : {e : Term [] t} -> Value e -> Term [] t
valueTerm {e = e} _ = e

-- End: VALUES IN THE LAMBDA CALCULUS
-------------------------------------


module Expr

data Expr num = Val num
    | Add (Expr num) (Expr num)
    | Sub (Expr num) (Expr num)
    | Mul (Expr num) (Expr num)

Num ty => Num (Expr ty) where
    (+) = Add
    (*) = Mul
    fromInteger = Val . fromInteger

-- Ex 7.2 #1
Cast ty String => Show (Expr ty) where
    show (Val x) = cast x
    show (Add x y) = "(" ++ show x ++ " + " ++ show y ++ ")"
    show (Sub x y) = "(" ++ show x ++ " - " ++ show y ++ ")"
    show (Mul x y) = "(" ++ show x ++ " * " ++ show y ++ ")"

eval : (Neg num, Integral num) => Expr num -> num
eval (Val x) = x
eval (Add x y) = eval x + eval y
eval (Sub x y) = eval x - eval y
eval (Mul x y) = eval x * eval y

-- Ex 7.2 #2
(Neg num, Integral num, Eq num) => Eq (Expr num) where
    (==) x y = eval x == eval y

-- Ex 7.2 #3
(Neg num, Integral num) => Cast (Expr num) num where
  cast orig = eval orig

-- Ex 7.3 #1
Functor Expr where
  map func (Val x) = Val (func x)
  map func (Add x y) = Add (map func x) (map func y)
  map func (Sub x y) = Sub (map func x) (map func y)
  map func (Mul x y) = Mul (map func x) (map func y)

-- Ex 7.3 #2
data Vect : (size : Nat) -> (ty : Type) -> Type where
     Nil : Vect Z ty
     (::) : ty -> Vect size ty -> Vect (S size) ty

Eq ty => Eq (Vect n ty) where
  (==) [] [] = True
  (==) (x :: z) (y :: w) = x == y && z == w

Foldable (Vect n) where
  foldr func acc [] = acc
  foldr func acc (x :: xs) = func x (foldr func acc xs)
  foldl func acc [] = acc
  foldl func acc (x :: xs) = func (foldl func acc xs) x


module HandMadeVectorStuff

import Data.Fin

%default total

data Vect : Nat -> Type -> Type where
  Nil : Vect Z a
  (::) : (x : a) -> (xs : Vect n a) -> Vect (S n) a

%name Vect xs, ys, zs

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

zip : Vect m a -> Vect m b -> Vect m (a, b)
zip [] [] = []
zip (x :: xs) (y :: ys) = (x, y) :: zip xs ys

vectTake : (n : Fin m) -> Vect m a -> Vect (finToNat n) a
vectTake FZ xs = []
vectTake (FS x) (y :: xs) = y :: vectTake x xs

vectGet : (x : Fin n) -> Vect n a -> a
vectGet FZ (x :: xs) = x
vectGet (FS x) (y :: xs) = vectGet x xs

sumEntries : Num e => Integer -> Vect n e -> Vect n e -> Maybe e
sumEntries {n} i xs ys = map sumAtIndex (integerToFin i n)
  where sumAtIndex fin = vectGet fin xs + (vectGet fin ys)

-- tryIndex : Integer -> Vect n a -> Maybe a
-- tryIndex {n} x xs = map (\fin => ?index fin xs) (integerToFin x n)


module Data.List.AtIndex

import Data.DPair
import Data.List.HasLength
import Data.Nat
import Decidable.Equality

%default total

||| @AtIndex witnesses the fact that a natural number encodes a membership proof.
||| It is meant to be used as a runtime-irrelevant gadget to guarantee that the
||| natural number is indeed a valid index.
public export
data AtIndex : a -> List a -> Nat -> Type where
  Z : AtIndex a (a :: as) Z
  S : AtIndex a as n -> AtIndex a (b :: as) (S n)

||| Inversion principle for Z constructor
export
inverseZ : AtIndex x (y :: xs) Z -> x === y
inverseZ Z = Refl

||| inversion principle for S constructor
export
inverseS : AtIndex x (y :: xs) (S n) -> AtIndex x xs n
inverseS (S p) = p

||| An empty list cannot possibly have members
export
Uninhabited (AtIndex a [] n) where
  uninhabited Z impossible
  uninhabited (S _) impossible

||| For a given list and a given index, there is only one possible value
||| stored at that index in that list
export
atIndexUnique : AtIndex a as n -> AtIndex b as n -> a === b
atIndexUnique Z Z = Refl
atIndexUnique (S p) (S q) = atIndexUnique p q

||| Provided that equality is decidable, we can look for the first occurence
||| of a value inside of a list
public export
find : DecEq a => (x : a) -> (xs : List a) -> Dec (Subset Nat (AtIndex x xs))
find x [] = No (\ p => void (absurd (snd p)))
find x (y :: xs) with (decEq x y)
  find x (x :: xs) | Yes Refl = Yes (Element Z Z)
  find x (y :: xs) | No neqxy = case find x xs of
      Yes (Element n prf) => Yes (Element (S n) (S prf))
      No notInxs => No $ \case
        (Element Z p) => void (neqxy (inverseZ p))
        (Element (S n) prf) => absurd (notInxs (Element n (inverseS prf)))

||| If the equality is not decidable, we may instead rely on interface resolution
public export
interface Member (0 t : a) (0 ts : List a) where
  isMember' : Subset Nat (AtIndex t ts)

public export
isMember : (0 t : a) -> (0 ts : List a) -> Member t ts =>
              Subset Nat (AtIndex t ts)
isMember t ts @{p} = isMember' @{p}

public export
Member t (t :: ts) where
  isMember' = Element 0 Z

public export
Member t ts => Member t (u :: ts) where
  isMember' = let (Element n prf) = isMember t ts in
              Element (S n) (S prf)

||| Given an index, we can decide whether there is a value corresponding to it
public export
lookup : (n : Nat) -> (xs : List a) -> Dec (Subset a (\ x => AtIndex x xs n))
lookup n [] = No (\ p => void (absurd (snd p)))
lookup Z (x :: xs) = Yes (Element x Z)
lookup (S n) (x :: xs) = case lookup n xs of
  Yes (Element x p) => Yes (Element x (S p))
  No notInxs => No (\ (Element x p) => void (notInxs (Element x (inverseS p))))

||| An AtIndex proof implies that n is less than the length of the list indexed into
public export
inRange : (n : Nat) -> (xs : List a) -> (0 _ : AtIndex x xs n) -> LTE n (length xs)
inRange n [] p = void (absurd p)
inRange Z (x :: xs) p = LTEZero
inRange (S n) (x :: xs) p = LTESucc (inRange n xs (inverseS p))

|||
export
weakenR : AtIndex x xs n -> AtIndex x (xs ++ ys) n
weakenR Z = Z
weakenR (S p) = S (weakenR p)

export
weakenL : (p : Subset Nat (HasLength ws)) -> AtIndex x xs n -> AtIndex x (ws ++ xs) (fst p + n)
weakenL m p = case view m of
  Z     => p
  (S m) => S (weakenL m p)

export
strengthenL : (p : Subset Nat (HasLength xs)) ->
              lt n (fst p) === True ->
              AtIndex x (xs ++ ys) n -> AtIndex x xs n
strengthenL m lt idx = case view m of
  S m => case idx of
    Z => Z
    S idx => S (strengthenL m lt idx)

export
strengthenR : (p : Subset Nat (HasLength ws)) ->
              lte (fst p) n === True ->
              AtIndex x (ws ++ xs) n -> AtIndex x xs (minus n (fst p))
strengthenR m lt idx = case view m of
  Z => rewrite minusZeroRight n in idx
  S m => case idx of S idx => strengthenR m lt idx


> module Identity.Operations

> import Control.Monad.Identity

> import Sigma.Sigma

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

> |||
> unwrap : Identity a -> a
> unwrap {a} (Id x) = x

* |Identity| is a functor:

> ||| fmap
> fmap : {A, B : Type} -> (A -> B) -> Identity A -> Identity B
> fmap = map {f = Identity}

* |Identity| is a monad:

> ||| ret
> ret : {A : Type} -> A -> Identity A
> ret = pure

> ||| bind
> bind : {A, B : Type} -> Identity A -> (A -> Identity B) -> Identity B
> bind = (>>=)

* |Identity| is a container monad:

> ||| Membership
> Elem : {A : Type} -> A -> Identity A -> Type
> Elem a1 (Id a2) = a1 = a2

> ||| Non emptiness
> NonEmpty : {A : Type} -> Identity A -> Type
> NonEmpty _ = Unit

> |||
> All : {A : Type} -> (P : A -> Type) -> Identity A -> Type
> All P = P . unwrap

> ||| Tagging
> tagElem  :  {A : Type} -> (ia : Identity A) -> Identity (Sigma A (\ a => a `Elem` ia))
> tagElem (Id a) = Id (MkSigma a Refl)

> |||
> unwrapElemLemma : (ia : Identity a) -> Elem (unwrap ia) ia
> unwrapElemLemma (Id a) = Refl


> module NonNegDouble.MeasureProperties

> import Syntax.PreorderReasoning

> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.Measures
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import List.Properties

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

* Properties of |average|:

> %freeze monotoneSum

> using implementation NumNonNegDouble
>   using implementation FractionalNonNegDouble
>     ||| |average| is monotone
>     monotoneAverage : {A : Type} ->
>                       (f : A -> NonNegDouble) -> (g : A -> NonNegDouble) ->
>                       (p : (a : A) -> f a `LTE` g a) ->
>                       (as : List A) ->
>                       average (map f as) `LTE` average (map g as)
>     monotoneAverage f g p as = monotoneMultLTE {a = sum (map f as)}
>                                                {b = sum (map g as)}
>                                                {c = one / fromNat (length (map f as))}
>                                                {d = one / fromNat (length (map g as))}
>                                                s1 s3 where
>       s1 : sum (map f as) `LTE` sum (map g as)
>       s1 = monotoneSum f g p as
>       s2 : one / fromNat (length (map f as)) `LTE` one / fromNat (length (map f as))
>       s2 = reflexiveLTE (one / fromNat (length (map f as)))
>       s3 : one / fromNat (length (map f as)) `LTE` one / fromNat (length (map g as))
>       s3 = replace {P = \ X => one / fromNat (length (map f as)) `LTE` one / fromNat X} (lengthLemma as f g) s2

> {-

> ---}