{-
Joseph Eremondi
Utrecht University Capita Selecta
UU# 4229924
July 22, 2015
-}

module SemiLin where

open import Data.Vec
open import Data.Nat
import Data.Fin as Fin

open import Data.List
import Data.List.All
open import Data.Bool
open import Data.Char

open import Data.Maybe

open import Data.Product
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.Core

open import Category.Monad

open import Data.Nat.Properties.Simple

open import Data.Maybe
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Utils

open import Function

import RETypes

open import Data.Sum

import Data.Nat.Properties.Simple

--The Parikh vector for a word is the count of occurrences of
--each letter of our alphabet in that word.
--We just represent this as a vector of Natural numbers
Parikh : ℕ -> Set
Parikh n = Vec ℕ n

--Scalar multiplication
_·ₛ_ : {n : ℕ} -> ℕ -> Parikh n -> Parikh n
c ·ₛ [] = []
c ·ₛ (x ∷ vt) = (c * x) ∷ (c ·ₛ vt)

--Vector addition
_+v_ : {n : ℕ} -> Parikh n -> Parikh n -> Parikh n
[] +v [] = []
(x ∷ ut) +v (y ∷ vt) = x + y ∷ ut +v vt

--The zero vector
v0 : {n : ℕ} -> Parikh n
v0 {zero} = []
v0 {suc n} = 0 ∷ v0

--0 times anything is v0
scalar0ident : {n : ℕ} -> (v : Parikh n ) -> 0 ·ₛ v ≡ v0
scalar0ident [] = refl
scalar0ident (x ∷ v) = cong (_∷_ zero) (scalar0ident v)

--Prove that 0 is a neutral element on the left
v0identLeft : {n : ℕ} -> {v : Parikh n} -> v0 +v v ≡ v
v0identLeft {v = []} = refl
v0identLeft {v = x ∷ v} =
  let
    subIdent = v0identLeft {v = v}
  in cong (λ t → x ∷ t) subIdent

--Prove that vector addition is commutative
v+-commut : {n : ℕ} -> (u : Parikh n) -> (v : Parikh n) -> (u +v v ≡ v +v u)
v+-commut [] [] = refl
v+-commut (x ∷ u) (y ∷ v) rewrite +-comm x y  | v+-commut u v = refl

--Prove the right-identity for vector addition with 0
--Just conbines commutativity and the left identity
v0identRight : {n : ℕ} -> {v : Parikh n} -> v +v v0 ≡ v
v0identRight {v = v} =
  begin
    v +v v0
  ≡⟨ v+-commut v v0 ⟩
    v0 +v v
  ≡⟨ v0identLeft ⟩
    v ∎

--Prove that vector addition is associative
--I couldn't figure out how to get this one working with rewrite
vAssoc : {n : ℕ} -> {x : Parikh n} {y : Parikh n} {z : Parikh n}
  -> (x +v y) +v z ≡ x +v (y +v z)
vAssoc {zero} {[]} {[]} {[]} = refl
vAssoc {suc n} {xh ∷ xt} {yh ∷ yt} {zh ∷ zt} =
  let
    x = xh ∷ xt
    y = yh ∷ yt
    z = zh ∷ zt
  in --_≡⟨_⟩_
      begin
        (x +v y) +v z
      ≡⟨ refl ⟩
        (xh + yh + zh) ∷ (xt +v yt) +v zt
      ≡⟨ cong (λ h → h ∷ (xt +v yt) +v zt) (+-assoc xh yh zh) ⟩
        xh + (yh + zh) ∷ (xt +v yt) +v zt
      ≡⟨ cong (λ t → xh + (yh + zh) ∷ t) vAssoc ⟩
        (xh + (yh + zh) ∷ xt +v (yt +v zt))
      ≡⟨ refl ⟩
        x +v (y +v z)
      ∎

-- Wouter: here's one definition using rewrite...
vAssoc2 : {n : ℕ} -> {x : Parikh n} {y : Parikh n} {z : Parikh n}
  -> (x +v y) +v z ≡ x +v (y +v z)
vAssoc2 {x = []} {[]} {[]} = refl
vAssoc2 {x = x ∷ xs} {y ∷ ys} {z ∷ zs} rewrite +-assoc x y z | vAssoc {x = xs} {y = ys} {z = zs}
  = refl

--Prove that scalar multiplication distributes over vector addition
scalarAssoc : {n : ℕ} -> (x y : ℕ ) -> (v : Parikh n) -> (x + y) ·ₛ v ≡  (x ·ₛ v) +v (y ·ₛ v)
scalarAssoc x y [] = refl
scalarAssoc x y (vfirst ∷ v) rewrite scalarAssoc x y v | distribʳ-*-+ vfirst x y = refl

--Handy lemma, prove that 0 + anything is 0
ident0 : (x : ℕ) -> x + 0 ≡ x
ident0 zero = refl
ident0 (suc x) = cong suc (ident0 x)

--Show that 1 is an identity for scalar multiplication
scalarIdent : {n : ℕ} -> (v : Parikh n) -> (1 ·ₛ v ≡ v )
scalarIdent [] = refl
scalarIdent (x ∷ v) rewrite scalarIdent v | ident0 x = refl

--A linear set is defined by an offset vector b
--And a set of m vectors v1 ... vm.
--A vector u is in a linear set if there exists constants c1 ... cm
--such that u = b + c1·v1 + ... + cm·vm

-- Wouter -- do you really want to existentially quantify m?
-- You could also define LinSet n m = Parikh n × Vec (Parikh n) m
--  I don' think it makes a whole lot of difference, but later on in applyLinCom
--  you use this anyway.
--  For what it's worth, you may want to note that ∃ n . Vec a n is isomorphic to List a
LinSet : ℕ -> Set
LinSet n = (Parikh n) × (∃ λ (m : ℕ) → Vec (Parikh n) m )

--Given an offset vector, a set of m Parikh vectors, and a set of m constants
--Return b + c1·v1 + ... + cm·vm
-- Wouter: you might want to consider defining this directly by recursion over the
--  cs and vset. The induction you use in this definition will determine how easy/hard
--  it might be to reason about this function later.
--  See the proof of sumPreserved in SemiLinRE, for instance.
applyLinComb : {n : ℕ} -> Parikh n -> (m : ℕ ) -> (Vec (Parikh n) m ) -> Vec ℕ m ->  Parikh n
applyLinComb base .0 [] cs = base
applyLinComb base (suc m) (firstVec ∷ vset) (firstConst ∷ cs) = (firstConst ·ₛ firstVec) +v (applyLinComb base m vset cs)

--Show that, if all the coefficients in a linear combination are 0, that the resulting vector is the base (offset) vector
v0apply : {n m : ℕ} -> (base : Parikh n) -> (vecs : Vec (Parikh n) m ) -> applyLinComb base m  vecs (v0 {m}) ≡ base
v0apply base [] = refl
v0apply {n} {suc m} base (x ∷ vecs) rewrite scalar0ident x | v0apply base vecs = v0identLeft

--A type acting as a witness that a vector is in a linear set
--Is just a set of coefficients, and a proof that those coefficients
--form v as a linear combination of vectors in our linear set's list
LinComb : {n : ℕ} -> Parikh n -> LinSet n -> Set
LinComb {n} initV (base , m , vset)  =
  ∃ (λ (cs : Vec ℕ m) -> applyLinComb base m vset cs ≡ initV )

--Sum of each vector in a linear set i.e. L1 + L2 = {x + y | x in L1, y in L2 }
--We just add the bases, and concatenate the list of vectors which can be multiplied by constants
_+l_ : {n : ℕ} -> LinSet n -> LinSet n -> LinSet n
(base1 , m1 , vecs1 ) +l (base2 , m2 , vecs2 ) = (base1 +v base2 , m1 + m2 , vecs1 Data.Vec.++ vecs2 )

--A semi-linear is a finite union of linear sets
--We represent this using a list of linear sets
SemiLinSet : ℕ -> Set
SemiLinSet n = List (LinSet n)

--Sum each linear set in the two semi-linear sets
--We basically just do a pairwise +l for each linear set in each of the semi-linear sets
_+s_ : {n : ℕ} -> SemiLinSet n -> SemiLinSet n -> SemiLinSet n
s1 +s s2 = Data.List.concat (Data.List.map (λ l1 -> Data.List.map (λ l2 -> l1 +l l2 )  s2 ) s1 )

--Data type for a witness that an element is in a semiLinear set
--Basically just a proof that there's some element (linear set) of the list containing the vector
data InSemiLin : {n : ℕ} -> (v : Parikh n) -> (sl : SemiLinSet n) -> Set where
  InHead : {n : ℕ}
    -> (v : Parikh n)
    -> (sh : LinSet n)
    -> (st : SemiLinSet n)
    -> LinComb v sh
    -> InSemiLin v (sh ∷ st)
  InTail : {n : ℕ}
    -> (v : Parikh n)
    -> (sh : LinSet n)
    -> (st : SemiLinSet n)
    -> InSemiLin v st
    -> InSemiLin v (sh ∷ st)

--Creates a  vector
--Which has 1 in the specified component, and 0 elsewhere
basis : { n : ℕ} -> ( i : Fin.Fin n ) -> Parikh n
basis Fin.zero  = Data.Vec.[ suc zero ] Data.Vec.++ v0
basis (Fin.suc f) = 0 ∷ basis f

--A proof that if a vector is in a SemiLinear set, then the vector is also in the
--union of that SemiLinear set with another single linear set
slExtend : {n : ℕ} -> (v : Parikh n) -> (sl : SemiLinSet n) -> InSemiLin v sl -> (ls : LinSet n) -> InSemiLin v (ls ∷ sl )
slExtend v sl inTail ls = InTail v ls sl inTail

--the above proof, but extended to an arbitrary number of linear sets
slConcatLeft : {n : ℕ} -> (v : Parikh n) -> (sl : SemiLinSet n) -> InSemiLin v sl -> (sl2 : SemiLinSet n) -> InSemiLin v (sl2 Data.List.++  sl )
slConcatLeft v sl inTail [] = inTail
slConcatLeft v sl inTail (x ∷ sl2) = InTail v x (sl2 Data.List.++ sl) (slConcatLeft v sl inTail sl2)

--The above proof, but the vectors are concatenated on the right
slConcatRight : {n : ℕ} -> (v : Parikh n) -> (sl : SemiLinSet n) -> InSemiLin v sl -> (sl2 : SemiLinSet n) -> InSemiLin v (sl Data.List.++  sl2 )
slConcatRight v .(sh ∷ st) (InHead .v sh st x) sl2 = (InHead v sh (st Data.List.++ sl2) x)
slConcatRight v .(sh ∷ st) (InTail .v sh st inTail) sl2 = slExtend v (st Data.List.++ sl2) (slConcatRight v st inTail sl2) sh

--Show that, if a vector is in a linear-set, then it is in a semi-linear set containing that linear set
slCons :  {n : ℕ} -> (v : Parikh n) -> (sl : SemiLinSet n) -> (ls : LinSet n) -> (InSemiLin v (ls ∷ [] ) ) -> InSemiLin v (ls ∷ sl )
slCons v sl sh (InHead .v .sh .[] x) = InHead v sh sl x
slCons v sl sh (InTail .v .sh .[] ())

--A linear set containing only v0
l0 : {n : ℕ} -> LinSet n
l0 = (v0 , zero , [] )

--A semi-linear set containing only v0
s0 : {n : ℕ} -> SemiLinSet n
s0 = (v0 , zero , [] ) ∷ []

--Show that, if a vector is in s0, then it must be v0
s0match : {n : ℕ} -> (v : Parikh n) -> InSemiLin v s0 -> v ≡ v0
s0match .v0 (InHead .v0 .(v0 , 0 , []) .[] (comb , refl)) = refl
s0match v (InTail .v .(v0 , 0 , []) .[] ())

--Show that if a vector is in a semi-lin set, then it's not the empty list
inSemiNonEmtpy : {n : ℕ} -> (v : Parikh n) -> (s : SemiLinSet n) -> InSemiLin v s -> ∃ λ sh -> ∃ λ st -> s ≡ sh ∷ st
inSemiNonEmtpy v .(sh ∷ st) (InHead .v sh st x) = sh , st , refl
inSemiNonEmtpy v .(sh ∷ st) (InTail .v sh st inSemi) = sh , st , refl

-------------Functions for Star ------------------
-- Star is by far the most complicated case, so a large number of definitions and lemmas
--Are dedicated to it

--Given a linear set L, find another linear set
--such that L = L +l (L*)
--We do this by allowing the base to appear an arbitrary number of times
linStar : {n : ℕ} -> LinSet n -> LinSet n
linStar (base , m , vecs ) = (base , suc m , base ∷ vecs )

--Given a non-empty semi-linear set, find the sum of the star
--of all linear sets it contains
starSum : {n : ℕ} -> LinSet n -> SemiLinSet n -> LinSet n
starSum ls [] = linStar ls
starSum first (sh ∷ s) = (linStar sh) +l starSum first s

--The semi-linear set for the Star of a regular expression
--The semi-linear set always contains 0, since the empty string matches r*
--We then union s0 with the sum of the star of each linear set
--in the Parikh image of r
starSemiLin : {n : ℕ} -> SemiLinSet n -> SemiLinSet n
starSemiLin [] = s0
starSemiLin (first ∷ s) = s0 Data.List.++ (  starSum first s ∷ [])

--Show that v0 is always in a star semi-linear set
zeroInStar : {n : ℕ} -> (s ss : SemiLinSet n) -> ss ≡ (starSemiLin s)  -> InSemiLin v0 ss
zeroInStar [] .((v0 , 0 , []) ∷ []) refl = InHead v0 (v0 , zero , []) [] ([] , refl)
zeroInStar (x ∷ s) .((v0 , 0 , []) ∷ starSum x s ∷ []) refl = InHead v0 (v0 , zero , []) (starSum x s ∷ []) ([] , refl)

--Show that if we sum two linear sets, then the number of vectors that can be combined
--is the sum of the number in each input set
linSetLen : {n : ℕ} -> (l1 l2 l3 : LinSet n) -> l1 +l l2 ≡ l3 -> (proj₁ (proj₂ l3)) ≡ (proj₁ (proj₂ l1)) + (proj₁ (proj₂ l2))
linSetLen (proj₁ , m1 , proj₂) (proj₃ , m2 , proj₄) .(proj₁ +v proj₃ , m1 + m2 , proj₂ Data.Vec.++ proj₄) refl = refl

--Useful lemma, suc x = x + 1
plusOneDef : ( x : ℕ) -> (suc x ≡ x + 1)
plusOneDef zero = refl
plusOneDef (suc x) = cong suc (plusOneDef x)

--Show that we can "remove" part of the base vector
--When making a linear combination
baseSplit : {n : ℕ} (ub vb : Parikh n) (vm : ℕ) (vvecs : Vec (Parikh n) vm) (vconsts : Vec ℕ vm) ->
  applyLinComb (ub +v vb) vm vvecs vconsts
  ≡ ub +v applyLinComb vb vm vvecs vconsts
baseSplit ub vb .0 [] [] = refl
baseSplit ub vb (suc m) (x ∷ vvecs) (c ∷ vconsts)  =
  begin
  applyLinComb (ub +v vb) (suc m) (x ∷ vvecs) (c ∷ vconsts)
  ≡⟨ refl ⟩ --cong {!!} (baseSplit ub vb _ vvecs vconsts)
  (c ·ₛ x) +v applyLinComb (ub +v vb) m vvecs vconsts
  ≡⟨ cong (λ x₁ → (c ·ₛ x) +v x₁) (baseSplit ub vb m vvecs vconsts) ⟩
  (c ·ₛ x) +v (ub +v applyLinComb vb m vvecs vconsts)
  ≡⟨ sym vAssoc ⟩
  ((c ·ₛ x) +v ub) +v applyLinComb vb m vvecs vconsts
  ≡⟨ cong (λ x₁ → x₁ +v applyLinComb vb m vvecs vconsts) (v+-commut (c ·ₛ x) ub) ⟩
  (ub +v (c ·ₛ x)) +v applyLinComb vb m vvecs vconsts
  ≡⟨ vAssoc ⟩
  (ub +v ((c ·ₛ x) +v applyLinComb vb m vvecs vconsts) ∎)

--If we have two linear combinations of vectors,
--That we can make it into a single combination of vectors
--By adding the bases, and concatenating the vector lists, and
-- concatenating the coefficient lists
combSplit :
  {n : ℕ} (ub vb : Parikh n) (um vm : ℕ) (uvecs : Vec (Parikh n) um) (vvecs : Vec (Parikh n) vm) (uconsts : Vec ℕ um) (vconsts : Vec ℕ vm) ->
  (applyLinComb (ub +v vb) (um + vm) (uvecs Data.Vec.++ vvecs) (uconsts Data.Vec.++ vconsts)
  ≡ (applyLinComb ub um uvecs uconsts) +v (applyLinComb vb vm vvecs vconsts) )
combSplit ub vb .0 vm [] vvecs [] vconsts = baseSplit ub vb vm vvecs vconsts
combSplit ub vb (suc um) vm (x ∷ uvecs) vvecs (uc ∷ uconsts) vconsts =
  begin
  applyLinComb (ub +v vb) (suc (um + vm))
    (x ∷ uvecs Data.Vec.++ vvecs) ((uc ∷ uconsts) Data.Vec.++ vconsts)
  ≡⟨ refl ⟩
  (uc ·ₛ x) +v applyLinComb (ub +v vb) (um + vm) (uvecs Data.Vec.++ vvecs)
                 (uconsts Data.Vec.++ vconsts)
  ≡⟨ cong (λ x₁ → (uc ·ₛ x) +v x₁) (combSplit ub vb um vm uvecs vvecs uconsts vconsts) ⟩
  (uc ·ₛ x) +v
    (applyLinComb ub um uvecs uconsts +v
     applyLinComb vb vm vvecs vconsts)
  ≡⟨ sym vAssoc ⟩
  ((uc ·ₛ x) +v applyLinComb ub um uvecs uconsts) +v
    applyLinComb vb vm vvecs vconsts
  ≡⟨ refl ⟩
  (((uc ·ₛ x) +v applyLinComb ub um uvecs uconsts) +v
     applyLinComb vb vm vvecs vconsts ∎)

--Extend the idea of distributivity to linear combinations
--Basically, the c1*v +v c2*v = (c1 +v c2 )*v, where * is element-wise product
applyCombSum :
  {n m : ℕ} ->
  (vecs : Vec (Parikh n) m ) ->
  (uconsts vconsts : Parikh m ) ->
  applyLinComb v0 m vecs (uconsts +v vconsts) ≡ applyLinComb v0 m vecs uconsts +v applyLinComb v0 m vecs vconsts
applyCombSum [] uconsts vconsts = sym v0identRight
applyCombSum {n} {suc m} (firstVec ∷ vecs) (uc ∷ uconsts) (vc ∷ vconsts) rewrite applyCombSum vecs uconsts vconsts | scalarAssoc uc vc firstVec =
  begin
  ((uc ·ₛ firstVec) +v (vc ·ₛ firstVec)) +v
    (applyLinComb v0 m vecs uconsts +v
     applyLinComb v0 m vecs vconsts)
  ≡⟨ vAssoc ⟩
  (uc ·ₛ firstVec) +v
    ((vc ·ₛ firstVec) +v
     (applyLinComb v0 m vecs uconsts +v
      applyLinComb v0 m vecs vconsts))
  ≡⟨ cong (λ x → (uc ·ₛ firstVec) +v x) (v+-commut (vc ·ₛ firstVec) (applyLinComb v0 m vecs uconsts +v applyLinComb v0 m vecs vconsts)) ⟩
  (uc ·ₛ firstVec) +v
    ((applyLinComb v0 m vecs uconsts +v applyLinComb v0 m vecs vconsts)
     +v (vc ·ₛ firstVec))
  ≡⟨ sym vAssoc ⟩
  ((uc ·ₛ firstVec) +v
     (applyLinComb v0 m vecs uconsts +v applyLinComb v0 m vecs vconsts))
    +v (vc ·ₛ firstVec)
  ≡⟨ cong (λ x → x +v (vc ·ₛ firstVec)) (sym vAssoc) ⟩
  (((uc ·ₛ firstVec) +v applyLinComb v0 m vecs uconsts) +v
     applyLinComb v0 m vecs vconsts)
    +v (vc ·ₛ firstVec)
  ≡⟨ vAssoc ⟩
  ((uc ·ₛ firstVec) +v applyLinComb v0 m vecs uconsts) +v
    (applyLinComb v0 m vecs vconsts +v (vc ·ₛ firstVec))
  ≡⟨ cong (λ x → ((uc ·ₛ firstVec) +v applyLinComb v0 m vecs uconsts) +v x) (v+-commut (applyLinComb v0 m vecs vconsts) (vc ·ₛ firstVec)) ⟩
  ((uc ·ₛ firstVec) +v applyLinComb v0 m vecs uconsts) +v
    ((vc ·ₛ firstVec) +v applyLinComb v0 m vecs vconsts) ∎

--If a linear set has base 0, and u and v are both in that set, then u+v is as well
sumEqualVecs : {n : ℕ} -> (ls : LinSet n) -> (proj₁ ls ≡ v0) -> (u v : Parikh n) -> LinComb u ls -> LinComb v ls -> LinComb (u +v v) ls
sumEqualVecs (.v0 , m , vecs) refl .(applyLinComb v0 m vecs uconsts) .(applyLinComb v0 m vecs vconsts) (uconsts , refl) (vconsts , refl)  =
  (uconsts +v vconsts) , applyCombSum vecs uconsts vconsts --applyCombSum {!!} {!!} vecs uconsts vconsts

--Show that the base vector of a linear set is always in that set, just set coefficients to 0
linContainsBase : {n : ℕ} -> (base : Parikh n) -> (m : ℕ ) -> (vecs : Vec (Parikh n) m ) -> applyLinComb base m vecs v0 ≡ base
linContainsBase base .0 [] = refl
linContainsBase base (suc m) (x ∷ vecs) rewrite linContainsBase base m vecs  =
  begin
  (zero ·ₛ x) +v base
  ≡⟨ cong (λ y → y +v base) (scalar0ident x) ⟩
  v0 +v base
  ≡⟨ v0identLeft ⟩
  (base ∎)

--Show that applying a linear combination with the base is just
--The base, plus the linear combination with v0 base
--Just a useful lemma for other proofs, basically uses associativity
linCombRemoveBase
 :  {n : ℕ}
 -> (m : ℕ )
 -> (base : Parikh n )
 -> (vecs : Vec (Parikh n) m )
 -> (c : Parikh m)
 -> applyLinComb base m vecs c ≡ base +v applyLinComb v0 m vecs c
linCombRemoveBase {n} m base vecs c =
  begin
  applyLinComb base m vecs c
  ≡⟨ cong (λ x → applyLinComb x m vecs c) (sym v0identRight) ⟩
  applyLinComb (base +v v0) m vecs c
  ≡⟨ baseSplit base v0 m vecs c ⟩
  base +v applyLinComb v0 m vecs c ∎

--Show that only v0 is in a set with no vectors and v0 base
emptyCombZero : {n : ℕ} -> (v : Parikh n ) -> LinComb v (v0 , 0 , []) -> v ≡ v0
emptyCombZero .v0 ([] , refl) = refl

--Show that when we add two linear combinations of the same vectors together,
--We get a linear combination of those vectors, with an extra base left-over
linCombDecompBase
 :  {n : ℕ}
 -> (m : ℕ )
 -> (base : Parikh n )
 -> (vecs : Vec (Parikh n) m )
 -> (c1 : Parikh m )
 -> (c2 : Parikh m)
 -> (applyLinComb base m vecs c1 ) +v (applyLinComb base m vecs c2 ) ≡ base +v applyLinComb base m vecs (c1 +v c2)
linCombDecompBase .0 base [] c1 c2 = refl
linCombDecompBase (suc m) base (vec1 ∷ vecs) (c ∷ c1) (cc ∷ c2) rewrite linCombDecompBase m base vecs c1 c2 | linCombRemoveBase m base vecs c1 | linCombRemoveBase m base vecs c2   =
  begin
  ((c ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c1)) +v
    ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → x +v ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))) (sym vAssoc ) ⟩
  (((c ·ₛ vec1) +v base) +v applyLinComb v0 m vecs c1) +v
    ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → (x +v applyLinComb v0 m vecs c1) +v ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))) (v+-commut (c ·ₛ vec1) base) ⟩
  ((base +v (c ·ₛ vec1)) +v applyLinComb v0 m vecs c1) +v
    ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → x +v ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))) vAssoc ⟩
  (base +v ((c ·ₛ vec1) +v applyLinComb v0 m vecs c1)) +v
    ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2))
  ≡⟨ vAssoc ⟩
  base +v
    (((c ·ₛ vec1) +v applyLinComb v0 m vecs c1) +v
     ((cc ·ₛ vec1) +v (base +v applyLinComb v0 m vecs c2)))
  ≡⟨ cong (λ x → base +v (((c ·ₛ vec1) +v applyLinComb v0 m vecs c1) +v x)) (sym vAssoc) ⟩
  base +v
    (((c ·ₛ vec1) +v applyLinComb v0 m vecs c1) +v
     (((cc ·ₛ vec1) +v base) +v applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → base +v (((c ·ₛ vec1) +v applyLinComb v0 m vecs c1) +v (x +v applyLinComb v0 m vecs c2))) (v+-commut (cc ·ₛ vec1) base) ⟩
  base +v
    (((c ·ₛ vec1) +v applyLinComb v0 m vecs c1) +v
     ((base +v (cc ·ₛ vec1)) +v applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → base +v x) vAssoc ⟩
  base +v
    ((c ·ₛ vec1) +v
     (applyLinComb v0 m vecs c1 +v
      ((base +v (cc ·ₛ vec1)) +v applyLinComb v0 m vecs c2)))
  ≡⟨ cong (λ x → base +v ((c ·ₛ vec1) +v x)) (sym vAssoc) ⟩
  base +v
    ((c ·ₛ vec1) +v
     ((applyLinComb v0 m vecs c1 +v (base +v (cc ·ₛ vec1))) +v
      applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → base +v ((c ·ₛ vec1) +v (x +v applyLinComb v0 m vecs c2))) (v+-commut (applyLinComb v0 m vecs c1) (base +v (cc ·ₛ vec1))) ⟩
  base +v
    ((c ·ₛ vec1) +v
     (((base +v (cc ·ₛ vec1)) +v applyLinComb v0 m vecs c1) +v
      applyLinComb v0 m vecs c2))
  ≡⟨ cong (λ x → base +v ((c ·ₛ vec1) +v x)) vAssoc ⟩
  base +v
    ((c ·ₛ vec1) +v
     ((base +v (cc ·ₛ vec1)) +v
      (applyLinComb v0 m vecs c1 +v applyLinComb v0 m vecs c2)))
  ≡⟨ cong (λ x → base +v ((c ·ₛ vec1) +v ((base +v (cc ·ₛ vec1)) +v x))) (sym (applyCombSum vecs c1 c2)) ⟩
  base +v
    ((c ·ₛ vec1) +v
     ((base +v (cc ·ₛ vec1)) +v applyLinComb v0 m vecs (c1 +v c2)))
  ≡⟨ cong (λ x → base +v x) (sym vAssoc) ⟩
  base +v
    (((c ·ₛ vec1) +v (base +v (cc ·ₛ vec1))) +v
     applyLinComb v0 m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v (x +v applyLinComb v0 m vecs (c1 +v c2))) (sym vAssoc) ⟩
  base +v
    ((((c ·ₛ vec1) +v base) +v (cc ·ₛ vec1)) +v
     applyLinComb v0 m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v ((x +v (cc ·ₛ vec1)) +v applyLinComb v0 m vecs (c1 +v c2))) (v+-commut (c ·ₛ vec1) base) ⟩
  base +v
    (((base +v (c ·ₛ vec1)) +v (cc ·ₛ vec1)) +v
     applyLinComb v0 m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v (x +v applyLinComb v0 m vecs (c1 +v c2))) vAssoc ⟩
  base +v
    ((base +v ((c ·ₛ vec1) +v (cc ·ₛ vec1))) +v
     applyLinComb v0 m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v ((base +v x) +v applyLinComb v0 m vecs (c1 +v c2))) (sym (scalarAssoc c cc vec1)) ⟩
  base +v
    ((base +v ((c + cc) ·ₛ vec1)) +v applyLinComb v0 m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v (x +v applyLinComb v0 m vecs (c1 +v c2))) (v+-commut base ((c + cc) ·ₛ vec1)) ⟩
  base +v
    ((((c + cc) ·ₛ vec1) +v base) +v applyLinComb v0 m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v x) vAssoc ⟩
  base +v
    (((c + cc) ·ₛ vec1) +v (base +v applyLinComb v0 m vecs (c1 +v c2)))
  ≡⟨ cong (λ x → base +v (((c + cc) ·ₛ vec1) +v x)) (sym (baseSplit base v0 m vecs (c1 +v c2))) ⟩
  base +v
    (((c + cc) ·ₛ vec1) +v applyLinComb (base +v v0) m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v (((c + cc) ·ₛ vec1) +v applyLinComb x m vecs (c1 +v c2))) v0identRight ⟩
  base +v (((c + cc) ·ₛ vec1) +v applyLinComb base m vecs (c1 +v c2))
  ≡⟨ cong (λ x → base +v x) refl ⟩
  (base +v (((c + cc) ·ₛ vec1) +v applyLinComb base m vecs (c1 +v c2)) ∎)

--Show that, if v1 is in L, and v2 is in L*, then v1 +v v2 is in L*
--Can be used to show that the sum of any vectors from L will be in L*
linStarExtend
  : {n : ℕ} -> (v1 v2 : Parikh n ) ->
  (l1 ls : LinSet n ) -> ls ≡ linStar l1  -> LinComb v1 l1 -> LinComb v2 ls -> LinComb (v1 +v v2) ls
linStarExtend .(applyLinComb base m vecs c1) .((c2h ·ₛ base) +v applyLinComb base m vecs c2) (base , m , vecs) .(base , suc m , base ∷ vecs) refl (c1 , refl) (c2h ∷ c2 , refl)  =
  ((1 ∷ c1) +v (c2h ∷ c2)) ,
  (begin
  (suc c2h ·ₛ base) +v applyLinComb base m vecs (c1 +v c2)
  ≡⟨ cong (λ x → (x ·ₛ base) +v applyLinComb base m vecs (c1 +v c2)) refl  ⟩
  ((1 + c2h) ·ₛ base) +v applyLinComb base m vecs (c1 +v c2)
  ≡⟨ cong (λ x → (x ·ₛ base) +v applyLinComb base m vecs (c1 +v c2)) (+-comm (suc zero) c2h) ⟩
  ((c2h + 1) ·ₛ base) +v applyLinComb base m vecs (c1 +v c2)
  ≡⟨ cong (λ x → x +v applyLinComb base m vecs (c1 +v c2)) (scalarAssoc c2h 1 base) ⟩
  ((c2h ·ₛ base) +v (1 ·ₛ base)) +v
    applyLinComb base m vecs (c1 +v c2)
  ≡⟨ cong (λ x → ((c2h ·ₛ base) +v x) +v applyLinComb base m vecs (c1 +v c2)) (scalarIdent base) ⟩
  ((c2h ·ₛ base) +v base) +v applyLinComb base m vecs (c1 +v c2)
  ≡⟨ vAssoc ⟩
  (c2h ·ₛ base) +v (base +v applyLinComb base m vecs (c1 +v c2))
  ≡⟨ cong (λ x → (c2h ·ₛ base) +v x) (sym (linCombDecompBase m base vecs c1 c2)) ⟩
  (c2h ·ₛ base) +v
    (applyLinComb base m vecs c1 +v applyLinComb base m vecs c2)
  ≡⟨ cong (λ x → (c2h ·ₛ base) +v x) (v+-commut (applyLinComb base m vecs c1) (applyLinComb base m vecs c2)) ⟩
  (c2h ·ₛ base) +v
    (applyLinComb base m vecs c2 +v applyLinComb base m vecs c1)
  ≡⟨ sym vAssoc ⟩
  ((c2h ·ₛ base) +v applyLinComb base m vecs c2) +v
    applyLinComb base m vecs c1
  ≡⟨ cong (λ x → x +v applyLinComb base m vecs c1 ) refl ⟩
  (applyLinComb base (suc m) (base ∷ vecs) (c2h ∷ c2)) +v
    applyLinComb base m vecs c1
  ≡⟨ v+-commut ((c2h ·ₛ base) +v applyLinComb base m vecs c2) (applyLinComb base m vecs c1) ⟩ applyLinComb base m vecs c1 +v
              ((c2h ·ₛ base) +v applyLinComb base m vecs c2) ∎
  )

--Show that every non-empty vector in L* for a linear-set L
--Can be split into a vector from L and another in L*
--Basically proves that L* contains only sums of vectors in L
linStarDecomp
 :  {n : ℕ}
 -> (v : Parikh n)
 -> (l ls : LinSet n)
 -> v ≢ v0
 -> proj₁ (l) ≢ v0
 -> ls ≡ linStar l
 -> LinComb v ls
 -> LinComb v l ⊎ (∃ λ v1 -> ∃ λ v2 -> v1 +v v2 ≡ v × LinComb v1 l × LinComb v2 ls × v1 ≢ v0 )
linStarDecomp .((0 ·ₛ base) +v applyLinComb base m vecs c) (base , m , vecs) .(base , suc m , base ∷ vecs) vnz bnz refl (zero ∷ c , refl) rewrite scalar0ident base  = inj₁ (c , (sym v0identLeft))
linStarDecomp .((suc cbase ·ₛ base) +v applyLinComb base m vecs c) (base , m , vecs) .(base , suc m , base ∷ vecs) vnz bnz refl (suc cbase ∷ c , refl) = inj₂ ( base , (applyLinComb base (suc m) (base ∷ vecs) (cbase ∷ c)) ,
  (sym (begin -- ? ≡⟨ ? ⟩ ?
    (suc cbase ·ₛ base) +v applyLinComb base m vecs c
    ≡⟨ cong (λ x → x +v applyLinComb base m vecs c) refl ⟩
    ((1 + cbase) ·ₛ base) +v applyLinComb base m vecs c
    ≡⟨ cong (λ x → x +v applyLinComb base m vecs c) (scalarAssoc 1 cbase base) ⟩
    ((suc zero ·ₛ base) +v (cbase ·ₛ base)) +v
      applyLinComb base m vecs c
    ≡⟨ cong (λ x → (x +v (cbase ·ₛ base)) +v applyLinComb base m vecs c) (scalarIdent base) ⟩
    (base +v (cbase ·ₛ base)) +v applyLinComb base m vecs c
    ≡⟨  vAssoc ⟩
    base +v ((cbase ·ₛ base) +v applyLinComb base m vecs c)
    ≡⟨ refl ⟩
    (base +v ((cbase ·ₛ base) +v applyLinComb base m vecs c) ∎))) ,
  (v0 , linContainsBase base m vecs) , ((cbase ∷ c) , refl) , bnz )


module Structure.Operator.Monoid.Homomorphism where

import      Lvl
open import Logic
open import Logic.Predicate
open import Structure.Function
open import Structure.Function.Multi
open import Structure.Operator.Monoid
open import Structure.Setoid
open import Type

record Homomorphism
  {ℓ₁ ℓ₂ ℓₑ₁ ℓₑ₂}
  {X : Type{ℓ₁}} ⦃ _ : Equiv{ℓₑ₁}(X) ⦄ {_▫X_ : X → X → X} ( structureₗ : Monoid(_▫X_))
  {Y : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(Y) ⦄ {_▫Y_ : Y → Y → Y} ( structureᵣ : Monoid(_▫Y_))
  (f : X → Y)
  : Stmt{ℓ₁ Lvl.⊔ ℓₑ₁ Lvl.⊔ ℓ₂ Lvl.⊔ ℓₑ₂} where

  constructor intro

  idₗ = Monoid.id(structureₗ)
  idᵣ = Monoid.id(structureᵣ)

  field
    ⦃ function ⦄ : Function(f)
    ⦃ preserve-op ⦄ : Preserving₂(f)(_▫X_)(_▫Y_)
    ⦃ preserve-id ⦄ : Preserving₀(f)(idₗ)(idᵣ)

_→ᵐᵒⁿᵒⁱᵈ_ : ∀{ℓₗ ℓₗₑ ℓᵣ ℓᵣₑ} → MonoidObject{ℓₗ}{ℓₗₑ} → MonoidObject{ℓᵣ}{ℓᵣₑ} → Type
A →ᵐᵒⁿᵒⁱᵈ B = ∃(Homomorphism(MonoidObject.monoid A)(MonoidObject.monoid B))


{-

This file contains:

- The first Eilenberg–Mac Lane type as a HIT

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.EilenbergMacLane1.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Algebra.Group.Base

private
  variable ℓ : Level

module _ (G : Group {ℓ}) where
  open Group G

  data EM₁ : Type ℓ where
    embase : EM₁
    emloop : Carrier → embase ≡ embase
    emcomp : (g h : Carrier)
           → PathP (λ j → embase ≡ emloop h j) (emloop g) (emloop (g + h))
    -- emsquash : ∀ (x y : EM₁) (p q : x ≡ y) (r s : p ≡ q) → r ≡ s
    emsquash : isGroupoid EM₁

  {- The comp// constructor fills the square:

    emloop (g + h)
    [a]— — — >[c]
     ‖         ^
     ‖         | emloop h     ^
     ‖         |            j |
    [a]— — — >[b]          ∙ — >
       emloop g                i

    We use this to give another constructor-like construction:
  -}

  emloop-comp : (g h : Carrier) → emloop (g + h) ≡ emloop g ∙ emloop h
  emloop-comp g h i = compPath-unique refl (emloop g) (emloop h)
    (emloop (g + h) , emcomp g h)
    (emloop g ∙ emloop h , compPath-filler (emloop g) (emloop h)) i .fst


{-# OPTIONS --without-K --safe #-}

open import Level hiding (zero)

open import Relation.Binary

module SDG.Extra.OrderedAlgebra.Structures {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) where

open import Algebra.Structures
open import Algebra.FunctionProperties

record IsOrderedCommutativeRing
    (_<_ : Rel A ℓ)
    (_+_ _*_ : Op₂ A)
    (-_ : Op₁ A)
    (0# 1# : A) : Set (a ⊔ ℓ) where
  field
    isCommutativeRing : IsCommutativeRing _≈_ _+_ _*_ -_ 0# 1#
    <-isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_
    <-+ : ∀ (a b c) → a < b → (a + c) < (b + c)
    <-* : ∀ (a b) → 0# < a → 0# < b → 0# < (a * b)

  open IsCommutativeRing isCommutativeRing public
    --using (zero)
  open IsStrictTotalOrder <-isStrictTotalOrder public


{-# OPTIONS --without-K --safe #-}

module Categories.Category.Instance.Properties.Setoids.Complete where

open import Level
open import Data.Product using (Σ; proj₁; proj₂; _,_; Σ-syntax; _×_; -,_)
open import Function.Equality using (Π)
open import Relation.Binary using (Setoid; Rel)

open import Categories.Category using (Category; _[_,_])
open import Categories.Functor
open import Categories.Category.Instance.Setoids
open import Categories.Category.Complete

import Categories.Category.Construction.Cones as Co

open Π using (_⟨$⟩_)

Setoids-Complete : (o ℓ e c ℓ′ : Level) → Complete o ℓ e (Setoids (c ⊔ ℓ ⊔ o ⊔ ℓ′) (o ⊔ ℓ′))
Setoids-Complete o ℓ e c ℓ′ {J} F =
  record
  { terminal = record
    { ⊤        = record
      { N     = record
        { Carrier       = Σ (∀ j → F₀.Carrier j)
                            (λ S → ∀ {X Y} (f : J [ X , Y ]) → [ F₀ Y ] F₁ f ⟨$⟩ S X ≈ S Y)
        ; _≈_           = λ { (S₁ , _) (S₂ , _) → ∀ j → [ F₀ j ] S₁ j ≈ S₂ j }
        ; isEquivalence = record
          { refl  = λ j → F₀.refl j
          ; sym   = λ a≈b j → F₀.sym j (a≈b j)
          ; trans = λ a≈b b≈c j → F₀.trans j (a≈b j) (b≈c j)
          }
        }
      ;  apex = record
        { ψ = λ j → record
          { _⟨$⟩_ = λ { (S , _) → S j }
          ; cong  = λ eq → eq j
          }
        ; commute = λ { {X} {Y} X⇒Y {_ , eq} {y} f≈g → F₀.trans Y (eq X⇒Y) (f≈g Y) }
        }
      }
    ; ⊤-is-terminal = record
      { !        = λ {K} →
        let module K = Cone K
        in record
        { arr     = record
          { _⟨$⟩_ = λ x → (λ j → K.ψ j ⟨$⟩ x) , λ f → K.commute f (Setoid.refl K.N)
          ; cong  = λ a≈b j → Π.cong (K.ψ j) a≈b
          }
        ; commute = λ x≈y → Π.cong (K.ψ _) x≈y
        }
      ; !-unique = λ {K} f x≈y j →
        let module K = Cone K
        in F₀.sym j (Cone⇒.commute f (Setoid.sym K.N x≈y))
      }
    }
  }
  where open Functor F
        open Co F
        module J    = Category J
        module F₀ j = Setoid (F₀ j)
        [_]_≈_ = Setoid._≈_


{-# OPTIONS --safe #-}

module Cubical.Algebra.CommRing.Instances.UnivariatePoly where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Nat using (ℕ ; zero ; suc)

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Polynomials.Univariate.Base
open import Cubical.Algebra.Polynomials.Univariate.Properties

private
  variable
    ℓ : Level

UnivariatePoly : (CommRing ℓ) → CommRing ℓ
UnivariatePoly R = (PolyMod.Poly R) , str
    where
      open CommRingStr --(snd R)
      str : CommRingStr (PolyMod.Poly R)
      0r str = PolyModTheory.0P R
      1r str = PolyModTheory.1P R
      _+_ str = PolyModTheory._Poly+_ R
      _·_ str = PolyModTheory._Poly*_ R
      - str = PolyModTheory.Poly- R
      isCommRing str = makeIsCommRing (PolyMod.isSetPoly R)
                                      (PolyModTheory.Poly+Assoc R)
                                      (PolyModTheory.Poly+Rid R)
                                      (PolyModTheory.Poly+Inverses R)
                                      (PolyModTheory.Poly+Comm  R)
                                      (PolyModTheory.Poly*Associative R)
                                      (PolyModTheory.Poly*Rid R)
                                      (PolyModTheory.Poly*LDistrPoly+ R)
                                      (PolyModTheory.Poly*Commutative R)

nUnivariatePoly : (A' : CommRing ℓ) → (n : ℕ) → CommRing ℓ
nUnivariatePoly A' zero = A'
nUnivariatePoly A' (suc n) = UnivariatePoly (nUnivariatePoly A' n)


open import Coinduction using ( ♯_ ; ♭ )
open import Data.Strict using ( Strict ; ! )
open import Data.Natural using ( Natural ; # ; _+_ )
open import Data.Bool using ( Bool ; true ; false )
open import System.IO.Transducers.Session using ( I ; Σ ; ⟨_⟩ ; * ; _&*_ ; ¿ )
open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done )
open import System.IO.Transducers.Strict using ( _⇛_ )

module System.IO.Transducers.List where

-- Length of a list

length' : ∀ {T S} → (Strict Natural) → (T &* S) ⇛ ⟨ Natural ⟩
length' {I}     {S} (! n) true  = inp (♯ length' {S} {S} (! (n + # 1)))
length' {I}     {S} (! n) false = out n done
length' {Σ V G} {S} (! n) b     = inp (♯ length' {♭ G b} {S} (! n))

length : ∀ {S} → (* S) ⇛ ⟨ Natural ⟩
length {S} = length' {I} {S} (! (# 0))

-- Flatten a list of lists

mutual

  concat' : ∀ {T S} → ((T &* S) &* * S) ⇛ (T &* S)
  concat' {I}     {S} true  = out true (inp (♯ concat' {S} {S}))
  concat' {I}     {S} false = inp (♯ concat {S})
  concat' {Σ W G} {S} a     = out a (inp (♯ concat' {♭ G a} {S}))

  concat : ∀ {S} → (* (* S)) ⇛ (* S)
  concat {S} true  = inp (♯ concat' {I} {S})
  concat {S} false = out false done

-- Some inclusions, which coerce traces from one session to another.

-- TODO: Add more inclusions.
-- TODO: Prove that these are monomorphisms.
-- TODO: It would be nice if inclusions like this could be handled by subtyping.

S⊆S&*T : ∀ {S T} → S ⇒ S &* T
S⊆S&*T {I}     = out false done
S⊆S&*T {Σ V F} = inp (♯ λ a → out a S⊆S&*T)

S⊆*S : ∀ {S} → S ⇒ * S
S⊆*S = out true S⊆S&*T

¿S⊆*S : ∀ {S} → ¿ S ⇛ * S
¿S⊆*S {S} true  = out true (S⊆S&*T {S} {S})
¿S⊆*S {S} false = out false done


module Generic.Lib.Data.Pow where

open import Generic.Lib.Intro
open import Generic.Lib.Data.Nat
open import Generic.Lib.Data.Product

infixl 6 _^_

_^_ : ∀ {α} -> Set α -> ℕ -> Set α
A ^ 0     = ⊤
A ^ suc n = A × A ^ n

elimPow : ∀ {n α} {A : Set α} {b : ∀ {n} -> A ^ n -> Level}
        -> (B : ∀ {n} -> (xs : A ^ n) -> Set (b xs))
        -> (∀ {n} {xs : A ^ n} x -> B xs -> B (x , xs))
        -> B tt
        -> (xs : A ^ n)
        -> B xs
elimPow {0}     B f z  tt      = z
elimPow {suc n} B f z (x , xs) = f x (elimPow B f z xs)

foldPow : ∀ {n α β} {A : Set α}
        -> (B : ℕ -> Set β) -> (∀ {n} -> A -> B n -> B (suc n)) -> B 0 -> A ^ n -> B n
foldPow B f z xs = elimPow (λ {n} _ -> B n) (λ x y -> f x y) z xs

foldPow₁ : ∀ {n α} {A : Set α} -> (A -> A -> A) -> A ^ suc n -> A
foldPow₁ {0}     f (x , []) = x
foldPow₁ {suc n} f (x , xs) = f x (foldPow₁ f xs)

mapPow : ∀ {n α β} {A : Set α} {B : Set β} -> (A -> B) -> A ^ n -> B ^ n
mapPow f = foldPow (_ ^_) (_,_ ∘ f) tt

replicatePow : ∀ {α} {A : Set α} n -> A -> A ^ n
replicatePow  0      x = tt
replicatePow (suc n) x = x , replicatePow n x


{-# OPTIONS --cubical --no-import-sorts --safe #-}

{-

This file defines

deltaIntSec : ∀ b → toInt (fromInt b) ≡ b
succPred : ∀ n → succ (pred n) ≡ n
predSucc : ∀ n → pred (succ n) ≡ n

and proved DeltaInt ≡ DeltaInt by the above functions

succPredEq : DeltaInt ≡ DeltaInt

along with some interval-relevant lemmas

cancelDiamond  : ∀ a b i → cancel a b i ≡ cancel (suc a) (suc b) i
cancelTriangle : ∀ a b i → a ⊖ b ≡ cancel a b i

we also have DeltaInt ≡ Int proof

DeltaInt≡Int : DeltaInt ≡ Int

and we transported some proofs from Int to DeltaInt

discreteDeltaInt : Discrete DeltaInt
isSetDeltaInt : isSet DeltaInt

-}

module Cubical.HITs.Ints.DeltaInt.Properties where

open import Cubical.Foundations.Everything
open import Cubical.Data.Nat hiding (zero)
open import Cubical.Data.Int hiding (abs; sgn; _+_)
open import Cubical.HITs.Ints.DeltaInt.Base
open import Cubical.Relation.Nullary using (Discrete)

deltaIntSec : ∀ b → toInt (fromInt b) ≡ b
deltaIntSec (pos n) = refl
deltaIntSec (negsuc n) = refl

cancelDiamond : ∀ a b i → cancel a b i ≡ cancel (suc a) (suc b) i
cancelDiamond a b i j = hcomp (λ k → λ
  { (i = i0) → cancel a b j
  ; (i = i1) → cancel (suc a) (suc b) (j ∧ k)
  ; (j = i0) → cancel a b i
  ; (j = i1) → cancel (suc a) (suc b) (i ∧ k)
  }) (cancel a b (i ∨ j))

cancelTriangle : ∀ a b i → a ⊖ b ≡ cancel a b i
cancelTriangle a b i j = hcomp (λ k → λ
  { (i = i0) → a ⊖ b
  ; (j = i0) → a ⊖ b
  ; (j = i1) → cancel a b (i ∧ k)
  }) (a ⊖ b)

deltaIntRet : ∀ a → fromInt (toInt a) ≡ a
deltaIntRet (x ⊖ 0) = refl
deltaIntRet (0 ⊖ suc y) = refl
deltaIntRet (suc x ⊖ suc y) = deltaIntRet (x ⊖ y) ∙ cancel x y
deltaIntRet (cancel a 0 i) = cancelTriangle a 0 i
deltaIntRet (cancel 0 (suc b) i) = cancelTriangle 0 (suc b) i
deltaIntRet (cancel (suc a) (suc b) i) = deltaIntRet (cancel a b i) ∙ cancelDiamond a b i

DeltaInt≡Int : DeltaInt ≡ Int
DeltaInt≡Int = isoToPath (iso toInt fromInt deltaIntSec deltaIntRet)

discreteDeltaInt : Discrete DeltaInt
discreteDeltaInt = subst Discrete (sym DeltaInt≡Int) discreteInt

isSetDeltaInt : isSet DeltaInt
isSetDeltaInt = subst isSet (sym DeltaInt≡Int) isSetInt

succPred : ∀ n → succ (pred n) ≡ n
succPred (x ⊖ y) i = cancel x y (~ i)
-- cancel (suc a) (suc b) i ≡ cancel a b i
succPred (cancel a b i) = sym (cancelDiamond a b i)

predSucc : ∀ n → pred (succ n) ≡ n
predSucc (x ⊖ y) = succPred (x ⊖ y)
predSucc (cancel a b i) = succPred (cancel a b i)

succPredEq : DeltaInt ≡ DeltaInt
succPredEq = isoToPath (iso succ pred succPred predSucc)


module Basic where

open import Level
open import Data.Product
open import Relation.Binary
open Setoid renaming (_≈_ to eqSetoid)

module Map where
  record Map {c₀ c₀′ ℓ ℓ′ : Level} (A : Setoid c₀ ℓ) (B : Setoid c₀′ ℓ′) : Set (suc (c₀ ⊔ ℓ ⊔ c₀′ ⊔ ℓ′)) where
    field
      mapping : Carrier A → Carrier B
      preserveEq : {x y : Carrier A} → (eqSetoid A x y) → eqSetoid B (mapping x) (mapping y)

  open Map public

  equality : {c₀ ℓ : Level} {A B : Setoid c₀ ℓ} (f g : Map A B) → Set _
  equality {A = A} {B = B} f g = ∀(x : Carrier A) → eqSetoid B (mapping f x) (mapping g x)

  compose : {c₀ ℓ : Level} {A B C : Setoid c₀ ℓ} (f : Map B C) (g : Map A B) → Map A C
  compose {C = C} f g = record {
    mapping = λ x → mapping f (mapping g x);
    preserveEq = λ x₁ → (preserveEq f (preserveEq g x₁)) }

  identity : {c₀ ℓ : Level} {A : Setoid c₀ ℓ} → Map A A
  identity = record { mapping = λ x → x ; preserveEq = λ x₁ → x₁ }

  subst : ∀{c₀ ℓ} {A B : Setoid c₀ ℓ} {f g : Map A B} (a : Carrier A) → equality f g → eqSetoid B (mapping f a) (mapping g a)
  subst a eq = eq a

LiftSetoid : ∀ {a b ℓ ℓ′} (A : Setoid a ℓ) → Setoid (a ⊔ b) (ℓ ⊔ ℓ′)
LiftSetoid {a} {b} {ℓ} {ℓ′} A = record {
  Carrier = Lift {a} {b} (Carrier A) ;
  _≈_ = λ x x₁ → Lift {ℓ} {ℓ′} (eqSetoid A (lower x) (lower x₁)) ;
  isEquivalence = record {
    refl = lift (refl A) ;
    sym = λ x → lift (sym A (lower x)) ;
    trans = λ x x₁ → lift (trans A (lower x) (lower x₁)) } }

liftMap : {c₀ c₀′ d ℓ ℓ′ ℓ″ : Level} {A : Setoid c₀ ℓ} {B : Setoid c₀′ ℓ′} → (f : Map.Map A B) → Map.Map (LiftSetoid {_} {c₀ ⊔ d} {_} {ℓ ⊔ ℓ″} A) (LiftSetoid {_} {c₀′ ⊔ d} {_} {ℓ′ ⊔ ℓ″} B)
liftMap f = record {
  mapping = λ x → lift (Map.mapping f (lower x)) ;
  preserveEq = λ x≈y → lift (Map.preserveEq f (lower x≈y)) }

lowerMap : {c₀ c₀′ d ℓ ℓ′ ℓ″ : Level} {A : Setoid c₀ ℓ} {B : Setoid c₀′ ℓ′} → (f : Map.Map (LiftSetoid {_} {c₀ ⊔ d} {_} {ℓ ⊔ ℓ″} A) (LiftSetoid {_} {c₀′ ⊔ d} {_} {ℓ′ ⊔ ℓ″} B)) → Map.Map A B
lowerMap f = record {
  mapping = λ x → lower (Map.mapping f (lift x)) ;
  preserveEq = λ x≈y → lower (Map.preserveEq f (lift x≈y)) }


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.RingSolver.CommRingExamples where

open import Cubical.Foundations.Prelude

open import Cubical.Data.FinData
open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Vec.Base

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.RingSolver.NatAsAlmostRing
open import Cubical.Algebra.RingSolver.RawAlgebra renaming (⟨_⟩ to ⟨_⟩ᵣ)
open import Cubical.Algebra.RingSolver.CommRingSolver

-- In scope for debugging:
open import Cubical.Algebra.RingSolver.CommRingHornerForms

private
  variable
    ℓ : Level

module MultivariateSolving (R : CommRing {ℓ}) where
  -- In scope for debuggin:

  -- In scope for solver use:
  open CommRingStr (snd R)
  AsAlgebra = CommRing→RawℤAlgebra R

  X : ℤExpr R 3
  X = ∣ Fin.zero

  Y : ℤExpr R 3
  Y = ∣ (suc Fin.zero)

  Z : ℤExpr R 3
  Z = ∣ (suc (suc Fin.zero))

  _ : (x y z : (fst R)) → x · y · z ≡ z · y · x
  _ = λ x y z →
              let
                lhs = X ·' Y ·' Z
                rhs = Z ·' Y ·' X
              in solve R lhs rhs (x ∷ y ∷ z ∷ []) refl

  _ : (x y z : (fst R)) → x · (y + z) ≡ z · x + y · x
  _ = λ x y z →
              let
                lhs = X ·' (Y +' Z)
                rhs = Z ·' X +' Y ·' X
              in solve R lhs rhs (x ∷ y ∷ z ∷ []) refl

  _ : (x y z : (fst R)) → x · (y - z) ≡ (- z) · x + y · x
  _ = λ x y z →
              let
                lhs = X ·' (Y +' (-' Z))
                rhs = (-' Z) ·' X +' (Y ·' X)
              in solve R lhs rhs (x ∷ y ∷ z ∷ []) refl

  {-
    A bigger example, copied from 'Example.agda'
  -}
  _ : (x y z : (fst R)) → (x + y) · (x + y) · (x + y) · (x + y)
                ≡ x · x · x · x + (scalar R 4) · x · x · x · y + (scalar R 6) · x · x · y · y
                  +  (scalar R 4) · x · y · y · y + y · y · y · y
  _ = λ x y z → let
              lhs = (X +' Y) ·' (X +' Y) ·' (X +' Y) ·' (X +' Y)
              rhs = X ·' X ·' X ·' X
                  +' (K 4) ·' X ·' X ·' X ·' Y
                  +' (K 6) ·' X ·' X ·' Y ·' Y
                  +' (K 4) ·' X ·' Y ·' Y ·' Y
                  +' Y ·' Y ·' Y ·' Y
             in solve R lhs rhs (x ∷ y ∷ z ∷ []) refl

  _ : (x y z : (fst R)) → (x + y) · (x - y) ≡ (x · x - y · y)
  _ = λ x y z →
              let
                lhs = (X +' Y) ·' (X +' (-' Y))
                rhs = (X ·' X) +' (-' (Y ·' Y))
              in solve R lhs rhs (x ∷ y ∷ z ∷ []) refl


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Discrete where

open import Level
open import Data.Unit
open import Function
open import Relation.Binary.PropositionalEquality as ≡

open import Categories.Category
open import Categories.Functor

Discrete : ∀ {a} (A : Set a) → Category a a a
Discrete A = record
  { Obj       = A
  ; _⇒_       = _≡_
  ; _≈_       = _≡_
  ; id        = refl
  ; _∘_       = flip ≡.trans
  ; assoc     = λ {_ _ _ _ g} → sym (trans-assoc g)
  ; sym-assoc = λ {_ _ _ _ g} → trans-assoc g
  ; identityˡ = λ {_ _ f} → trans-reflʳ f
  ; identityʳ = refl
  ; identity² = refl
  ; equiv     = isEquivalence
  ; ∘-resp-≈  = λ where
    refl refl → refl
  }

module _ {a o ℓ e} {A : Set a} (C : Category o ℓ e) where
  open Category C renaming (id to one)

  module _ (f : A → Obj) where

    lift-func : Functor (Discrete A) C
    lift-func = record
      { F₀           = f
      ; F₁           = λ { refl → one }
      ; identity     = Equiv.refl
      ; homomorphism = λ { {_} {_} {_} {refl} {refl} → Equiv.sym identity² }
      ; F-resp-≈     = λ { {_} {_} {refl} refl → Equiv.refl }
      }


{-# OPTIONS --cubical-compatible #-}

module NewWithoutK where

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

infixl 20 _+_
_+_ : ℕ → ℕ → ℕ
zero + n = n
(suc m) + n = suc (m + n)

infixl 30 _*_
_*_ : ℕ → ℕ → ℕ
zero * n = zero
(suc m) * n = n + (m * n)

infixl 5 _⊎_
data _⊎_ (A B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

infixl 10 _≡_
data _≡_ {A : Set} (a : A) : A → Set where
  refl : a ≡ a

data _≤_ : ℕ → ℕ → Set where
  z≤n : {n : ℕ} → zero ≤ n
  s≤s : {m n : ℕ} → m ≤ n → suc m ≤ suc n

foo : (k l m : ℕ) → k ≡ l + m → ℕ
foo .(l + m) l m refl = zero

bar : (n : ℕ) → n ≤ n → ℕ
bar .zero z≤n = zero
bar .(suc m) (s≤s {m} p) = zero

baz : ∀ m n → m * n ≡ zero → m ≡ zero ⊎ n ≡ zero
baz zero     n      h = inj₁ refl
baz (suc m) zero    h = inj₂ refl
baz (suc x) (suc x₁) ()


module PigeonHole where

open import Prelude
open import Data.Nat hiding (_==_; _<_)
open import Data.Fin
open import Data.Vec as Vec
open import Logic.Base
open import Logic.Identity

open Vec.Elem

tooManyPigeons : {n : Nat}(xs : Vec (Fin (suc n)) n) -> ∃ \p -> p ∉ xs
tooManyPigeons {zero}  [] = ∃-I fzero nl
tooManyPigeons {suc n} zs = aux zs (find _==_ fzero zs)
  where

    -- We start by checking whether or not fzero is an element of the list
    aux : {n : Nat}(xs : Vec (Fin (suc (suc n))) (suc n)) ->
	  fzero ∈ xs \/ fzero ∉ xs -> ∃ \p -> p ∉ xs

    -- If it's not then we're done
    aux xs (\/-IR z∉xs) = ∃-I fzero z∉xs

    -- If it is we have to find another element
    aux xs (\/-IL z∈xs) = lem₂ ih
      where

	-- Let's remove the occurrence of fzero from the list and strip a fsuc
	-- from each of the other elements (i.e. map pred $ delete fzero xs)
	-- We can apply the induction hypothesis, giving us a p which is not in
	-- this list.
	ih : ∃ \p -> p ∉ map pred (delete fzero xs z∈xs)
	ih = tooManyPigeons (map pred $ delete _ xs z∈xs)

	-- First observe that if i ∉ map pred xs then fsuc i ∉ xs. Using this
	-- lemma we conclude that fsuc p ∉ delete fzero xs.
	lem₀ : {n m : Nat}(i : Fin (suc n))(xs : Vec (Fin (suc (suc n))) m) ->
	      i ∉ map pred xs -> fsuc i ∉ xs
	lem₀ i []	 nl	  = nl
	lem₀ i (x :: xs) (cns h t) = cns (rem₀ h) (lem₀ i xs t)
	  where
	    rem₀ : {n : Nat}{i : Fin (suc n)}{j : Fin (suc (suc n))} ->
		   i ≢ pred j -> fsuc i ≢ j
	    rem₀ i≠i refl = i≠i refl

	-- Furthermore, if i ∉ delete j xs and i ≠ j then i ∉ xs.
	lem₁ : {n m : Nat}{i : Fin (suc n)}{j : Fin n}
	       (xs : Vec (Fin (suc n)) (suc m))(p : i ∈ xs) ->
	       thin i j ∉ delete i xs p -> thin i j ∉ xs
	lem₁ (x :: xs)  hd    el = cns (thin-ij≠i _ _) el
	lem₁ {m = zero } (x :: xs) (tl ()) _
	lem₁ {m = suc _} (x :: xs) (tl p) (cns h t) = cns h (lem₁ xs p t)

	-- So we get fsuc p ∉ xs and we're done.
	lem₂ : (∃ \p -> p ∉ map pred (delete fzero xs z∈xs)) ->
	       (∃ \p -> p ∉ xs)
	lem₂ (∃-I p h) = ∃-I (fsuc p) (lem₁ xs z∈xs $ lem₀ _ _ h)

-- tooManyHoles : {n : Nat}(xs : Vec (Fin n) (suc n)) ->
-- 	       ∃ \p -> ∃ \i -> ∃ \j -> xs ! i ≡ p /\ xs ! thin i j ≡ p
-- tooManyHoles = ?


{-# OPTIONS --without-K --safe #-}
module Util.Vec where

open import Data.Vec public
open import Data.Vec.Relation.Unary.All as All public using (All ; [] ; _∷_)
open import Data.Vec.Relation.Unary.Any as Any public using (Any ; here ; there)
open import Data.Vec.Membership.Propositional public using (_∈_)

open import Data.Nat as ℕ using (_≤_)
open import Level using (_⊔_)
open import Relation.Binary using (Rel)

open import Util.Prelude

import Data.Nat.Properties as ℕ

max : ∀ {n} → Vec ℕ n → ℕ
max = foldr _ ℕ._⊔_ 0

max-weaken : ∀ {n} x (xs : Vec ℕ n) → max xs ≤ max (x ∷ xs)
max-weaken _ _ = ℕ.n≤m⊔n _ _

max-maximal : ∀ {n} (xs : Vec ℕ n) → All (_≤ max xs) xs
max-maximal [] = []
max-maximal (x ∷ xs)
  = ℕ.m≤m⊔n _ _
  ∷ All.map (λ x≤max → ℕ.≤-trans x≤max (max-weaken x xs)) (max-maximal xs)

All→∈→P : ∀ {α β} {A : Set α} {P : A → Set β} {n} {xs : Vec A n}
  → All P xs
  → ∀ {x}
  → x ∈ xs
  → P x
All→∈→P (px ∷ allP) (here refl) = px
All→∈→P (px ∷ allP) (there x∈xs) = All→∈→P allP x∈xs

max-maximal-∈ : ∀ {n x} {xs : Vec ℕ n} → x ∈ xs → x ≤ max xs
max-maximal-∈ = All→∈→P (max-maximal _)

data All₂ {α} {A : Set α} {ρ} (R : Rel A ρ)
  : ∀ {n} → Vec A n → Vec A n → Set (α ⊔ ρ) where
  [] : All₂ R [] []
  _∷_ : ∀ {n x y} {xs ys : Vec A n}
    → R x y
    → All₂ R xs ys
    → All₂ R (x ∷ xs) (y ∷ ys)

All₂-tabulate⁺ : ∀ {α} {A : Set α} {ρ} {R : Rel A ρ} {n} {f g : Fin n → A}
  → (∀ x → R (f x) (g x))
  → All₂ R (tabulate f) (tabulate g)
All₂-tabulate⁺ {n = zero} p = []
All₂-tabulate⁺ {n = suc n} p = p zero ∷ All₂-tabulate⁺ (λ x → p (suc x))

All₂-tabulate⁻ : ∀ {α} {A : Set α} {ρ} {R : Rel A ρ} {n} {f g : Fin n → A}
  → All₂ R (tabulate f) (tabulate g)
  → ∀ x → R (f x) (g x)
All₂-tabulate⁻ [] ()
All₂-tabulate⁻ (fzRgz ∷ all) zero = fzRgz
All₂-tabulate⁻ (fzRgz ∷ all) (suc x) = All₂-tabulate⁻ all x


module A1 where

open import Data.Empty using (⊥)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst)
open import Data.Unit using (⊤; tt)
open import Data.Bool using (Bool; false; true; _xor_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; Σ; Σ-syntax)
open import Data.Nat using (ℕ; suc; _+_; _*_)
open import Data.List using (List; []; _++_)
open import Data.Vec using (Vec; []; _∷_) renaming (_++_ to _++V_)

------------------------------------------------------------------------------
-- Ch. 1
-- Theme: for each type, recursion principle and induction principle

------------------------------------------------------------------------------
-- Sec. 1.9
-- ℕ

recℕ : ∀ {ℓ} → (C : Set ℓ) → C → (ℕ → C → C) → ℕ → C
recℕ C z f 0 = z
recℕ C z f (suc n) = f n (recℕ C z f n)

indℕ : ∀ {ℓ} → (C : ℕ → Set ℓ) → C 0 → ((n : ℕ) → C n → C (suc n)) → (n : ℕ) → C n
indℕ C z f 0 = z
indℕ C z f (suc n) = f n (indℕ C z f n)

-- Many examples in L.agda

------------------------------------------------------------------------------
-- Sec. 1.7
-- Empty type

-- Ex falso quodlibet

rec⊥ : ∀ {ℓ} → (C : Set ℓ) → ⊥ → C
rec⊥ C ()

ind⊥ : ∀ {ℓ} → (C : ⊥ → Set ℓ) → (v : ⊥) → C v
ind⊥ C ()

-- Examples

⊥→1≡2 : ⊥ → (1 ≡ 2)
⊥→1≡2 = rec⊥ (1 ≡ 2)

⊥→⊤≡⊥ : ⊥ → ⊤
⊥→⊤≡⊥ = rec⊥ ⊤

⊥→⊤≡⊥' : ⊥ → ⊤
⊥→⊤≡⊥' = ind⊥ (λ v → ⊤)

------------------------------------------------------------------------------
-- Sec. 1.5
-- Unit type

rec⊤ : ∀ {ℓ} → (C : Set ℓ) → C → ⊤ → C
rec⊤ C c tt = c

ind⊤ : ∀ {ℓ} → (C : ⊤ → Set ℓ) → C tt → (u : ⊤) → C u
ind⊤ C c tt = c

-- Example

singleton⊤ : (u : ⊤) → (u ≡ tt)
singleton⊤ = ind⊤ (λ u → u ≡ tt) refl

------------------------------------------------------------------------------
-- Sec. 1.8
-- Booleans

recBool : ∀ {ℓ} → (C : Set ℓ) → C → C → Bool → C
recBool C el th false = el
recBool C el th true = th

indBool : ∀ {ℓ} → (C : Bool → Set ℓ) → C false → C true → (b : Bool) → C b
indBool C el th false = el
indBool C el th true = th

-- Example

bool2 : (b : Bool) → (b ≡ false) ⊎ (b ≡ true)
bool2 = indBool
          (λ b → (b ≡ false) ⊎ (b ≡ true))
          (inj₁ refl)
          (inj₂ refl)

------------------------------------------------------------------------------
-- Sec. 1.5
-- Product types

rec× : ∀ {ℓ₁ ℓ₂ ℓ₃} → {A : Set ℓ₁} {B : Set ℓ₂} →
      (C : Set ℓ₃) → (A → B → C) → A × B → C
rec× C g (a , b) = g a b

ind× : ∀ {ℓ₁ ℓ₂ ℓ₃} → {A : Set ℓ₁} {B : Set ℓ₂} → (C : A × B → Set ℓ₃) →
       ((a : A) → (b : B) → C (a , b)) → (p : A × B) → C p
ind× C g ( a , b ) = g a b

-- Examples

fst : {A B : Set} → A × B → A
fst {A} {B} = rec× A (λ a b → a)

snd : {A B : Set} → A × B → B
snd {A} {B} = rec× B (λ a b → b)

surj-pair : ∀ {A B} → (p : A × B) → (fst p , snd p) ≡ p
surj-pair = ind×
              (λ p → (fst p , snd p) ≡ p)
              (λ a b → refl)

-- IMPORTANT:
--
-- TO PROVE ANY PROPERTY OF SOMETHING OF TYPE A × B, IT IS SUFFICIENT
-- TO PROVE IT FOR CANONICAL VALUES OF THAT TYPE, i.e. FOR (a , b)
--

_Product_ : (A : Set) → (B : Set) → Set
A Product B = (z : Bool) → recBool Set A B z

pair : {A B : Set} → A → B → A Product B
pair {A} {B} a b = indBool (λ z → recBool Set A B z) a b

------------------------------------------------------------------------------
-- Sigma types (dependent pair type)

recΣ : ∀ {ℓ₁ ℓ₂ ℓ₃} → {A : Set ℓ₁} {B : A → Set ℓ₂} → (C : Set ℓ₃) →
       ((a : A) → B a → C) → Σ A B → C
recΣ C g (a , b) = g a b

indΣ : ∀ {ℓ₁ ℓ₂ ℓ₃} → {A : Set ℓ₁} {B : A → Set ℓ₂} → (C : Σ A B → Set ℓ₃) →
        ((a : A) → (b : B a) → C (a , b)) → (p : Σ A B) → C p
indΣ C g ( a , b ) = g a b

-- Examples

dfst : {A : Set} {B : A → Set} → Σ A B → A
dfst {A} {B} = recΣ A (λ a b → a)

dsnd : {A : Set} {B : A → Set} → (p : Σ A B) → B (dfst p)
dsnd {A} {B} = indΣ
                 (λ p → B (dfst p))
                 (λ a b → b)

ac : {A B : Set} {R : A → B → Set} →
     ((x : A) → (Σ[ y ∈ B ] (R x y))) →
     (Σ[ f ∈ (A → B) ] ((x : A) → R x (f x)))
ac g = (λ x → dfst (g x)) , (λ x → dsnd (g x))

{-- In English :-)

If for all x, exists y, such that x R y, then
exists f such that for all x, x R f(x)

... this is one type-theoretic "axiom of choice"

--}

Magma : Set₁
Magma = Σ[ A ∈ Set ] (A → A → A)

m₁ m₂ m₃ m₄ m₅ : Magma
m₁ = (ℕ , _+_)
m₂ = (ℕ , _*_)
m₃ = (Bool , _xor_)
m₄ = (List Bool , _++_)
m₅ = (⊥ , λ ())

PointedMagma : Set₁
PointedMagma = Σ[ A ∈ Set ] ((A → A → A) × A)

pm₁ pm₂ pm₃ pm₄ : PointedMagma
pm₁ = (ℕ , _+_ , 0)
pm₂ = (ℕ , _*_ , 1)
pm₃ = (Bool , _xor_ , false)
pm₄ = (List Bool , _++_ , [])

------------------------------------------------------------------------------
-- Sum types (coproducts)

rec⊎ : ∀ {ℓ₁ ℓ₂ ℓ₃} → {A : Set ℓ₁} {B : Set ℓ₂} →
       (C : Set ℓ₃) → (A → C) → (B → C) → (A ⊎ B → C)
rec⊎ C f g (inj₁ a) = f a
rec⊎ C f g (inj₂ b) = g b

ind⊎ : ∀ {ℓ₁ ℓ₂ ℓ₃} → {A : Set ℓ₁} {B : Set ℓ₂} → (C : A ⊎ B → Set ℓ₃) →
        ((a : A) → C (inj₁ a)) → ((b : B) → C (inj₂ b)) → ((x : A ⊎ B) → C x)
ind⊎ C f g (inj₁ a) = f a
ind⊎ C f g (inj₂ b) = g b

-- Examples

_Union_ : (A : Set) → (B : Set) → Set
A Union B = Σ[ b ∈ Bool ] (recBool Set A B b)

inLeft : {A B : Set} → A → A Union B
inLeft a = (false , a)

inRight : {A B : Set} → B → A Union B
inRight b = (true , b)

------------------------------------------------------------------------------
-- Induction principle for vectors

indVec : {A : Set} → (C : {n : ℕ} → Vec A n → Set) →
         C [] →
         ({m : ℕ} → (x : A) → (xs : Vec A m) → C xs → C (x ∷ xs)) →
         ({n : ℕ} → (xs : Vec A n) → C xs)
indVec C cnil ccons [] = cnil
indVec C cnil ccons (x ∷ xs) = ccons x xs (indVec C cnil ccons xs)

-- Example

[]++v≡v : ∀ {A n} → (v : Vec A n) → [] ++V v ≡ v
[]++v≡v {A} {n} = indVec
                    (λ v → [] ++V v ≡ v)
                    refl
                    (λ x xs p → refl)
postulate
  n+0≡n : ∀ {n} → n + 0 ≡ n

v++[]≡v : ∀ {n} {A : Set} → (v : Vec A n) →
        (subst (λ n -> Vec A n) n+0≡n (v ++V [])) ≡ v
v++[]≡v {A} {n} = {!!}

------------------------------------------------------------------------------
-- Obvious omission from list of types

-- No induction principle for functions

------------------------------------------------------------------------------
-- Propositions as types

¬ : Set → Set
¬ A = A → ⊥

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


------------------------------------------------------------------------------
-- Testing the function FOL.Translation.Terms.termToFOLTerm: Con term
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module TermToFOLTerm.ConTerm where

-- We add 3 to the fixities of the standard library.
infixl 9 _+_
infix  7 _≡_

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

data ℕ : Set where
  zero :     ℕ
  succ : ℕ → ℕ

data _≡_ (m : ℕ) : ℕ → Set where
  refl : m ≡ m

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

_+_ : ℕ → ℕ → ℕ
zero   + n = n
succ m + n = succ (m + n)

+-Sx : ∀ m n → succ m + n ≡ succ (m + n)
+-Sx m n = refl
{-# ATP hint +-Sx #-}

postulate
  +-rightIdentity : ∀ n → n + zero ≡ n
  x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero     n = sym (+-rightIdentity n)
+-comm (succ m) n = prf (+-comm m n)
  where
  postulate prf : m + n ≡ n + m →
                  succ m + n ≡ n + succ m
  {-# ATP prove prf x+Sy≡S[x+y] #-}


module BTree.Complete.Base {A : Set} where

open import BTree {A}
open import BTree.Equality {A}

data Perfect : BTree → Set where
  plf : Perfect leaf
  p≃ : {l r : BTree}
                   (x : A)
                   → l ≃ r
                   → Perfect (node x l r)

data _⋗_ : BTree → BTree → Set where
  ⋗lf : (x : A)
                   → node x leaf leaf ⋗ leaf
  ⋗nd : {l r' : BTree}
                   (x x' : A)
                   → (r l' : BTree)
                   → l ⋗ r'
                   → node x l r ⋗ node x' l' r'

data NearlyPerfect : BTree → Set where
  npr : {r : BTree}
                   (x : A)
                   (l : BTree)
                   → NearlyPerfect r
                   → NearlyPerfect (node x l r)
  np⋗ : {l r : BTree}
                   (x : A)
                   → l ⋗ r
                   → NearlyPerfect (node x l r)

data _⋘_ : BTree → BTree → Set where
  eq⋘ : {l r : BTree}
                   → l ≃ r
                   → l ⋘ r
  gt⋘ : {l r : BTree}
                   → NearlyPerfect l
                   → Perfect r
                   → l ⋗ r
                   → l ⋘ r

data _⋙_ : BTree → BTree → Set where
  ⋙gt : {l r : BTree}
                   → l ⋗ r
                   → l ⋙ r

data Complete : BTree → Set where
  leaf : Complete leaf
  left : {l r : BTree}
                   (x : A)
                   → Complete l
                   → Complete r
                   → l ⋘ r
                   → Complete (node x l r)
  right : {l r : BTree}
                   (x : A)
                   → Complete l
                   → Complete r
                   → l ⋙ r
                   → Complete (node x l r)


module Prelude where

infix 20 _≡_ _≤_ _∈_
infixl 60 _,_ _++_ _+_ _◄_ _◄²_

_∘_ : {A B : Set}{C : B -> Set}(f : (x : B) -> C x)(g : A -> B)(x : A) -> C (g x)
(f ∘ g) x = f (g x)

data _≡_ {A : Set}(x : A) : {B : Set} -> B -> Set where
  refl : x ≡ x

cong : {A : Set}{B : A -> Set}(f : (z : A) -> B z){x y : A} ->
       x ≡ y -> f x ≡ f y
cong f refl = refl

subst : {A : Set}(P : A -> Set){x y : A} -> x ≡ y -> P y -> P x
subst P refl px = px

sym : {A : Set}{x y : A} -> x ≡ y -> y ≡ x
sym refl = refl

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

{-# BUILTIN NATURAL Nat  #-}
{-# BUILTIN SUC     suc  #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN NATPLUS _+_  #-}

data _≤_ : Nat -> Nat -> Set where
  leqZ : {m : Nat}   -> zero ≤ m
  leqS : {n m : Nat} -> n ≤ m -> suc n ≤ suc m

refl-≤ : {n : Nat} -> n ≤ n
refl-≤ {zero } = leqZ
refl-≤ {suc n} = leqS refl-≤

refl-≤' : {n m : Nat} -> n ≡ m -> n ≤ m
refl-≤' refl = refl-≤

trans-≤ : {x y z : Nat} -> x ≤ y -> y ≤ z -> x ≤ z
trans-≤ leqZ      yz        = leqZ
trans-≤ (leqS xy) (leqS yz) = leqS (trans-≤ xy yz)

lem-≤suc : {x : Nat} -> x ≤ suc x
lem-≤suc {zero } = leqZ
lem-≤suc {suc x} = leqS lem-≤suc

lem-≤+L : (x : Nat){y : Nat} -> y ≤ x + y
lem-≤+L zero    = refl-≤
lem-≤+L (suc x) = trans-≤ (lem-≤+L x) lem-≤suc

lem-≤+R : {x y : Nat} -> x ≤ x + y
lem-≤+R {zero } = leqZ
lem-≤+R {suc x} = leqS lem-≤+R

data List (A : Set) : Set where
  ε   : List A
  _,_ : List A -> A -> List A

_++_ : {A : Set} -> List A -> List A -> List A
xs ++ ε        = xs
xs ++ (ys , y) = (xs ++ ys) , y

data All {A : Set}(P : A -> Set) : List A -> Set where
  ∅   : All P ε
  _◄_ : forall {xs x} -> All P xs -> P x -> All P (xs , x)

{-
data Some {A : Set}(P : A -> Set) : List A -> Set where
  hd : forall {x xs} -> P x -> Some P (xs , x)
  tl : forall {x xs} -> Some P xs -> Some P (xs , x)
-}

data _∈_ {A : Set}(x : A) : List A -> Set where
  hd : forall {xs} -> x ∈ xs , x
  tl : forall {y xs} -> x ∈ xs -> x ∈ xs , y

_!_ : {A : Set}{P : A -> Set}{xs : List A} ->
      All P xs -> {x : A} -> x ∈ xs -> P x
∅        ! ()
(xs ◄ x) ! hd   = x
(xs ◄ x) ! tl i = xs ! i

tabulate : {A : Set}{P : A -> Set}{xs : List A} ->
           ({x : A} -> x ∈ xs -> P x) -> All P xs
tabulate {xs = ε}      f = ∅
tabulate {xs = xs , x} f = tabulate (f ∘ tl) ◄ f hd

data All² {I : Set}{A : I -> Set}(P : {i : I} -> A i -> Set) :
          {is : List I} -> All A is -> Set where
  ∅²   : All² P ∅
  _◄²_ : forall {i is}{x : A i}{xs : All A is} ->
         All² P xs -> P x -> All² P (xs ◄ x)

data _∈²_ {I : Set}{A : I -> Set}{i : I}(x : A i) :
          {is : List I} -> All A is -> Set where
  hd² : forall {is}{xs : All A is} -> x ∈² xs ◄ x
  tl² : forall {j is}{y : A j}{xs : All A is} ->
        x ∈² xs -> x ∈² xs ◄ y


open import Relation.Binary.PropositionalEquality
open import Data.Unit using (⊤ ; tt)
open import Data.Product renaming (_×_ to _∧_ ; proj₁ to fst ; proj₂ to snd)
open import Data.Sum renaming (_⊎_ to _∨_ ; inj₁ to left ; inj₂ to right)
open import Data.Nat using (ℕ ; zero ; suc)
open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
open import Data.List hiding (length ; head)

{- --- 1. Order on natural numbers --- -}
data _≤_ : ℕ → ℕ → Set where
  z≤n : {n : ℕ}                 → zero  ≤ n
  s≤s : {m n : ℕ} (m≤n : m ≤ n) → suc m ≤ suc n

{- 1.1 Compatibility with successor -}
≤-pred : {m n : ℕ} → (suc m ≤ suc n) → m ≤ n
≤-pred (s≤s i) = i

≤-suc : {m n : ℕ} → (m ≤ n) → suc m ≤ suc n
≤-suc i = s≤s i

{- 1.2 Reflexivity -}
≤-refl : (n : ℕ) → n ≤ n
≤-refl zero = z≤n
≤-refl (suc n) = s≤s (≤-refl n)

{- 1.3 Transitivity -}
≤-trans : {m n p : ℕ} → (m ≤ n) → (n ≤ p) → (m ≤ p)
≤-trans z≤n i2 = z≤n
≤-trans (s≤s i1) (s≤s i2) = ≤-suc (≤-trans i1 i2)

{- 1.4 Totality -}
_≤?_ : (m n : ℕ) → (m ≤ n) ∨ (n ≤ m)
zero ≤? n = left z≤n
suc m ≤? zero = right z≤n
suc m ≤? suc n with m ≤? n
... | left e = left (≤-suc e)
... | right e = right (≤-suc e)

{- --- 2. Insertion sort --- -}

{- 2.1 Insertion -}
insert : (x : ℕ) → (l : List ℕ) → List ℕ
insert x [] = x ∷ []
insert x (x₁ ∷ l) with x ≤? x₁
... | left e = x ∷ (x₁ ∷ l)
... | right e = x₁ ∷ (insert x l)

{- 2.2 Sorting -}
sort : List ℕ → List ℕ
sort [] = []
sort (x ∷ l) = insert x (sort l)

test : List ℕ
test = sort (4 ∷ 1 ∷ 45 ∷ 8 ∷ 32 ∷ 12 ∷ 1 ∷ [])

{- 2.3 The bounded below predicate -}
data _≤*_ : ℕ → List ℕ → Set where
  [] : {x : ℕ} → x ≤* []
  _∷_ : {x y : ℕ} → {l : List ℕ} → (x ≤ y) → (x ≤* l) → (x ≤* (y ∷ l))

{- 2.4 The sorted predicate -}
data sorted : (l : List ℕ) → Set where
  [] : sorted []
  _∷_ : {x : ℕ} → {l : List ℕ} → (x ≤* l) → sorted l → (sorted (x ∷ l))

{- 2.5 Insert is sorting -}

≤*-trans : {x y : ℕ} → (l : List ℕ) → x ≤ y → y ≤* l → x ≤* l
≤*-trans [] x≤y y≤*l = []
≤*-trans (x₁ ∷ l) x≤y (y≤x₁ ∷ y≤*l) = ≤-trans x≤y y≤x₁ ∷ ≤*-trans l x≤y y≤*l

sorted-lemma : {x y : ℕ} → (l : List ℕ) → x ≤ y → sorted (y ∷ l) → x ≤* (y ∷ l)
sorted-lemma l x≤y (y≤*l ∷ s) = x≤y ∷ (≤*-trans l x≤y y≤*l)

insert-lemma : (x y : ℕ) → (l : List ℕ) → y ≤ x → y ≤* l → y ≤* insert x l
insert-lemma x y [] y≤x y≤*l = y≤x ∷ []
insert-lemma x y (x₁ ∷ l) y≤x (y≤x₁ ∷ y≤*l) with x ≤? x₁
... | right x₁≤x = y≤x₁ ∷ insert-lemma x y l y≤x y≤*l
... | left x≤x₁ = y≤x ∷ (y≤x₁ ∷ y≤*l)

insert-sorting : (x : ℕ) → (l : List ℕ) → sorted l → sorted (insert x l)
insert-sorting x [] s = [] ∷ []
insert-sorting x (y ∷ l) (y≤*l ∷ s) with x ≤? y
... | left x≤y = (x≤y ∷ (≤*-trans l x≤y y≤*l)) ∷ (y≤*l ∷ s)
... | right y≤x = insert-lemma x y l y≤x y≤*l ∷ (insert-sorting x l s)

{- 2.6 Sort is sorting -}
sort-sorting : (l : List ℕ) → sorted (sort l)
sort-sorting [] = []
sort-sorting (x ∷ l) = insert-sorting x (sort l) (sort-sorting l)

{- 2.7 The problem of specification -}

{- Empty lists are always sorted, so always return an empty list -}
f : List ℕ → List ℕ
f l = []

f-sorting : (l : List ℕ) → sorted (f l)
f-sorting _ = []

{- 2.8 Intrinsic approach -}
mutual
  data Sorted : Set where
    nil : Sorted
    cons : (x : ℕ) → (l : Sorted) → x ≤ (head x l) → Sorted

  head : ℕ → Sorted → ℕ
  head d nil = d
  head d (cons x l x₁) = x

mutual
  insert' : (x : ℕ) → Sorted → Sorted
  insert' x nil = nil
  insert' x (cons x₁ l x₁≤hd) with x ≤? x₁
  ... | left x≤x₁ = cons x (cons x₁ l x₁≤hd) x≤x₁
  ... | right x₁≤x = cons x₁ (insert' x l) (ins-lemma x x₁ l x₁≤x x₁≤hd)

  {- In other words, y ≤ x and y ≤* l gives us y ≤* (insert x l) -}
  ins-lemma : (x y : ℕ) → (l : Sorted) → y ≤ x → y ≤ head y l → y ≤ head y (insert' x l)
  ins-lemma x y nil y≤x y≤hd = ≤-refl y
  ins-lemma x y (cons x₁ l x₁≤hd) y≤x y≤hd with x ≤? x₁
  ... | left x≤x₁ = y≤x
  ... | right x₁≤x = y≤hd

sort' : (l : List ℕ) → Sorted
sort' [] = nil
sort' (x ∷ l) = insert' x (sort' l)

{- --- 4. Merge sort --- -}

{- 4.1 Splitting -}
split : {A : Set} → List A → List A × List A
split [] = [] , []
split (x ∷ []) = (x ∷ []) , []
split (x ∷ y ∷ l) =
  let (l₁ , l₂) = split l in
  x ∷ l₁ , y ∷ l₂

test-split : List ℕ × List ℕ
test-split = split (4 ∷ 1 ∷ 45 ∷ 8 ∷ 32 ∷ 12 ∷ 1 ∷ [])

{- 4.2 Merging -}
merge : (l m : List ℕ) → List ℕ
merge [] m = m
merge l [] = l
merge (x ∷ l) (y ∷ m) with x ≤? y
... | left x≤y = x ∷ (merge l (y ∷ m))
... | right y≤x = y ∷ (merge (x ∷ l) m)

{- 4.3 Sorting -}

{-# TERMINATING #-}
mergesort-v1 : List ℕ → List ℕ
mergesort-v1 [] = []
mergesort-v1 (x ∷ []) = x ∷ []
mergesort-v1 l =
  let (l₁ , l₂) = split l in
  merge (mergesort-v1 l₁) (mergesort-v1 l₂)

test-merge-v1 : List ℕ
test-merge-v1 = mergesort-v1 (4 ∷ 1 ∷ 45 ∷ 8 ∷ 32 ∷ 12 ∷ 1 ∷ [])

{- 4.4 Splitting is decreasing -}
data _<_ : ℕ → ℕ → Set where
  s<s : {m n : ℕ} (m<n : suc m ≤ n) → m < n

length : {A : Set} (l : List A) → ℕ
length [] = zero
length (x ∷ l) = suc (length l)

test-length : ℕ
test-length = length (4 ∷ [])

{- Surprisingly we need this lemma to have a compact proof that splitting is decreasing -}
≤-to-suc : (m : ℕ) → m ≤ suc m
≤-to-suc zero = z≤n
≤-to-suc (suc m) = s≤s (≤-to-suc m)

{- Splitting is strictly decreasing only for lists with at least two elements
   Another approach would be to add `2 ≤ length l` as an argument, but it
   complicates the proof and Agda's pattern matching shows problematic behavior in that case
   [see at the end] -}
<-split₁ : {A : Set} → (x y : A) → (l : List A)
                    → length (fst (split (x ∷ y ∷ l))) < length (x ∷ y ∷ l)
<-split₁ x y [] = s<s (≤-refl 2)
<-split₁ x y (x₁ ∷ []) = s<s (s≤s (s≤s (≤-refl 1)))
<-split₁ x y (x₁ ∷ x₂ ∷ l) with <-split₁ x y l
... | s<s h = s<s (s≤s (s≤s (≤-trans (≤-to-suc (suc (length (fst (split l))))) h)))

<-split₂ : {A : Set} → (x y : A) → (l : List A)
                    → length (snd (split (x ∷ y ∷ l))) < length (x ∷ y ∷ l)
<-split₂ x y [] = s<s (≤-refl 2)
<-split₂ x y (x₁ ∷ []) = s<s (s≤s (s≤s z≤n))
<-split₂ x y (x₁ ∷ x₂ ∷ l) with <-split₂ x y l
... | s<s h = s<s (s≤s (s≤s (≤-trans (≤-to-suc (suc (length (snd (split l))))) h)))

{- 4.5 The fuel definition of merge -}

{- Convenience function -}
<-to-≤ : {m n : ℕ} → m < n → suc m ≤ n
<-to-≤ (s<s m<n) = m<n

{- The key part of this definition is proving that the recursive calls are decreasing -}
mergesort-fuel : (n : ℕ) → (l : List ℕ) → (length l ≤ n) → List ℕ
mergesort-fuel n [] l≤n = []
mergesort-fuel n (x ∷ []) l≤n = x ∷ []
mergesort-fuel (suc n) (x ∷ y ∷ l) l≤n =
  let (l₁ , l₂) = split (x ∷ y ∷ l) in
  merge
    (mergesort-fuel n l₁ (≤-trans (≤-pred (<-to-≤ (<-split₁ x y l))) (≤-pred l≤n)))
    (mergesort-fuel n l₂ (≤-trans (≤-pred (<-to-≤ (<-split₂ x y l))) (≤-pred l≤n)))

mergesort : (l : List ℕ) → List ℕ
mergesort l = mergesort-fuel (length l) l (≤-refl (length l))

test-merge : List ℕ
test-merge = mergesort (4 ∷ 1 ∷ 45 ∷ 8 ∷ 32 ∷ 12 ∷ 1 ∷ [])

{- 4.6 Merge sort is sorting -}

{- Intrinsic approach: using the Sorted type -}

{- Step 1: merging two sorted lists produces a sorted list -}
mutual
  merge' : (l m : Sorted) → Sorted
  merge' nil m = m
  merge' l nil = l
  merge' (cons x l x≤l) (cons y m y≤m) with x ≤? y
  ... | left x≤y = cons x (merge' l (cons y m y≤m)) (merge-lemma x l (cons y m y≤m) x≤l x≤y)
  ... | right y≤x = cons y (merge' (cons x l x≤l) m) (merge-lemma y (cons x l x≤l) m y≤x y≤m)

  {- Lemma: if x is a lower bound on both l and m, it's also a lower bound on the merged list -}
  merge-lemma : (x : ℕ) → (l m : Sorted) → x ≤ head x l → x ≤ head x m
                → x ≤ head x (merge' l m)
  merge-lemma x nil m x≤l x≤m = x≤m
  merge-lemma x (cons y l y≤l) nil x≤l x≤m = x≤l
  merge-lemma x (cons y l y≤l) (cons z m z≤m) x≤l x≤m with y ≤? z
  ... | left y≤z = x≤l
  ... | right z≤y = x≤m

{- Step 2: same-approach to mergesort-fuel -}
mergesort-fuel-v2 : (n : ℕ) → (l : List ℕ) → (length l ≤ n) → Sorted
mergesort-fuel-v2 _ [] _ = nil
mergesort-fuel-v2 _ (x ∷ []) _ = cons x nil (≤-refl x)
mergesort-fuel-v2 (suc n) (x ∷ y ∷ l) l≤n =
  let (l₁ , l₂) = split (x ∷ y ∷ l) in
  merge'
    (mergesort-fuel-v2 n l₁ (≤-trans (≤-pred (<-to-≤ (<-split₁ x y l))) (≤-pred l≤n)))
    (mergesort-fuel-v2 n l₂ (≤-trans (≤-pred (<-to-≤ (<-split₂ x y l))) (≤-pred l≤n)))

{- Step 3: mergesort-v3 comes to life -}
mergesort-v3 : List ℕ → Sorted
mergesort-v3 l = mergesort-fuel-v2 (length l) l (≤-refl (length l))

{- --- APPENDIX --- -}

{- Showcase: Agda's pattern matching forces us to consider a case where 2 ≤ 1 -}
<-split₁-x : {A : Set} → (l : List A) → 2 ≤ length l
                                    → length (fst (split l)) < length l
<-split₁-x (x ∷ []) (s≤s ())
<-split₁-x (x ∷ y ∷ l) 2≤l' with 2 ≤? length l
... | left 2≤l = s<s (s≤s (≤-trans (<-to-≤ (<-split₁-x l 2≤l)) (≤-to-suc (length l))))
... | right l≤2 = {!!} {- would need to refine l here -}


open import Relation.Binary.Core

module Bound.Total.Order.Properties {A : Set}
                 (_≤_ : A → A → Set)
                 (trans≤ : Transitive _≤_)  where

open import Bound.Total A
open import Bound.Total.Order _≤_

lemma-LeB≤ : {x y : A} → LeB (val x) (val y) → x ≤ y
lemma-LeB≤ (lexy x≤y) = x≤y

transLeB : {a b c : Bound} → LeB a b → LeB b c → LeB a c
transLeB lebx _ = lebx
transLeB _ lext = lext
transLeB (lexy x≤y) (lexy y≤z) = lexy (trans≤ x≤y y≤z)


module Numeral.Integer.Sign where

open import Numeral.Natural
  using (ℕ)
open import Numeral.Integer
open import Numeral.Sign as Sign
  using (+|− ; +|0|−)

sign : ℤ → (+|−)
sign(+ₙ _) = Sign.➕
sign(−𝐒ₙ _) = Sign.➖

sign0 : ℤ → (+|0|−)
sign0(𝟎) = Sign.𝟎
sign0(+𝐒ₙ _) = Sign.➕
sign0(−𝐒ₙ _) = Sign.➖

signum0 : ℤ → ℤ
signum0(𝟎) = 𝟎
signum0(+𝐒ₙ _) = +𝐒ₙ(ℕ.𝟎)
signum0(−𝐒ₙ _) = −𝐒ₙ(ℕ.𝟎)


-- This module is used to illustrate how to import a non-parameterised module.
module examples.syntax.ModuleA where

  data Nat : Set where
    zero  : Nat
    suc   : Nat -> Nat
    plus  : Nat -> Nat -> Nat

  eval : Nat -> Nat
  eval zero		    = zero
  eval (suc x)		    = suc (eval x)
  eval (plus zero y)	    = eval y
  eval (plus (suc x) y)	    = suc (eval (plus x y))
  eval (plus (plus x y) z)  = eval (plus x (plus y z))


{-# OPTIONS --without-K --exact-split --safe #-}

module Homotopy_Equivalence where

open import Basic_Types
open import Identity

-- ------------------------------------
-- In homotopy type theory, a homotopy is just a point-wise equality (path)
-- between to (dependent) functions f and g
infix  2 _~_

_~_ : ∀ {A : Set} {B : A → Set} → ∀ (f g : ∀ (x : A) → B x) → Set
_~_ {A} f g = ∀ (x : A) → f x ≡ g x

-- operations on homotopies, which give them groupoid-like structures
hp-refl : ∀ {A : Set} {B : A → Set} → ∀ (f : ∀ (a : A) → B a) → f ~ f
hp-refl {A} f = λ (x : A) → refl (f x)

hp-inv : ∀ {A : Set} {B : A → Set} {f g : ∀ (a : A) → B a} → f ~ g → g ~ f
hp-inv {A} H = λ (x : A) → inv (H x)

hp-concat : ∀ {A : Set} {B : A → Set} {f g h : ∀ (a : A) → B a} →
            f ~ g → g ~ h → f ~ h
hp-concat {A} H K = λ (x : A) → (H x) ∙ (K x)

-- naturality of homotopies
<<<<<<< HEAD
hpna : ∀ {A B : Set} {x y : A} → ∀ (p : x ≡ y) → ∀ (f g : A → B) → ∀ (H : f ~ g) →
       (H x) ∙ (ap g p) ≡ (ap f p) ∙ (H y)
hpna {_} {_} {x} {x} (refl x) f g H = (right_unit (H x)) ∙ (inv (left_unit (H x)))

=======

>>>>>>> a0dc66dca08059f740d9290f3d1cad1bb007d721
infix  3 _·_

_·_ : ∀ {A : Set} {B : A → Set} {f g h : ∀ (a : A) → B a} →
      f ~ g → g ~ h → f ~ h
H · K = hp-concat H K

hp-ass : ∀ {A : Set} {B : A → Set} {f g h k : ∀ (a : A) → B a} →
         ∀ (H : f ~ g) (K : g ~ h) (L : h ~ k) → H · (K · L) ~ (H · K) · L
hp-ass {A} H K L = λ (x : A) → p-ass (H x) (K x) (L x)

hp-left_unit : ∀ {A : Set} {B : A → Set} {f g : ∀ (a : A) → B a} →
               ∀ (H : f ~ g) → (hp-refl f) · H ~ H
hp-left_unit {A} H = λ (x : A) → left_unit (H x)

hp-right_unit : ∀ {A : Set} {B : A → Set} {f g : ∀ (a : A) → B a} →
                ∀ (H : f ~ g) → H · (hp-refl g) ~ H
hp-right_unit {A} H = λ (x : A) → right_unit (H x)

-- whiskering operations
whis-r : ∀ {A B C : Set} {f g : A → B} → ∀ (H : f ~ g) → ∀ (h : B → C) →
         (comp h f) ~ (comp h g)
<<<<<<< HEAD
whis-r {A} H h = λ (x : A) → ap h (H x)
=======
whis-f {A} h H = λ (x : A) → ap h (H x)
>>>>>>> a0dc66dca08059f740d9290f3d1cad1bb007d721

whis-l : ∀ {A B C : Set} {g h : B → C} → ∀ (H : g ~ h) → ∀ (f : A → B) →
         (comp g f) ~ (comp h f)
whis-l {A} H f = λ (x : A) → H (f x)

-- ------------------------------------
-- equivalences
-- first, let's consider quasi-equivalences
qinv : ∀ {A B : Set} → ∀ (f : A → B) → Set
qinv {A} {B} f = Σ g ∶ (B → A) , (((comp f g) ~ id) × ((comp g f) ~ id))

isequiv : ∀ {A B : Set} → ∀ (f : A → B) → Set
isequiv {A} {B} f = (Σ g ∶ (B → A) , ((comp f g) ~ id)) × (Σ h ∶ (B → A) , ((comp h f) ~ id))

isequivid : ∀ {A : Set} → isequiv (id {A})
isequivid {A} = ((id {A} , hp-refl (id {A})) , (id {A} , hp-refl (id {A})))

-- the relation between quasi-inverse and equivalence is as following:
q→e : ∀ {A B : Set} → ∀ (f : A → B) → qinv f → isequiv f
q→e f q = ((π₁ q , π₁ (π₂ q)) , (π₁ q , π₂ (π₂ q)))

e→q : ∀ {A B : Set} → ∀ (f : A → B) → isequiv f → qinv f
e→q {A} {B} f ((g , fgid) , (h , hfid)) = (comp h (comp f g) , (e→q1 , e→q2))
  where e→q1 : comp f (comp h (comp f g)) ~ id
        e→q1 = (whis-l {B} {A} {B} (whis-r {A} {A} {B} hfid f) g) · fgid
        e→q2 : comp (comp h (comp f g)) f ~ id
        e→q2 = (whis-l {A} {B} {A} (whis-r {B} {B} {A} fgid h) f) · hfid
-- the above two lemmas shows that quasi-equivalence and equivalence are
-- logically equivalent

-- ------------------------------------
-- type equivalence
infix  3 _≃_

_≃_ : ∀ (A B : Set) → Set
A ≃ B = Σ f ∶ (A → B) , (isequiv f)

-- type equivalence is an equivalence relation on Set
≃-refl : ∀ (A : Set) → A ≃ A
≃-refl A = id {A} , isequivid {A}

-- ------------------------------------
-- The higher groupoid structure of type formers
-- Cartesian product types
p×1 : ∀ {A B : Set} {x y : A × B} → x ≡ y → π₁ x ≡ π₁ y
p×1 {_} {_} {x} {x} (refl x) = refl (π₁ x)

p×2 : ∀ {A B : Set} {x y : A × B} → x ≡ y → π₂ x ≡ π₂ y
p×2 {_} {_} {x} {x} (refl x) = refl (π₂ x)

p≡p× : ∀ {A B : Set} {x y : A × B} → ∀ (p : x ≡ y) → (π₁ x ≡ π₁ y) × (π₂ x ≡ π₂ y)
p≡p× = λ p → (p×1 p , p×2 p)

p×≡p : ∀ {A B : Set} {x1 y1 : A} {x2 y2 : B} →
      ((x1 ≡ y1) × (x2 ≡ y2)) → (x1 , x2) ≡ (y1 , y2)
p×≡p {_} {_} {x1} {x1} {x2} {x2} (refl x1 , refl x2) = refl (x1 , x2)


-- https://stackoverflow.com/questions/61037572/how-to-define-the-range-function-on-a-relation-in-agda-set-theory

module range where

open import Data.Unit
open import Data.Product renaming (_,_ to ⟨_,_⟩)
open import Data.Sum
open import Function

Subset : Set → Set₁
Subset A = A → Set

_∈_ : ∀ {A} → A → Subset A → Set
a ∈ P = P a

Relation : ∀ A B → Set₁
Relation A B = Subset (A × B)

Range : ∀ {A B} → Relation A B → Subset B
Range R b = ∃ (R ∘ ⟨_, b ⟩)  -- equivalent to ∃ \a → R ⟨ a , b ⟩

_⊆_ : ∀ {A} → Subset A → Subset A → Set
A ⊆ B = ∀ x → x ∈ A → x ∈ B

wholeSet : ∀ A → Subset A
wholeSet _ _ = ⊤

∀subset⊆set : ∀ {A sub} → sub ⊆ wholeSet A
∀subset⊆set _ _ = tt

_∩_ : ∀ {A} → Subset A → Subset A → Subset A
(A ∩ B) x = x ∈ A × x ∈ B

open import Data.Nat

x : Set₁
x = Subset ℕ

y : Set₁
y = Relation ℕ ℕ

z : Subset ℕ
z = Range {ℕ} λ { ⟨ n1 , n2 ⟩ → (x₁ : Σ ℕ (λ _ → ℕ)) → {!!} ∈ {!!}}


------------------------------------------------------------------------
-- Some algebraic structures (not packed up with sets, operations,
-- etc.)
------------------------------------------------------------------------

open import Relation.Binary

module Algebra.Structures where

import Algebra.FunctionProperties as FunctionProperties
open FunctionProperties using (Op₁; Op₂)
import Relation.Binary.EqReasoning as EqR
open import Data.Function
open import Data.Product

------------------------------------------------------------------------
-- One binary operation

record IsSemigroup {A} (≈ : Rel A) (∙ : Op₂ A) : Set where
  open FunctionProperties ≈
  field
    isEquivalence : IsEquivalence ≈
    assoc         : Associative ∙
    ∙-pres-≈      : ∙ Preserves₂ ≈ ⟶ ≈ ⟶ ≈

  open IsEquivalence isEquivalence public

record IsMonoid {A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) : Set where
  open FunctionProperties ≈
  field
    isSemigroup : IsSemigroup ≈ ∙
    identity    : Identity ε ∙

  open IsSemigroup isSemigroup public

record IsCommutativeMonoid
         {A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) : Set where
  open FunctionProperties ≈
  field
    isMonoid : IsMonoid ≈ ∙ ε
    comm     : Commutative ∙

  open IsMonoid isMonoid public

record IsGroup
         {A} (≈ : Rel A) (_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set where
  open FunctionProperties ≈
  infixl 7 _-_
  field
    isMonoid  : IsMonoid ≈ _∙_ ε
    inverse   : Inverse ε _⁻¹ _∙_
    ⁻¹-pres-≈ : _⁻¹ Preserves ≈ ⟶ ≈

  open IsMonoid isMonoid public

  _-_ : Op₂ A
  x - y = x ∙ (y ⁻¹)

record IsAbelianGroup
         {A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) (⁻¹ : Op₁ A) : Set where
  open FunctionProperties ≈
  field
    isGroup : IsGroup ≈ ∙ ε ⁻¹
    comm    : Commutative ∙

  open IsGroup isGroup public

  isCommutativeMonoid : IsCommutativeMonoid ≈ ∙ ε
  isCommutativeMonoid = record
    { isMonoid = isMonoid
    ; comm     = comm
    }

------------------------------------------------------------------------
-- Two binary operations

record IsNearSemiring {A} (≈ : Rel A) (+ * : Op₂ A) (0# : A) : Set where
  open FunctionProperties ≈
  field
    +-isMonoid    : IsMonoid ≈ + 0#
    *-isSemigroup : IsSemigroup ≈ *
    distribʳ      : * DistributesOverʳ +
    zeroˡ         : LeftZero 0# *

  open IsMonoid +-isMonoid public
         renaming ( assoc       to +-assoc
                  ; ∙-pres-≈    to +-pres-≈
                  ; isSemigroup to +-isSemigroup
                  ; identity    to +-identity
                  )

  open IsSemigroup *-isSemigroup public
         using ()
         renaming ( assoc    to *-assoc
                  ; ∙-pres-≈ to *-pres-≈
                  )

record IsSemiringWithoutOne
         {A} (≈ : Rel A) (+ * : Op₂ A) (0# : A) : Set where
  open FunctionProperties ≈
  field
    +-isCommutativeMonoid : IsCommutativeMonoid ≈ + 0#
    *-isSemigroup         : IsSemigroup ≈ *
    distrib               : * DistributesOver +
    zero                  : Zero 0# *

  open IsCommutativeMonoid +-isCommutativeMonoid public
         renaming ( assoc       to +-assoc
                  ; ∙-pres-≈    to +-pres-≈
                  ; isSemigroup to +-isSemigroup
                  ; identity    to +-identity
                  ; isMonoid    to +-isMonoid
                  ; comm        to +-comm
                  )

  open IsSemigroup *-isSemigroup public
         using ()
         renaming ( assoc       to *-assoc
                  ; ∙-pres-≈    to *-pres-≈
                  )

  isNearSemiring : IsNearSemiring ≈ + * 0#
  isNearSemiring = record
    { +-isMonoid    = +-isMonoid
    ; *-isSemigroup = *-isSemigroup
    ; distribʳ      = proj₂ distrib
    ; zeroˡ         = proj₁ zero
    }

record IsSemiringWithoutAnnihilatingZero
         {A} (≈ : Rel A) (+ * : Op₂ A) (0# 1# : A) : Set where
  open FunctionProperties ≈
  field
    -- Note that these structures do have an additive unit, but this
    -- unit does not necessarily annihilate multiplication.
    +-isCommutativeMonoid : IsCommutativeMonoid ≈ + 0#
    *-isMonoid            : IsMonoid ≈ * 1#
    distrib               : * DistributesOver +

  open IsCommutativeMonoid +-isCommutativeMonoid public
         renaming ( assoc       to +-assoc
                  ; ∙-pres-≈    to +-pres-≈
                  ; isSemigroup to +-isSemigroup
                  ; identity    to +-identity
                  ; isMonoid    to +-isMonoid
                  ; comm        to +-comm
                  )

  open IsMonoid *-isMonoid public
         using ()
         renaming ( assoc       to *-assoc
                  ; ∙-pres-≈    to *-pres-≈
                  ; isSemigroup to *-isSemigroup
                  ; identity    to *-identity
                  )

record IsSemiring {A} (≈ : Rel A) (+ * : Op₂ A) (0# 1# : A) : Set where
  open FunctionProperties ≈
  field
    isSemiringWithoutAnnihilatingZero :
      IsSemiringWithoutAnnihilatingZero ≈ + * 0# 1#
    zero : Zero 0# *

  open IsSemiringWithoutAnnihilatingZero
         isSemiringWithoutAnnihilatingZero public

  isSemiringWithoutOne : IsSemiringWithoutOne ≈ + * 0#
  isSemiringWithoutOne = record
    { +-isCommutativeMonoid = +-isCommutativeMonoid
    ; *-isSemigroup         = *-isSemigroup
    ; distrib               = distrib
    ; zero                  = zero
    }

  open IsSemiringWithoutOne isSemiringWithoutOne public
         using (isNearSemiring)

record IsCommutativeSemiringWithoutOne
         {A} (≈ : Rel A) (+ * : Op₂ A) (0# : A) : Set where
  open FunctionProperties ≈
  field
    isSemiringWithoutOne : IsSemiringWithoutOne ≈ + * 0#
    *-comm               : Commutative *

  open IsSemiringWithoutOne isSemiringWithoutOne public

record IsCommutativeSemiring
         {A} (≈ : Rel A) (+ * : Op₂ A) (0# 1# : A) : Set where
  open FunctionProperties ≈
  field
    isSemiring : IsSemiring ≈ + * 0# 1#
    *-comm     : Commutative *

  open IsSemiring isSemiring public

  *-isCommutativeMonoid : IsCommutativeMonoid ≈ * 1#
  *-isCommutativeMonoid = record
      { isMonoid = *-isMonoid
      ; comm     = *-comm
      }

  isCommutativeSemiringWithoutOne :
    IsCommutativeSemiringWithoutOne ≈ + * 0#
  isCommutativeSemiringWithoutOne = record
    { isSemiringWithoutOne = isSemiringWithoutOne
    ; *-comm               = *-comm
    }

record IsRing {A} (≈ : Rel A)
              (_+_ _*_ : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set where
  open FunctionProperties ≈
  field
    +-isAbelianGroup : IsAbelianGroup ≈ _+_ 0# -_
    *-isMonoid       : IsMonoid ≈ _*_ 1#
    distrib          : _*_ DistributesOver _+_

  open IsAbelianGroup +-isAbelianGroup public
         renaming ( assoc               to +-assoc
                  ; ∙-pres-≈            to +-pres-≈
                  ; isSemigroup         to +-isSemigroup
                  ; identity            to +-identity
                  ; isMonoid            to +-isMonoid
                  ; inverse             to -‿inverse
                  ; ⁻¹-pres-≈           to -‿pres-≈
                  ; isGroup             to +-isGroup
                  ; comm                to +-comm
                  ; isCommutativeMonoid to +-isCommutativeMonoid
                  )

  open IsMonoid *-isMonoid public
         using ()
         renaming ( assoc       to *-assoc
                  ; ∙-pres-≈    to *-pres-≈
                  ; isSemigroup to *-isSemigroup
                  ; identity    to *-identity
                  )

  zero : Zero 0# _*_
  zero = (zeroˡ , zeroʳ)
    where
    open EqR (record { isEquivalence = isEquivalence })

    zeroˡ : LeftZero 0# _*_
    zeroˡ x = begin
        0# * x                              ≈⟨ sym $ proj₂ +-identity _ ⟩
       (0# * x) +            0#             ≈⟨ refl ⟨ +-pres-≈ ⟩ sym (proj₂ -‿inverse _) ⟩
       (0# * x) + ((0# * x)  + - (0# * x))  ≈⟨ sym $ +-assoc _ _ _ ⟩
      ((0# * x) +  (0# * x)) + - (0# * x)   ≈⟨ sym (proj₂ distrib _ _ _) ⟨ +-pres-≈ ⟩ refl ⟩
             ((0# + 0#) * x) + - (0# * x)   ≈⟨ (proj₂ +-identity _ ⟨ *-pres-≈ ⟩ refl)
                                                 ⟨ +-pres-≈ ⟩
                                               refl ⟩
                    (0# * x) + - (0# * x)   ≈⟨ proj₂ -‿inverse _ ⟩
                             0#             ∎

    zeroʳ : RightZero 0# _*_
    zeroʳ x = begin
      x * 0#                              ≈⟨ sym $ proj₂ +-identity _ ⟩
      (x * 0#) + 0#                       ≈⟨ refl ⟨ +-pres-≈ ⟩ sym (proj₂ -‿inverse _) ⟩
      (x * 0#) + ((x * 0#) + - (x * 0#))  ≈⟨ sym $ +-assoc _ _ _ ⟩
      ((x * 0#) + (x * 0#)) + - (x * 0#)  ≈⟨ sym (proj₁ distrib _ _ _) ⟨ +-pres-≈ ⟩ refl ⟩
      (x * (0# + 0#)) + - (x * 0#)        ≈⟨ (refl ⟨ *-pres-≈ ⟩ proj₂ +-identity _)
                                               ⟨ +-pres-≈ ⟩
                                             refl ⟩
      (x * 0#) + - (x * 0#)               ≈⟨ proj₂ -‿inverse _ ⟩
      0#                                  ∎

  isSemiringWithoutAnnihilatingZero
    : IsSemiringWithoutAnnihilatingZero ≈ _+_ _*_ 0# 1#
  isSemiringWithoutAnnihilatingZero = record
    { +-isCommutativeMonoid = +-isCommutativeMonoid
    ; *-isMonoid            = *-isMonoid
    ; distrib               = distrib
    }

  isSemiring : IsSemiring ≈ _+_ _*_ 0# 1#
  isSemiring = record
    { isSemiringWithoutAnnihilatingZero =
        isSemiringWithoutAnnihilatingZero
    ; zero = zero
    }

  open IsSemiring isSemiring public
         using (isNearSemiring; isSemiringWithoutOne)

record IsCommutativeRing {A}
         (≈ : Rel A) (+ * : Op₂ A) (- : Op₁ A) (0# 1# : A) : Set where
  open FunctionProperties ≈
  field
    isRing : IsRing ≈ + * - 0# 1#
    *-comm : Commutative *

  open IsRing isRing public

  isCommutativeSemiring : IsCommutativeSemiring ≈ + * 0# 1#
  isCommutativeSemiring = record
    { isSemiring = isSemiring
    ; *-comm     = *-comm
    }

  open IsCommutativeSemiring isCommutativeSemiring public
         using (isCommutativeSemiringWithoutOne)

record IsLattice {A} (≈ : Rel A) (∨ ∧ : Op₂ A) : Set where
  open FunctionProperties ≈
  field
    isEquivalence : IsEquivalence ≈
    ∨-comm        : Commutative ∨
    ∨-assoc       : Associative ∨
    ∨-pres-≈      : ∨ Preserves₂ ≈ ⟶ ≈ ⟶ ≈
    ∧-comm        : Commutative ∧
    ∧-assoc       : Associative ∧
    ∧-pres-≈      : ∧ Preserves₂ ≈ ⟶ ≈ ⟶ ≈
    absorptive    : Absorptive ∨ ∧

  open IsEquivalence isEquivalence public

record IsDistributiveLattice {A} (≈ : Rel A) (∨ ∧ : Op₂ A) : Set where
  open FunctionProperties ≈
  field
    isLattice    : IsLattice ≈ ∨ ∧
    ∨-∧-distribʳ : ∨ DistributesOverʳ ∧

  open IsLattice isLattice public

record IsBooleanAlgebra
         {A} (≈ : Rel A) (∨ ∧ : Op₂ A) (¬ : Op₁ A) (⊤ ⊥ : A) : Set where
  open FunctionProperties ≈
  field
    isDistributiveLattice : IsDistributiveLattice ≈ ∨ ∧
    ∨-complementʳ         : RightInverse ⊤ ¬ ∨
    ∧-complementʳ         : RightInverse ⊥ ¬ ∧
    ¬-pres-≈              : ¬ Preserves ≈ ⟶ ≈

  open IsDistributiveLattice isDistributiveLattice public


module Prelude.Semigroup where

open import Prelude.Function
open import Prelude.Maybe

open import Prelude.List

open import Prelude.Semiring
open import Prelude.Applicative
open import Prelude.Functor
open import Prelude.Equality

record Semigroup {a} (A : Set a) : Set a where
  infixr 6 _<>_
  field
    _<>_ : A → A → A
open Semigroup {{...}} public

{-# DISPLAY Semigroup._<>_ _ a b = a <> b #-}
{-# DISPLAY Semigroup._<>_ _ = _<>_ #-}

record Semigroup/Laws {a} (A : Set a) : Set a where
  field
    {{super}} : Semigroup A
    semigroup-assoc : (a b c : A) → (a <> b) <> c ≡ a <> (b <> c)
open Semigroup/Laws {{...}} public hiding (super)

instance
  SemigroupList : ∀ {a} {A : Set a} → Semigroup (List A)
  _<>_   {{SemigroupList}} = _++_

  SemigroupFun : ∀ {a b} {A : Set a} {B : A → Set b} {{_ : ∀ {x} → Semigroup (B x)}} → Semigroup (∀ x → B x)
  _<>_   {{SemigroupFun}} f g x = f x <> g x

  SemigroupMaybe : ∀ {a} {A : Set a} → Semigroup (Maybe A)
  _<>_   {{SemigroupMaybe}} nothing  y = y
  _<>_   {{SemigroupMaybe}} (just x) _ = just x


{-
This second-order signature was created from the following second-order syntax description:

syntax Sub | S

type
  L : 0-ary
  T : 0-ary

term
  vr : L  ->  T
  sb : L.T  T  ->  T

theory
  (C) x y : T |> sb (a. x[], y[]) = x[]
  (L) x : T |> sb (a. vr(a), x[]) = x[]
  (R) a : L  x : L.T |> sb (b. x[b], vr(a[])) = x[a[]]
  (A) x : (L,L).T  y : L.T  z : T |> sb (a. sb (b. x[a,b], y[a]), z[]) = sb (b. sb (a. x[a, b], z[]), sb (a. y[a], z[]))
-}

module Sub.Signature where

open import SOAS.Context

-- Type declaration
data ST : Set where
  L : ST
  T : ST

open import SOAS.Syntax.Signature ST public
open import SOAS.Syntax.Build ST public

-- Operator symbols
data Sₒ : Set where
  vrₒ sbₒ : Sₒ

-- Term signature
S:Sig : Signature Sₒ
S:Sig = sig λ
  {  vrₒ  → (⊢₀ L) ⟼₁ T
  ;  sbₒ  → (L ⊢₁ T) , (⊢₀ T) ⟼₂ T
  }

open Signature S:Sig public


{-# OPTIONS --cubical --safe #-}

module Data.Nat.Properties where

open import Data.Nat.Base
open import Agda.Builtin.Nat using () renaming (_<_ to _<ᴮ_; _==_ to _≡ᴮ_) public
open import Prelude
open import Cubical.Data.Nat using (caseNat; znots; snotz; injSuc) public

pred : ℕ → ℕ
pred (suc n) = n
pred zero = zero

correct-== : ∀ n m → Reflects (n ≡ m) (n ≡ᴮ m)
correct-== zero zero = ofʸ refl
correct-== zero (suc m) = ofⁿ znots
correct-== (suc n) zero = ofⁿ snotz
correct-== (suc n) (suc m) =
  map-reflects (cong suc) (λ contra prf  → contra (cong pred prf)) (correct-== n m)

discreteℕ : Discrete ℕ
discreteℕ n m .does = n ≡ᴮ m
discreteℕ n m .why  = correct-== n m

isSetℕ : isSet ℕ
isSetℕ = Discrete→isSet discreteℕ

+-suc : ∀ x y → x + suc y ≡ suc (x + y)
+-suc zero y = refl
+-suc (suc x) y = cong suc (+-suc x y)

+-idʳ : ∀ x → x + 0 ≡ x
+-idʳ zero     = refl
+-idʳ (suc x)  = cong suc (+-idʳ x)

+-comm : ∀ x y → x + y ≡ y + x
+-comm x zero = +-idʳ x
+-comm x (suc y) = +-suc x y ; cong suc (+-comm x y)

infix 4 _<_
_<_ : ℕ → ℕ → Type₀
n < m = T (n <ᴮ m)

_≤ᴮ_ : ℕ → ℕ → Bool
zero  ≤ᴮ m = true
suc n ≤ᴮ m = n <ᴮ m

+-assoc : ∀ x y z → (x + y) + z ≡ x + (y + z)
+-assoc zero y z = refl
+-assoc (suc x) y z = cong suc (+-assoc x y z)


------------------------------------------------------------------------------
-- Commutativity of addition of total natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.AddComm where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat

------------------------------------------------------------------------------
-- Auxiliary properties

succCong : ∀ {m n} → m ≡ n → succ₁ m ≡ succ₁ n
succCong refl = refl

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity Nn = N-ind A A0 is Nn
  where
  A : D → Set
  A i = i + zero ≡ i

  A0 : A zero
  A0 = +-leftIdentity zero

  is : ∀ {i} → A i → A (succ₁ i)
  is {i} Ai = trans (+-Sx i zero) (succCong Ai)

x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] Nm n = N-ind A A0 is Nm
  where
  A : D → Set
  A i = i + succ₁ n ≡ succ₁ (i + n)

  A0 : A zero
  A0 = zero + succ₁ n   ≡⟨ +-leftIdentity (succ₁ n) ⟩
       succ₁ n          ≡⟨ succCong (sym (+-leftIdentity n)) ⟩
       succ₁ (zero + n) ∎

  is : ∀ {i} → A i → A (succ₁ i)
  is {i} Ai = succ₁ i + succ₁ n     ≡⟨ +-Sx i (succ₁ n) ⟩
              succ₁ (i + succ₁ n)   ≡⟨ succCong Ai ⟩
              succ₁ (succ₁ (i + n)) ≡⟨ succCong (sym (+-Sx i n)) ⟩
              succ₁ (succ₁ i + n)   ∎

+-comm-ind-instance :
  ∀ n →
  zero + n ≡ n + zero →
  (∀ {m} → m + n ≡ n + m → succ₁ m + n ≡ n + succ₁ m) →
  ∀ {m} → N m → m + n ≡ n + m
+-comm-ind-instance n = N-ind (λ i → i + n ≡ n + i)

------------------------------------------------------------------------------
-- Approach 1: Interactive proof using pattern matching

module M1 where

  +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
  +-comm {n = n} nzero Nn =
    zero + n ≡⟨ +-leftIdentity n ⟩
    n        ≡⟨ sym (+-rightIdentity Nn) ⟩
    n + zero ∎

  +-comm {n = n} (nsucc {m} Nm) Nn =
    succ₁ m + n   ≡⟨ +-Sx m n ⟩
    succ₁ (m + n) ≡⟨ succCong (+-comm Nm Nn) ⟩
    succ₁ (n + m) ≡⟨ sym (x+Sy≡S[x+y] Nn m) ⟩
    n + succ₁ m   ∎

------------------------------------------------------------------------------
-- Approach 2: Combined proof using pattern matching

module M2 where

  +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
  +-comm {n = n} nzero Nn = prf
    where postulate prf : zero + n ≡ n + zero
          {-# ATP prove prf +-rightIdentity #-}
  +-comm {n = n} (nsucc {m} Nm) Nn = prf (+-comm Nm Nn)
    where postulate prf : m + n ≡ n + m → succ₁ m + n ≡ n + succ₁ m
          {-# ATP prove prf x+Sy≡S[x+y] #-}

------------------------------------------------------------------------------
-- Approach 3: Interactive proof using the induction principle

module M3 where

  +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
  +-comm {n = n} Nm Nn = N-ind A A0 is Nm
    where
    A : D → Set
    A i = i + n ≡ n + i

    A0 : A zero
    A0 = zero + n ≡⟨ +-leftIdentity n ⟩
         n        ≡⟨ sym (+-rightIdentity Nn) ⟩
         n + zero ∎

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} Ai = succ₁ i + n   ≡⟨ +-Sx i n ⟩
                succ₁ (i + n) ≡⟨ succCong Ai ⟩
                succ₁ (n + i) ≡⟨ sym (x+Sy≡S[x+y] Nn i) ⟩
                n + succ₁ i   ∎

------------------------------------------------------------------------------
-- Approach 4: Combined proof using the induction principle

module M4 where

  -- See Issue https://github.com/asr/apia/issues/81 .
  +-commA : D → D → Set
  +-commA n i = i + n ≡ n + i
  {-# ATP definition +-commA #-}

  +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
  +-comm {n = n} Nm Nn = N-ind (+-commA n) A0 is Nm
    where
    postulate A0 : +-commA n zero
    {-# ATP prove A0 +-rightIdentity #-}

    postulate is : ∀ {i} → +-commA n i → +-commA n (succ₁ i)
    {-# ATP prove is x+Sy≡S[x+y] #-}

------------------------------------------------------------------------------
-- Approach 5: Interactive proof using an instance of the induction
-- principle

module M5 where

  +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
  +-comm {n = n} Nm Nn = +-comm-ind-instance n A0 is Nm
    where
    A0 : zero + n ≡ n + zero
    A0 = zero + n ≡⟨ +-leftIdentity n ⟩
         n        ≡⟨ sym (+-rightIdentity Nn) ⟩
         n + zero ∎

    is : ∀ {i} → i + n ≡ n + i → succ₁ i + n ≡ n + succ₁ i
    is {i} ih = succ₁ i + n   ≡⟨ +-Sx i n ⟩
                succ₁ (i + n) ≡⟨ succCong ih ⟩
                succ₁ (n + i) ≡⟨ sym (x+Sy≡S[x+y] Nn i) ⟩
                n + succ₁ i   ∎

------------------------------------------------------------------------------
-- Approach 6: Combined proof using an instance of the induction
-- principle

module M6 where

  -- TODO (25 October 2012): Why is it not necessary the hypothesis
  -- +-rightIdentity?
  postulate +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
  {-# ATP prove +-comm +-comm-ind-instance x+Sy≡S[x+y] #-}


{-# OPTIONS --sized-types #-}
module SNat.Log where

open import Size
open import SNat
open import SNat.Order
open import SNat.Order.Properties
open import SNat.Properties
open import SNat.Sum

lemma-≅-log : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}} → m ≅ n → log₂ m ≅ log₂ n
lemma-≅-log z≅z = z≅z
lemma-≅-log (s≅s z≅z) = z≅z
lemma-≅-log (s≅s (s≅s m≅n)) = s≅s (lemma-≅-log (s≅s (lemma-≅-/2 m≅n)))

mutual
  lemma-logn≤′logsn : {ι : Size}(n : SNat {ι}) → log₂ n ≤′ log₂ (succ n)
  lemma-logn≤′logsn zero = ≤′-eq z≅z
  lemma-logn≤′logsn (succ zero) = ≤′-step (≤′-eq z≅z)
  lemma-logn≤′logsn (succ (succ n)) = lemma-s≤′s (lemma-≤′-log (lemma-s≤′s (lemma-n/2≤′sn/2 n)))

  lemma-≤′-log : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}} → m ≤′ n → log₂ m ≤′ log₂ n
  lemma-≤′-log (≤′-eq m≅n) = ≤′-eq (lemma-≅-log m≅n)
  lemma-≤′-log (≤′-step {n = n} m≤′n) = trans≤′ (lemma-≤′-log m≤′n) (lemma-logn≤′logsn n)

lemma-1+logn≤′log2n : (n : SNat) → succ (log₂ (succ n)) ≤′ log₂ (succ n + succ n)
lemma-1+logn≤′log2n zero = refl≤′
lemma-1+logn≤′log2n (succ n) rewrite +-assoc-succ (succ (succ n)) (succ n) | +-assoc-succ n (succ n) | +-assoc-succ n n = lemma-s≤′s (lemma-≤′-log (lemma-s≤′s (lemma-n+1≤′2n+2/2 n)))

lemma-log2n≤′1+logn : (n : SNat) → log₂ (n + n) ≤′ succ (log₂ n)
lemma-log2n≤′1+logn zero = ≤′-step refl≤′
lemma-log2n≤′1+logn (succ n) rewrite +-assoc-succ (succ n) n = lemma-s≤′s (lemma-≤′-log (lemma-s≤′s (lemma-2n/2≤′n n)))


{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Instances.DiffInt where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Int.MoreInts.DiffInt renaming ( _+_ to _+ℤ_ ; _-_ to _-ℤ_)

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Semigroup.Base
open import Cubical.Algebra.Monoid.Base

open import Cubical.HITs.SetQuotients

open GroupStr

ℤ-isGroup : IsGroup {G = ℤ} ([ 0 , 0 ]) (_+ℤ_) (-ℤ_)
IsSemigroup.is-set (IsMonoid.isSemigroup (IsGroup.isMonoid ℤ-isGroup)) = ℤ-isSet
IsSemigroup.assoc (IsMonoid.isSemigroup (IsGroup.isMonoid ℤ-isGroup)) = +ℤ-assoc
IsMonoid.identity (IsGroup.isMonoid ℤ-isGroup) = λ x → (zero-identityʳ 0 x  , zero-identityˡ 0 x)
IsGroup.inverse ℤ-isGroup = λ x → (-ℤ-invʳ x , -ℤ-invˡ x)

ℤGroup : Group₀
fst ℤGroup = ℤ
1g (snd ℤGroup) = [ 0 , 0 ]
_·_ (snd ℤGroup) = _+ℤ_
inv (snd ℤGroup) = -ℤ_
isGroup (snd ℤGroup) = ℤ-isGroup


{-# OPTIONS --safe --warning=error --without-K #-}

open import Groups.Definition
open import Setoids.Orders.Partial.Definition
open import Setoids.Setoids
open import Functions.Definition

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Groups.Orders.Partial.Definition {n m : _} {A : Set n} {S : Setoid {n} {m} A} {_+_ : A → A → A} (G : Group S _+_) where

open Group G
open Setoid S

record PartiallyOrderedGroup {p : _} {_<_ : Rel {_} {p} A} (pOrder : SetoidPartialOrder S _<_) : Set (lsuc n ⊔ m ⊔ p) where
  field
    orderRespectsAddition : {a b : A} → (a < b) → (c : A) → (a + c) < (b + c)