------------------------------------------------------------------------
-- List membership and some related definitions
open import Level using (Level; _⊔_)
open import Relation.Binary
open import Relation.Binary.List.Pointwise as ListEq using ([]; _∷_)
open import Relation.Nullary
open import Data.List
open import Data.List.Any
open import Function
import Relation.Binary.InducedPreorders as Ind
open import Data.Product as Prod using (∃; _×_; _,_)
module Membership-old {c ℓ : Level} (S : Setoid c ℓ) where

  private
    open module  S = Setoid S using (_≈_) renaming (Carrier to A)
    open module LS = Setoid (ListEq.setoid S)
      using () renaming (_≈_ to _≋_)

  -- If a predicate P respects the underlying equality then Any P
  -- respects the list equality.

  lift-resp : ∀ {p} {P : A → Set p} →
              P Respects _≈_ → Any P Respects _≋_
  lift-resp resp []            ()
  lift-resp resp (x≈y ∷ xs≈ys) (here px)   = here (resp x≈y px)
  lift-resp resp (x≈y ∷ xs≈ys) (there pxs) =
    there (lift-resp resp xs≈ys pxs)

  -- List membership.

  infix 4 _∈_ _∉_

  _∈_ : A → List A → Set _
  x ∈ xs = Any (_≈_ x) xs

  _∉_ : A → List A → Set _
  x ∉ xs = ¬ x ∈ xs

  -- Subsets.

  infix 4 _⊆_ _⊈_

  _⊆_ : List A → List A → Set _
  xs ⊆ ys = ∀ {x} → x ∈ xs → x ∈ ys

  _⊈_ : List A → List A → Set _
  xs ⊈ ys = ¬ xs ⊆ ys

  -- Equality is respected by the predicate which is used to define
  -- _∈_.

  ∈-resp-≈ : ∀ {x} → (_≈_ x) Respects _≈_
  ∈-resp-≈ = flip S.trans

  -- List equality is respected by _∈_.

  ∈-resp-list-≈ : ∀ {x} → _∈_ x Respects _≋_
  ∈-resp-list-≈ = lift-resp ∈-resp-≈

  -- _⊆_ is a preorder.

  ⊆-preorder : Preorder _ _ _
  ⊆-preorder = Ind.InducedPreorder₂ (ListEq.setoid S) _∈_ ∈-resp-list-≈

  module ⊆-Reasoning where
    import Relation.Binary.PreorderReasoning as PreR
    open PreR ⊆-preorder public
      renaming (_∼⟨_⟩_ to _⊆⟨_⟩_)

    infix 1 _∈⟨_⟩_

    _∈⟨_⟩_ : ∀ x {xs ys} → x ∈ xs → xs IsRelatedTo ys → x ∈ ys
    x ∈⟨ x∈xs ⟩ xs⊆ys = (begin xs⊆ys) x∈xs

  -- A variant of List.map.

  map-with-∈ : ∀ {b} {B : Set b}
               (xs : List A) → (∀ {x} → x ∈ xs → B) → List B
  map-with-∈ []       f = []
  map-with-∈ (x ∷ xs) f = f (here S.refl) ∷ map-with-∈ xs (f ∘ there)

  -- Finds an element satisfying the predicate.

  find : ∀ {p} {P : A → Set p} {xs} →
         Any P xs → ∃ λ x → x ∈ xs × P x
  find (here px)   = (_ , here S.refl , px)
  find (there pxs) = Prod.map id (Prod.map there id) (find pxs)

  lose : ∀ {p} {P : A → Set p} {x xs} →
         P Respects _≈_ → x ∈ xs → P x → Any P xs
  lose resp x∈xs px = Data.List.Any.map (flip resp px) x∈xs


------------------------------------------------------------------------
-- The Agda standard library
--
-- Relations between properties of functions, such as associativity and
-- commutativity
------------------------------------------------------------------------

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

open import Relation.Binary using (Rel; Setoid; Substitutive; Symmetric; Total)

module Algebra.FunctionProperties.Consequences
  {a ℓ} (S : Setoid a ℓ) where

open Setoid S renaming (Carrier to A)

open import Algebra.FunctionProperties _≈_
open import Data.Sum using (inj₁; inj₂)
open import Data.Product using (_,_)
import Relation.Binary.Consequences as Bin
open import Relation.Binary.Reasoning.Setoid S
open import Relation.Unary using (Pred)

------------------------------------------------------------------------
-- Re-export core properties

open import Algebra.FunctionProperties.Consequences.Core public

------------------------------------------------------------------------
-- Magma-like structures

module _ {_•_ : Op₂ A} (comm : Commutative _•_) where

  comm+cancelˡ⇒cancelʳ : LeftCancellative _•_ →  RightCancellative _•_
  comm+cancelˡ⇒cancelʳ cancelˡ {x} y z eq = cancelˡ x (begin
    x • y ≈⟨ comm x y ⟩
    y • x ≈⟨ eq ⟩
    z • x ≈⟨ comm z x ⟩
    x • z ∎)

  comm+cancelʳ⇒cancelˡ : RightCancellative _•_ → LeftCancellative _•_
  comm+cancelʳ⇒cancelˡ cancelʳ x {y} {z} eq = cancelʳ y z (begin
    y • x ≈⟨ comm y x ⟩
    x • y ≈⟨ eq ⟩
    x • z ≈⟨ comm x z ⟩
    z • x ∎)

------------------------------------------------------------------------
-- Monoid-like structures

module _ {_•_ : Op₂ A} (comm : Commutative _•_) {e : A} where

  comm+idˡ⇒idʳ : LeftIdentity e _•_ → RightIdentity e _•_
  comm+idˡ⇒idʳ idˡ x = begin
    x • e ≈⟨ comm x e ⟩
    e • x ≈⟨ idˡ x ⟩
    x     ∎

  comm+idʳ⇒idˡ : RightIdentity e _•_ → LeftIdentity e _•_
  comm+idʳ⇒idˡ idʳ x = begin
    e • x ≈⟨ comm e x ⟩
    x • e ≈⟨ idʳ x ⟩
    x     ∎

  comm+zeˡ⇒zeʳ : LeftZero e _•_ → RightZero e _•_
  comm+zeˡ⇒zeʳ zeˡ x = begin
    x • e ≈⟨ comm x e ⟩
    e • x ≈⟨ zeˡ x ⟩
    e     ∎

  comm+zeʳ⇒zeˡ : RightZero e _•_ → LeftZero e _•_
  comm+zeʳ⇒zeˡ zeʳ x = begin
    e • x ≈⟨ comm e x ⟩
    x • e ≈⟨ zeʳ x ⟩
    e     ∎

------------------------------------------------------------------------
-- Group-like structures

module _ {_•_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (comm : Commutative _•_) where

  comm+invˡ⇒invʳ : LeftInverse e _⁻¹ _•_ → RightInverse e _⁻¹ _•_
  comm+invˡ⇒invʳ invˡ x = begin
    x • (x ⁻¹) ≈⟨ comm x (x ⁻¹) ⟩
    (x ⁻¹) • x ≈⟨ invˡ x ⟩
    e          ∎

  comm+invʳ⇒invˡ : RightInverse e _⁻¹ _•_ → LeftInverse e _⁻¹ _•_
  comm+invʳ⇒invˡ invʳ x = begin
    (x ⁻¹) • x ≈⟨ comm (x ⁻¹) x ⟩
    x • (x ⁻¹) ≈⟨ invʳ x ⟩
    e          ∎

module _ {_•_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (cong : Congruent₂ _•_) where

  assoc+id+invʳ⇒invˡ-unique : Associative _•_ →
                              Identity e _•_ → RightInverse e _⁻¹ _•_ →
                              ∀ x y → (x • y) ≈ e → x ≈ (y ⁻¹)
  assoc+id+invʳ⇒invˡ-unique assoc (idˡ , idʳ) invʳ x y eq = begin
    x                ≈⟨ sym (idʳ x) ⟩
    x • e            ≈⟨ cong refl (sym (invʳ y)) ⟩
    x • (y • (y ⁻¹)) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩
    (x • y) • (y ⁻¹) ≈⟨ cong eq refl ⟩
    e • (y ⁻¹)       ≈⟨ idˡ (y ⁻¹) ⟩
    y ⁻¹             ∎

  assoc+id+invˡ⇒invʳ-unique : Associative _•_ →
                              Identity e _•_ → LeftInverse e _⁻¹ _•_ →
                              ∀ x y → (x • y) ≈ e → y ≈ (x ⁻¹)
  assoc+id+invˡ⇒invʳ-unique assoc (idˡ , idʳ) invˡ x y eq = begin
    y                ≈⟨ sym (idˡ y) ⟩
    e • y            ≈⟨ cong (sym (invˡ x)) refl ⟩
    ((x ⁻¹) • x) • y ≈⟨ assoc (x ⁻¹) x y ⟩
    (x ⁻¹) • (x • y) ≈⟨ cong refl eq ⟩
    (x ⁻¹) • e       ≈⟨ idʳ (x ⁻¹) ⟩
    x ⁻¹             ∎

----------------------------------------------------------------------
-- Bisemigroup-like structures

module _ {_•_ _◦_ : Op₂ A}
         (◦-cong : Congruent₂ _◦_)
         (•-comm : Commutative _•_)
         where

  comm+distrˡ⇒distrʳ :  _•_ DistributesOverˡ _◦_ → _•_ DistributesOverʳ _◦_
  comm+distrˡ⇒distrʳ distrˡ x y z = begin
    (y ◦ z) • x       ≈⟨ •-comm (y ◦ z) x ⟩
    x • (y ◦ z)       ≈⟨ distrˡ x y z ⟩
    (x • y) ◦ (x • z) ≈⟨ ◦-cong (•-comm x y) (•-comm x z) ⟩
    (y • x) ◦ (z • x) ∎

  comm+distrʳ⇒distrˡ : _•_ DistributesOverʳ _◦_ → _•_ DistributesOverˡ _◦_
  comm+distrʳ⇒distrˡ distrˡ x y z = begin
    x • (y ◦ z)       ≈⟨ •-comm x (y ◦ z) ⟩
    (y ◦ z) • x       ≈⟨ distrˡ x y z ⟩
    (y • x) ◦ (z • x) ≈⟨ ◦-cong (•-comm y x) (•-comm z x) ⟩
    (x • y) ◦ (x • z) ∎

  comm⇒sym[distribˡ] : ∀ x → Symmetric (λ y z → (x ◦ (y • z)) ≈ ((x ◦ y) • (x ◦ z)))
  comm⇒sym[distribˡ] x {y} {z} prf = begin
    x ◦ (z • y)       ≈⟨ ◦-cong refl (•-comm z y) ⟩
    x ◦ (y • z)       ≈⟨ prf ⟩
    (x ◦ y) • (x ◦ z) ≈⟨ •-comm (x ◦ y) (x ◦ z) ⟩
    (x ◦ z) • (x ◦ y) ∎

----------------------------------------------------------------------
-- Ring-like structures

module _ {_+_ _*_ : Op₂ A}
         {_⁻¹ : Op₁ A} {0# : A}
         (+-cong : Congruent₂ _+_)
         (*-cong : Congruent₂ _*_)
         where

  assoc+distribʳ+idʳ+invʳ⇒zeˡ : Associative _+_ → _*_ DistributesOverʳ _+_ →
                                RightIdentity 0# _+_ → RightInverse 0# _⁻¹ _+_ →
                                LeftZero 0# _*_
  assoc+distribʳ+idʳ+invʳ⇒zeˡ +-assoc distribʳ idʳ invʳ  x = begin
    0# * x                                 ≈⟨ sym (idʳ _) ⟩
    (0# * x) + 0#                          ≈⟨ +-cong refl (sym (invʳ _)) ⟩
    (0# * x) + ((0# * x)  + ((0# * x)⁻¹))  ≈⟨ sym (+-assoc _ _ _) ⟩
    ((0# * x) +  (0# * x)) + ((0# * x)⁻¹)  ≈⟨ +-cong (sym (distribʳ _ _ _)) refl ⟩
    ((0# + 0#) * x) + ((0# * x)⁻¹)         ≈⟨ +-cong (*-cong (idʳ _) refl) refl ⟩
    (0# * x) + ((0# * x)⁻¹)                ≈⟨ invʳ _ ⟩
    0#                                     ∎

  assoc+distribˡ+idʳ+invʳ⇒zeʳ : Associative _+_ → _*_ DistributesOverˡ _+_ →
                                RightIdentity 0# _+_ → RightInverse 0# _⁻¹ _+_ →
                                RightZero 0# _*_
  assoc+distribˡ+idʳ+invʳ⇒zeʳ +-assoc distribˡ idʳ invʳ  x = begin
     x * 0#                                ≈⟨ sym (idʳ _) ⟩
     (x * 0#) + 0#                         ≈⟨ +-cong refl (sym (invʳ _)) ⟩
     (x * 0#) + ((x * 0#) + ((x * 0#)⁻¹))  ≈⟨ sym (+-assoc _ _ _) ⟩
     ((x * 0#) + (x * 0#)) + ((x * 0#)⁻¹)  ≈⟨ +-cong (sym (distribˡ _ _ _)) refl ⟩
     (x * (0# + 0#)) + ((x * 0#)⁻¹)        ≈⟨ +-cong (*-cong refl (idʳ _)) refl ⟩
     ((x * 0#) + ((x * 0#)⁻¹))             ≈⟨ invʳ _ ⟩
     0#                                    ∎

------------------------------------------------------------------------
-- Without Loss of Generality

module _ {p} {f : Op₂ A} {P : Pred A p}
         (≈-subst : Substitutive _≈_ p)
         (comm : Commutative f)
         where

  subst+comm⇒sym : Symmetric (λ a b → P (f a b))
  subst+comm⇒sym = ≈-subst P (comm _ _)

  wlog : ∀ {r} {_R_ : Rel _ r} → Total _R_ →
         (∀ a b → a R b → P (f a b)) →
         ∀ a b → P (f a b)
  wlog r-total = Bin.wlog r-total subst+comm⇒sym


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Functions.Definition
open import Boolean.Definition

open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Vectors

module Logic.PropositionalLogic where

data Propositions {a : _} (primitives : Set a) : Set a where
  ofPrimitive : primitives → Propositions primitives
  false : Propositions primitives
  implies : (a b : Propositions primitives) → Propositions primitives

prNot : {a : _} {pr : Set a} → Propositions pr → Propositions pr
prNot p = implies p false

impliesIsBigger : {a : _} {pr : Set a} {P Q : Propositions pr} → Q ≡ implies P Q → False
impliesIsBigger {P = P} {Q} ()

impliesInjectiveL : {a : _} {A : Set a} → {p q r : Propositions A} → implies p q ≡ implies r q → p ≡ r
impliesInjectiveL refl = refl

impliesInjectiveR : {a : _} {A : Set a} → {p q r : Propositions A} → implies p q ≡ implies p r → q ≡ r
impliesInjectiveR refl = refl

impliesInjective : {a : _} {A : Set a} → {p q r s : Propositions A} → implies p q ≡ implies r s → (p ≡ r) && (q ≡ s)
impliesInjective refl = refl ,, refl

record Valuation {a : _} (primitives : Set a) : Set a where
  field
    v : Propositions primitives → Bool
    vFalse : v false ≡ BoolFalse
    vImplicationF : {p q : Propositions primitives} → v p ≡ BoolTrue → v q ≡ BoolFalse → v (implies p q) ≡ BoolFalse
    vImplicationVacuous : {p q : Propositions primitives} → v p ≡ BoolFalse → v (implies p q) ≡ BoolTrue
    vImplicationT : {p q : Propositions primitives} → v q ≡ BoolTrue → v (implies p q) ≡ BoolTrue

-- Proposition 1a
valuationIsDetermined : {a : _} {pr : Set a} → (v1 v2 : Valuation pr) → ({x : pr} → Valuation.v v1 (ofPrimitive x) ≡ Valuation.v v2 (ofPrimitive x)) → {x : Propositions pr} → Valuation.v v1 x ≡ Valuation.v v2 x
valuationIsDetermined v1 v2 pr {ofPrimitive x} = pr
valuationIsDetermined v1 v2 pr {false} rewrite Valuation.vFalse v1 | Valuation.vFalse v2 = refl
valuationIsDetermined v1 v2 pr {implies x y} with valuationIsDetermined v1 v2 pr {x}
valuationIsDetermined v1 v2 pr {implies x y} | eqX with valuationIsDetermined v1 v2 pr {y}
... | eqY with inspect (Valuation.v v1 x)
valuationIsDetermined v1 v2 pr {implies x y} | eqX | eqY | BoolTrue with≡ p with inspect (Valuation.v v1 y)
valuationIsDetermined v1 v2 pr {implies x y} | eqX | eqY | BoolTrue with≡ p | BoolTrue with≡ q rewrite p | q | Valuation.vImplicationT v2 {p = x} {q = y} (equalityCommutative eqY) | Valuation.vImplicationT v1 {p = x} {q = y} q = refl
valuationIsDetermined v1 v2 pr {implies x y} | eqX | eqY | BoolTrue with≡ p | BoolFalse with≡ q rewrite p | q | Valuation.vImplicationF v1 p q | Valuation.vImplicationF v2 (equalityCommutative eqX) (equalityCommutative eqY) = refl
valuationIsDetermined v1 v2 pr {implies x y} | eqX | eqY | BoolFalse with≡ p rewrite p | Valuation.vImplicationVacuous v1 {q = y} p | Valuation.vImplicationVacuous v2 {q = y} (equalityCommutative eqX) = refl

extendValuationV : {a : _} {pr : Set a} → (w : pr → Bool) → Propositions pr → Bool
extendValuationV w (ofPrimitive x) = w x
extendValuationV w false = BoolFalse
extendValuationV w (implies x y) with extendValuationV w x
... | BoolTrue with extendValuationV w y
extendValuationV w (implies x y) | BoolTrue | BoolTrue = BoolTrue
... | BoolFalse = BoolFalse
extendValuationV w (implies x y) | BoolFalse = BoolTrue

extendValuation : {a : _} {pr : Set a} → (w : pr → Bool) → Valuation pr
Valuation.v (extendValuation w) = extendValuationV w
Valuation.vFalse (extendValuation w) = refl
Valuation.vImplicationF (extendValuation w) {p} {q} pT qF with Valuation.v (extendValuation w) p
Valuation.vImplicationF (extendValuation w) {p} {q} refl qF | BoolTrue with Valuation.v (extendValuation w) q
Valuation.vImplicationF (extendValuation w) {p} {q} refl () | BoolTrue | BoolTrue
Valuation.vImplicationF (extendValuation w) {p} {q} refl refl | BoolTrue | BoolFalse = refl
Valuation.vImplicationF (extendValuation w) {p} {q} () qF | BoolFalse
Valuation.vImplicationVacuous (extendValuation w) {p} {q} pF with Valuation.v (extendValuation w) p
Valuation.vImplicationVacuous (extendValuation w) {p} {q} () | BoolTrue
Valuation.vImplicationVacuous (extendValuation w) {p} {q} refl | BoolFalse = refl
Valuation.vImplicationT (extendValuation w) {p} {q} qT with Valuation.v (extendValuation w) p
Valuation.vImplicationT (extendValuation w) {p} {q} qT | BoolTrue with Valuation.v (extendValuation w) q
Valuation.vImplicationT (extendValuation w) {p} {q} refl | BoolTrue | BoolTrue = refl
Valuation.vImplicationT (extendValuation w) {p} {q} () | BoolTrue | BoolFalse
Valuation.vImplicationT (extendValuation w) {p} {q} qT | BoolFalse = refl

-- Proposition 1b
valuationsAreFree : {a : _} {pr : Set a} → (w : pr → Bool) → {x : pr} → Valuation.v (extendValuation w) (ofPrimitive x) ≡ w x
valuationsAreFree w = refl

Tautology : {a : _} {pr : Set a} (prop : Propositions pr) → Set a
Tautology {pr = pr} prop = (v : Valuation pr) → Valuation.v v prop ≡ BoolTrue

record IsSubset {a b : _} (sub : Set a) (super : Set b) : Set (a ⊔ b) where
  field
    ofElt : sub → super

mapProp : {a b : _} {pr1 : Set a} {pr2 : Set b} → (pr1 → pr2) → Propositions pr1 → Propositions pr2
mapProp f (ofPrimitive x) = ofPrimitive (f x)
mapProp f false = false
mapProp f (implies p q) = implies (mapProp f p) (mapProp f q)

inheritedValuation : {a b : _} {sub : Set a} {super : Set b} → (IsSubset sub super) → Valuation super → Valuation sub
Valuation.v (inheritedValuation isSub v) prop = Valuation.v v (mapProp (IsSubset.ofElt isSub) prop)
Valuation.vFalse (inheritedValuation isSub v) = Valuation.vFalse v
Valuation.vImplicationF (inheritedValuation isSub v) pT qF = Valuation.vImplicationF v pT qF
Valuation.vImplicationVacuous (inheritedValuation isSub v) pF = Valuation.vImplicationVacuous v pF
Valuation.vImplicationT (inheritedValuation isSub v) qT = Valuation.vImplicationT v qT

inheritedValuation' : {a b : _} {sub : Set a} {super : Set b} → (IsSubset sub (Propositions super)) → Valuation super → (x : sub) → Bool
inheritedValuation' subset v x = Valuation.v v (IsSubset.ofElt subset x)

Entails : {a b : _} {sub : Set a} {super : Set b} (S : IsSubset sub (Propositions super)) (P : Propositions super) → Set (a ⊔ b)
Entails {sub = sub} {super = super} S P = {v : Valuation super} → ({s : sub} → inheritedValuation' S v s ≡ BoolTrue) → Valuation.v v P ≡ BoolTrue

data ThreeElements : Set where
  One : ThreeElements
  Two : ThreeElements
  Three : ThreeElements

indexAxiom : {a : _} (A : Set a) → ThreeElements → Set a
indexAxiom A One = Propositions A && Propositions A
indexAxiom A Two = Propositions A & Propositions A & Propositions A
indexAxiom A Three = Propositions A

indexPropositionalAxioms : {a : _} {A : Set a} → Set a
indexPropositionalAxioms {A = A} = Sg ThreeElements (indexAxiom A)

-- An axiom system is simply a subset of a set of propositions.
propositionalAxioms : {a : _} {A : Set a} → IsSubset (indexPropositionalAxioms {A = A}) (Propositions A)
IsSubset.ofElt propositionalAxioms (One , (p ,, q)) = implies p (implies q p)
IsSubset.ofElt propositionalAxioms (Two , record { one = p ; two = q ; three = r }) = implies (implies p (implies q r)) (implies (implies p q) (implies p r))
IsSubset.ofElt propositionalAxioms (Three , p) = implies (prNot (prNot p)) p

record Selection {a : _} {A : Set a} {n : ℕ} (l : Vec A n) : Set a where
  field
    element : A
    position : ℕ
    pos<N : position <N n
    elementIsAt : vecIndex l position pos<N ≡ element

data Proof {a b c : _} {A : Set a} {axioms : Set b} (axiomsSubset : IsSubset axioms (Propositions A)) {givens : Set c} (givensSubset : IsSubset givens (Propositions A)) : (n : ℕ) → Set (a ⊔ b ⊔ c)
data ProofStep {a b c : _} {A : Set a} {axioms : Set b} (axiomsSubset : IsSubset axioms (Propositions A)) {givens : Set c} (givensSubset : IsSubset givens (Propositions A)) {n : ℕ} (proofSoFar : Proof {a} {b} {c} {A} {axioms} axiomsSubset {givens} givensSubset n) : Set (a ⊔ b ⊔ c)

toSteps : {a b c : _} {A : Set a} {axioms : Set b} {axiomsSubset : IsSubset axioms (Propositions A)} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} {n : ℕ} (pr : Proof {axioms = axioms} axiomsSubset {givens = givens} givensSubset n) → Vec (Propositions A) n

data ProofStep {a} {b} {c} {A} {axioms} axiomsSubset {givens} givensSubset proofSoFar where
  axiom : axioms → ProofStep axiomsSubset givensSubset proofSoFar
  given : givens → ProofStep axiomsSubset givensSubset proofSoFar
  modusPonens : (implication : Selection (toSteps proofSoFar)) → (argument : Selection (toSteps proofSoFar)) → (conclusion : Propositions A) → (Selection.element implication ≡ implies (Selection.element argument) conclusion) → ProofStep axiomsSubset givensSubset proofSoFar
data Proof {a} {b} {c} {A} {axioms} axiomsSubset {givens} givensSubset where
  empty : Proof axiomsSubset givensSubset 0
  nextStep : (n : ℕ) → (previous : Proof {axioms = axioms} axiomsSubset {givens = givens} givensSubset n) → ProofStep axiomsSubset givensSubset previous → Proof axiomsSubset givensSubset (succ n)

toSteps empty = []
toSteps {axiomsSubset = axiomsSubset} (nextStep n pr (axiom x)) = (IsSubset.ofElt axiomsSubset x) ,- toSteps pr
toSteps {givensSubset = givensSubset} (nextStep n pr (given x)) = IsSubset.ofElt givensSubset x ,- toSteps pr
toSteps (nextStep n pr (modusPonens implication argument conclusion x)) = conclusion ,- toSteps pr

record Proves {a b c : _} {A : Set a} {axioms : Set b} (axiomsSubset : IsSubset axioms (Propositions A)) {givens : Set c} (givensSubset : IsSubset givens (Propositions A)) (P : Propositions A) : Set (a ⊔ b ⊔ c) where
  field
    n : ℕ
    proof : Proof axiomsSubset givensSubset (succ n)
    ofStatement : vecIndex (toSteps proof) 0 (succIsPositive n) ≡ P

addSingletonSet : {a : _} → Set a → Set a
addSingletonSet A = True || A

interpretSingletonSet : {a b c : _} {A : Set a} {B : Set b} {C : Set c} → IsSubset A B → (c : C) → (addSingletonSet A) → C || B
interpretSingletonSet A<B c (inl x) = inl c
interpretSingletonSet A<B _ (inr x) = inr (IsSubset.ofElt A<B x)

inrInjective : {a b : _} {A : Set a} {B : Set b} {b1 b2 : B} → inr {a = a} {A = A} b1 ≡ inr b2 → b1 ≡ b2
inrInjective refl = refl

singletonSubset : {a b c : _} {A : Set a} {B : Set b} {C : Set c} → IsSubset A B → (c : C) → IsSubset (addSingletonSet A) (C || B)
IsSubset.ofElt (singletonSubset subs c) = interpretSingletonSet subs c

adjoinGiven : {a b : _} {A : Set a} {givens : Set b} (givensSubset : IsSubset givens A) (P : A) → IsSubset (addSingletonSet givens) A
IsSubset.ofElt (adjoinGiven record { ofElt = ofElt } P) (inl x) = P
IsSubset.ofElt (adjoinGiven record { ofElt = ofElt } _) (inr x) = ofElt x

vecIndexRefl : {a : _} {A : Set a} {n : ℕ} {v1 v2 : Vec A n} → {pos : ℕ} → {pos<N1 pos<N2 : pos <N n} → v1 ≡ v2 → vecIndex v1 pos pos<N1 ≡ vecIndex v2 pos pos<N2
vecIndexRefl {v1 = v1} {.v1} {pos} {pos<N1} {pos<N2} refl = refl

{-
proofRemainsValidOnAddingGivens : {a b c : _} {A : Set a} {axioms : Set b} {axiomsSubset : IsSubset axioms (Propositions A)} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} {n : ℕ} → {Q : Propositions A} → Proof axiomsSubset givensSubset n → Proof axiomsSubset (adjoinGiven givensSubset Q) n
pr' : {a b c : _} {A : Set a} {axioms : Set b} {axiomsSubset : IsSubset axioms (Propositions A)} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} {n : ℕ} → {Q : Propositions A} → (pr : Proof axiomsSubset givensSubset n) → toSteps pr ≡ toSteps (proofRemainsValidOnAddingGivens {Q = Q} pr)

pr' empty = refl
pr' (nextStep n pr (axiom x)) rewrite pr' pr = refl
pr' (nextStep n pr (given x)) rewrite pr' pr = refl
pr' (nextStep n pr (modusPonens implication argument conclusion x)) rewrite pr' pr = refl

proofRemainsValidOnAddingGivens {Q = Q} empty = empty
proofRemainsValidOnAddingGivens {Q = Q} (nextStep n pr (axiom x)) = nextStep n (proofRemainsValidOnAddingGivens pr) (axiom x)
proofRemainsValidOnAddingGivens {Q = Q} (nextStep n pr (given x)) = nextStep n (proofRemainsValidOnAddingGivens pr) (given (inr x))
proofRemainsValidOnAddingGivens {A = A} {axiomsSubset = axiomsSubset} {givensSubset = givensSubset} {Q = Q} (nextStep n pr (modusPonens implication argument conclusion x)) = nextStep n (proofRemainsValidOnAddingGivens pr) (modusPonens (record { element = Selection.element implication ; position = Selection.position implication ; pos<N = Selection.pos<N implication ; elementIsAt = lemma implication }) (record { element = Selection.element argument ; position = Selection.position argument ; pos<N = Selection.pos<N argument ; elementIsAt = lemma argument }) conclusion x)
  where
    lemma : (sel : Selection (toSteps pr)) → vecIndex (toSteps (proofRemainsValidOnAddingGivens pr)) (Selection.position sel) (Selection.pos<N sel) ≡ Selection.element sel
    lemma sel with proofRemainsValidOnAddingGivens {Q = Q} pr
    ... | nextStep n bl x = {!!}
-}

{-

proofImpliesProves : {a b c : _} {A : Set a} {axioms : Set b} {axiomsSubset : IsSubset axioms (Propositions A)} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} {n : ℕ} (0<n : 0 <N n) → (p : Proof axiomsSubset givensSubset n) → (pr : Propositions A) → vecIndex (toSteps p) 0 0<n ≡ pr → Proves axiomsSubset givensSubset pr
proofImpliesProves {n = zero} () p pr x
proofImpliesProves {n = succ n} _ p pr x = record { n = n ; proof = p ; ofStatement = transitivity (vecIndexRefl {v1 = toSteps p} refl) x }

deductionTheorem' : {a b c : _} {A : Set a} {axioms : Set b} {axiomsSubset : IsSubset axioms (Propositions A)} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} {n : ℕ} → {P Q : Propositions A} → Proves axiomsSubset givensSubset (implies P Q) → Proves axiomsSubset {givens = addSingletonSet givens} (adjoinGiven givensSubset P) Q
Proves.n (deductionTheorem' record { n = n ; proof = proof ; ofStatement = ofStatement }) = succ (succ n)
Proves.proof (deductionTheorem' {P = P} {Q = Q} record { n = n ; proof = proof ; ofStatement = ofStatement }) = nextStep (succ (succ n)) (nextStep (succ n) (proofRemainsValidOnAddingGivens proof) (given (inl record {}))) (modusPonens (record { element = implies P Q ; position = 1 ; pos<N = succPreservesInequality (succIsPositive _) ; elementIsAt = transitivity (equalityCommutative (vecIndexRefl (pr' proof))) ofStatement }) (record { element = P ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) Q refl)
Proves.ofStatement (deductionTheorem' record { n = n ; proof = proof ; ofStatement = ofStatement }) = refl

deductionTheorem : {a b c : _} {A : Set a} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} {n : ℕ} → {P Q : Propositions A} → Proves propositionalAxioms {givens = addSingletonSet givens} (adjoinGiven givensSubset P) Q → Proves propositionalAxioms givensSubset (implies P Q)
deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (axiom x)) ; ofStatement = ofStatement } = {!!}
--... | bl = record { n = {!!} ; proof = nextStep (succ (succ (succ n))) (nextStep (succ (succ n)) (nextStep (succ n) {!deductionTheorem proof!} (axiom x)) (axiom (One , (Q ,, P)))) (modusPonens (record { element = implies Q (implies P Q) ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) (record { element = Q ; position = 1 ; pos<N = succPreservesInequality (succIsPositive _) ; elementIsAt = ofStatement }) (implies P Q) refl) ; ofStatement = {!!} }
deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (given x)) ; ofStatement = ofStatement } = {!!}
deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (modusPonens implication argument conclusion x)) ; ofStatement = ofStatement } = {!!}
{-
Proves.n (deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (axiom x)) ; ofStatement = ofStatement }) = succ (succ (succ n))
Proves.proof (deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (axiom x)) ; ofStatement = ofStatement }) = nextStep (succ (succ (succ n))) (nextStep (succ (succ n)) (nextStep (succ n) {!!} (axiom x)) (axiom (One , (Q ,, P)))) (modusPonens (record { element = implies Q (implies P Q) ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) (record { element = Q ; position = 1 ; pos<N = succPreservesInequality (succIsPositive _) ; elementIsAt = ofStatement }) (implies P Q) refl)
Proves.ofStatement (deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (axiom x)) ; ofStatement = ofStatement }) = {!!}
deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (given x)) ; ofStatement = ofStatement } = {!!}
deductionTheorem {P = P} {Q} record { n = n ; proof = (nextStep .n proof (modusPonens implication argument conclusion x)) ; ofStatement = ofStatement } = {!!}

-}

propositionalLogicSound : {a b c : _} {A : Set a} {givens : Set c} {givensSubset : IsSubset givens (Propositions A)} → {P : Propositions A} → Proves propositionalAxioms givensSubset P → Entails givensSubset P
Entails.entails (propositionalLogicSound {P = .(IsSubset.ofElt propositionalAxioms x)} record { n = .0 ; proof = (nextStep .0 empty (axiom x)) ; ofStatement = refl }) {v} values = propositionalAxiomsTautology x {v}
Entails.entails (propositionalLogicSound {P = P} record { n = .0 ; proof = (nextStep .0 empty (given x)) ; ofStatement = ofStatement }) {v} values rewrite equalityCommutative ofStatement = values {x}
Entails.entails (propositionalLogicSound {P = P} record { n = .0 ; proof = (nextStep .0 empty (modusPonens record { element = element ; position = zero ; pos<N = (le x₁ ()) ; elementIsAt = elementIsAt } argument conclusion x)) ; ofStatement = ofStatement }) {v} values
Entails.entails (propositionalLogicSound {P = P} record { n = .0 ; proof = (nextStep .0 empty (modusPonens record { element = element ; position = (succ position) ; pos<N = (le x₁ ()) ; elementIsAt = elementIsAt } argument conclusion x)) ; ofStatement = ofStatement }) {v} values
Entails.entails (propositionalLogicSound {P = P} record { n = .(succ n) ; proof = (nextStep .(succ n) (nextStep n proof y) x) ; ofStatement = ofStatement }) {v} values = {!!}

-}


open import Common.Equality
open import Common.Prelude hiding (pred)

pred : Nat → Nat
pred = _∸ 1

T : Bool → Set
T = if_then ⊤ else ⊥

if : {A : Set} (b : Bool) → A → A → A
if b = if b then_else_

test₁ : Nat → Nat
test₁ = 5 +_

test₁-test : ∀ x → test₁ x ≡ 5 + x
test₁-test _ = refl

test₂ : Nat → Nat
test₂ = _* 5

test₂-test : ∀ x → test₂ x ≡ x * 5
test₂-test _ = refl

infixr 9 _∘_

_∘_ : {A B C : Set} → (B → C) → (A → B) → (A → C)
f ∘ g = λ x → f (g x)

test₃ : Nat → Nat
test₃ = (_* 5) ∘ (6 +_) ∘ (2 ∸_)

test₃-test : ∀ x → test₃ x ≡ (6 + (2 ∸ x)) * 5
test₃-test _ = refl

infixr 0 _⊚_

_⊚_ : {A B C : Set} → (B → C) → (A → B) → (A → C)
f ⊚ g = λ x → f (g x)

test₃½ : Nat → Nat
test₃½ = _* 5 ⊚ 6 +_ ⊚ 2 ∸_

test₃½-test : ∀ x → test₃½ x ≡ (6 + (2 ∸ x)) * 5
test₃½-test _ = refl

test₄ : Nat → Nat → Nat
test₄ = Common.Prelude.if true then_else_

test₄-test : ∀ x y → test₄ x y ≡ x
test₄-test _ _ = refl

test₅ : Bool → Nat
test₅ = if_then 2 else 3

test₅-test : ∀ x → test₅ x ≡ (if x then 2 else 3)
test₅-test _ = refl

postulate
  foo_bar_ : (b₁ b₂ : Bool) → if b₁ then Nat else if b₂ then Bool else Nat

test₆ : (b : Bool) → if b then Bool else Nat
test₆ = foo false bar_

test₆-test : ∀ x → test₆ x ≡ (foo false bar x)
test₆-test _ = refl

test₇ : Nat → Nat
test₇ = (Common.Prelude._+ 2) ∘ (1 Common.Prelude.∸_)

test₇-test : ∀ x → test₇ x ≡ (1 Common.Prelude.∸ x) Common.Prelude.+ 2
test₇-test _ = refl

_test₈_ : Nat → Nat → Nat
_test₈_ = _*_

test₈-test : ∀ x y → (x test₈ y) ≡ x * y
test₈-test _ _ = refl

test₉ : Nat → Nat → Nat
test₉ = Common.Prelude._*_

test₉-test : ∀ x y → test₉ x y ≡ x Common.Prelude.* y
test₉-test _ _ = refl

data D : Set₂ where
  ⟨_⟩_ : Set → Set₁ → D

Test₁₀ : D → Set
Test₁₀ (⟨_⟩_ X _) = X

Test₁₁ : Set → Set
Test₁₁ ⟨_⟩ = ⟨_⟩

postulate
  ⟦_⟧ : Set → Set

Test₁₂ : Set → Set
Test₁₂ A = ⟦_⟧ A

Test₁₂-test : ∀ X → Test₁₂ X ≡ ⟦ X ⟧
Test₁₂-test _ = refl

module M where

  _! : Set₁ → Set₁
  X ! = X

Test₁₃ : Set₁
Test₁₃ = M._! Set

Test₁₄ : (x : Nat → Nat) → x ≡ suc → Set₁
Test₁₄ .(1 +_) refl = Set

_$_ : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → A → B
f $ x = f x

test₁₅ : (((⊤ → Bool) → Bool) → Nat) → Nat
test₁₅ = _$ _$ _

postulate
  -_  : Nat → Nat
  _-_ : Nat → Nat → Nat

test₁₆ : Nat → Nat
test₁₆ = (-_)

test₁₆-test : ∀ x → test₁₆ x ≡ (- x)
test₁₆-test _ = refl

test₁₇ : (f : Nat → Nat) → f ≡ suc → Set₁
test₁₇ .(1 +_) refl = Set

test₁₈ : (section : Nat) → section +_ ≡ λ x → section + x
test₁₈ section = refl


-- {-# OPTIONS --safe #-}
module Time where

open import Map
open import Relation.Binary.PropositionalEquality
open import Data.String using (String)
open import Data.Nat
open import Data.Nat.Base using (_≤_)
open import Data.Bool using (true ; false)
open import Data.Bool.Base using (if_then_else_)
open import Data.Maybe using (Maybe; just; nothing)
open import Agda.Builtin.Unit
open import Data.Empty
open import Relation.Nullary using (¬_)
open import Data.Product using (_×_)
open import Data.List
open import Data.Nat.Properties
open import Language
open import Function.Base using (_$_)

max : ∀ (m n : ℕ) → ℕ
max m n with (m ≤? n)
... | false Relation.Nullary.because _ = m
... | true Relation.Nullary.because _ = n

taeval : (Γ : (String → ℕ)) → (Aexp {ℕ}) → ℕ
taeval Γ (a +` a₁) = taeval Γ a + taeval Γ a₁ + (Γ "+")
taeval Γ (a -` a₁) = taeval Γ a + taeval Γ a₁ + (Γ "-")
taeval Γ (a *` a₁) = taeval Γ a + taeval Γ a₁ + (Γ "*")
taeval Γ (Avar x) = 1           -- Just look up in memory assuming 1
                                -- clock cycle
taeval Γ (Anum x) = 1           -- Just look up in mem is 1 clock cycle

tbeval : (Γ : (String → ℕ)) → (Bexp {ℕ}) → ℕ
tbeval Γ TRUE = Γ "TRUE"
tbeval Γ FALSE = Γ "FALSE"
tbeval Γ (x1 <` x2) = aeval Γ x1 + aeval Γ x2 + (Γ "<")
tbeval Γ (x1 >` x2) = aeval Γ x1 + aeval Γ x2 + (Γ ">")
tbeval Γ (x1 ≤` x2) = aeval Γ x1 + aeval Γ x2 + (Γ "≤")
tbeval Γ (x1 ≥` x2) = aeval Γ x1 + aeval Γ x2 + (Γ "≥")
tbeval Γ (x1 ≡` x2) = aeval Γ x1 + aeval Γ x2 + (Γ "≡")
tbeval Γ (¬` b) = tbeval Γ b + (Γ "NOT")
tbeval Γ (b &&` b₁) = tbeval Γ b + tbeval Γ b₁ + (Γ "AND")
tbeval Γ (b ||` b₁) = tbeval Γ b + tbeval Γ b₁ + (Γ "OR")

-- Making the tuple type needed to hold the program
data TProgTuple {A : Set} : Set where
  _,_,_,_ : (a : ATuple) → (r : RTuple) → (c : Cmd {A}) → (cmt : ℕ) → TProgTuple

-- Getting stuff from the TProgTuple
getProgCmdT : {A : Set} → (p : Maybe (TProgTuple {A})) → Cmd {A}
getProgCmdT (just (_ , _ , c , _)) = c
getProgCmdT nothing = SKIP       -- Dangerous

getProgArgsT : {A : Set} → (p : Maybe (TProgTuple {A})) → ATuple
getProgArgsT (just (a , _ , _ , _)) = a
getProgArgsT nothing = Arg "VOID"

getProgRetsT : {A : Set} → (p : Maybe (TProgTuple {A})) → RTuple
getProgRetsT (just (_ , r , _ , _)) = r
getProgRetsT nothing = Ret "VOID"

getProgTimeT : {A : Set} → (p : Maybe (TProgTuple {A})) → ℕ
getProgTimeT (just (_ , _ , _ , t)) = t
getProgTimeT nothing = 0

data _,_=[_]=>ᴬ_  (Γ : (String → ℕ)) : ℕ → (ATuple) → ℕ → Set where

  hd : ∀ (W : ℕ) → ∀ (v : String) →
       Γ , W =[ Arg v ]=>ᴬ (W + (Γ "arg-copy"))

  tl : (l r : ATuple) → (W W' W'' : ℕ) →
       (Γ , W =[ l ]=>ᴬ (W + W')) → (Γ , W + W' =[ r ]=>ᴬ (W + W' + W'')) →
        -----------------------------------------------------------
        Γ , W =[ (l ,` r) ]=>ᴬ (W + W' + W'')

numargs : ∀ (args : ATuple) → ℕ
numargs (Arg v) = 1
numargs (args ,` args₁) = numargs args + numargs args₁

-- soundness theorem for arg copy
args-sound : ∀ (Γ : (String → ℕ)) → ∀ (args : ATuple) → (W W' : ℕ)
             → (Γ , W =[ args ]=>ᴬ W')
             → (W + numargs args * (Γ "arg-copy")) ≡ W'
args-sound Γ .(Arg v) W .(W + Γ "arg-copy") (hd .W v)
  rewrite +-comm (Γ "arg-copy") 0 = refl
args-sound Γ .(l ,` r) W .(W + W' + W'') (tl l r .W W' W'' cmd cmd₁)
  with (Γ "arg-copy") in eq
... | u rewrite *-distribʳ-+ u (numargs l) (numargs r)
    | +-comm W (((numargs l) * u) + ((numargs r) * u))
    | +-comm ((numargs l) * u) ((numargs r) * u)
    | +-assoc ((numargs r) * u) ((numargs l) * u) W
    | +-comm ((numargs l) * u) W
    | +-comm ((numargs r) * u) (W + ((numargs l) * u))
    with args-sound Γ l W (W + W') cmd
... | j with args-sound Γ r (W + W') (W + W' + W'') cmd₁
... | k with +-cancelˡ-≡ W j | +-cancelˡ-≡ (W + W') k | eq
... | refl | refl | refl = refl

data _,_=[_]=>ᴿ_  (Γ : (String →  ℕ)) : ℕ → RTuple → ℕ  → Set where
  hd : ∀ (W : ℕ) → ∀ (v : String) →
       Γ , W =[ Ret v ]=>ᴿ (W + (Γ "ret-copy"))

  tl : (l r : RTuple) → (W W' W'' : ℕ) →
       (Γ , W =[ l ]=>ᴿ (W + W')) → (Γ , W + W' =[ r ]=>ᴿ (W + W' + W'')) →
        -----------------------------------------------------------
        Γ , W =[ (l ,` r) ]=>ᴿ (W + W' + W'')

numrets : ∀ (rets : RTuple) → ℕ
numrets (Ret v) = 1
numrets (rets ,` rets₁) = numrets rets + numrets rets₁

-- soundness theorem for ret copy
rets-sound : ∀ (Γ : (String → ℕ)) → ∀ (rets : RTuple) → (W W' : ℕ)
             → Γ , W =[ rets ]=>ᴿ W'
             → (W + numrets rets * (Γ "ret-copy")) ≡ W'
rets-sound Γ .(Ret v) W .(W + Γ "ret-copy") (hd .W v)
  rewrite +-comm (Γ "ret-copy") 0 = refl
rets-sound Γ .(l ,` r) W .(W + W' + W'') (tl l r .W W' W'' cmd cmd₁)
  with (Γ "ret-copy") in eq
... | u rewrite *-distribʳ-+ u (numrets l) (numrets r)
    | +-comm W (((numrets l) * u) + ((numrets r) * u))
    | +-comm ((numrets l) * u) ((numrets r) * u)
    | +-assoc ((numrets r) * u) ((numrets l) * u) W
    | +-comm ((numrets l) * u) W
    | +-comm ((numrets r) * u) (W + ((numrets l) * u))
    with rets-sound Γ l W (W + W') cmd
... | j with rets-sound Γ r (W + W') (W + W' + W'') cmd₁
... | k with +-cancelˡ-≡ W j | +-cancelˡ-≡ (W + W') k | eq
... | refl | refl | refl = refl

mutual
-- Semantics of time from here
 data _,_,_=[_]=>_ (Γ : (String → Maybe (TProgTuple {ℕ}))) (st : String → ℕ) :
           ℕ → Cmd {ℕ} → ℕ → Set where
  TSKIP : ∀ (W : ℕ) → Γ , st , W =[ SKIP ]=> (W + 0)

  TASSIGN : ∀ (X : String) → ∀ (n : ℕ) → ∀ (e : Aexp {ℕ})
           → ∀ (W : ℕ) →
           ---------------------------------
           Γ , st ,  W =[ (Var X := e) ]=> (W + (taeval st e) + (st "store"))

  TSEQ : ∀ (c1 c2 : Cmd {ℕ})
        → ∀ (W W' W'' : ℕ)
        → Γ , st , W =[ c1 ]=> (W + W')
        → Γ , st , (W + W') =[ c2 ]=> (W + (W' + W'')) →
        --------------------------------------------
        Γ , st ,  W =[ c1 ; c2 ]=> (W + (W' + W''))

  -- XXX: Hack, st contains both exec time and state!
  TIFT : (n1 : ℕ) → (b : Bexp {ℕ}) →
        (t e : Cmd {ℕ}) → ∀ (W W' W'' : ℕ)
        → (beval st b ≡ true)
        → Γ , st , W =[ t ]=> (W + W')
        → Γ , st , W =[ e ]=> (W + W'')
        → Γ , st , W =[ (IF b THEN t ELSE e END) ]=>
          (W + W' + (tbeval st b))

  TIFE : (n1 : ℕ) → (b : Bexp {ℕ}) →
        (t e : Cmd {ℕ}) → ∀ (W W' W'' : ℕ)
        → (beval st b ≡ false)
        → Γ , st , W =[ t ]=> (W + W')
        → Γ , st , W =[ e ]=> (W + W'')
        → Γ , st , W =[ (IF b THEN t ELSE e END) ]=>
          (W +  W'' + (tbeval st b))

  TLF :  (b : Bexp {ℕ}) → (c : Cmd {ℕ}) →
        beval st b ≡ false →
        ∀ (W : ℕ) →
        -----------------------------------------------------------
        Γ , st , W =[ (WHILE b DO c END) ]=>
        (W + 0 + (tbeval st b))

  TLT :  (b : Bexp {ℕ}) → (c : Cmd {ℕ}) →
        beval st b ≡ true → ∀ (W W' : ℕ) →
        -----------------------------------------------------------
        Γ , st , W =[ c ]=> (W + W') →
        Γ , st , W =[ (WHILE b DO c END) ]=>
        (W + ((st "loop-count") * (W' + (tbeval st b))) + (tbeval st b))

 -- CEX : ∀ (f : FuncCall {ℕ}) → ∀ (st st' : (String → ℕ))
 --       → Γ , st =[ f ]=>ᶠ st'
 --       -----------------------------------------------------------
 --       → Γ , st =[ EXEC f ]=> st'

 data _,_,_=[_]=>ᶠ_ (Γ : String → (Maybe (TProgTuple {ℕ})))
                    (st : String → ℕ) :
                    ℕ → FuncCall {ℕ} → ℕ → Set where

  Base : ∀ (fname : String) →        -- name of the function
         ∀ (W W' W'' W''' : ℕ)

         -- time to put args on function stack
         → st , W =[ getProgArgsT (Γ fname) ]=>ᴬ (W + W')

         -- Proof that WCET is what we have in the tuple
         → (wcet-is : (getProgTimeT (Γ fname)) ≡ W'')
         -- time to run the function
         → Γ , st , (W + W') =[ getProgCmdT (Γ fname) ]=> (W + W' + W'')

         -- copying ret values back on caller' stack
         → st , (W + W' + W'')
              =[ getProgRetsT (Γ fname) ]=>ᴿ (W + W' + W'' + W''')

         -----------------------------------------------------------
         → Γ , st , W =[ < getProgRetsT (Γ fname) >:=
             fname < getProgArgsT (Γ fname) > ]=>ᶠ (W + W' + W'' + W''')

  PAR : ∀ (l r : FuncCall {ℕ}) → ∀ (W X1 X2 : ℕ)
        → Γ , st , W =[ l ]=>ᶠ (W + X1)
        → Γ , st , W =[ r ]=>ᶠ (W + X2)
        -----------------------------------------------------------
        → Γ , st , W =[ l ||` r ]=>ᶠ (W + (max X1 X2) + ((2 * (st "fork"))
                                        + (2 * (st "join"))))

-- Soundness theorem for SKIP WCET rule
skip-sound : (Γ : String → Maybe (TProgTuple {ℕ}))
           → (Γᵗ : String → ℕ)  -- map of labels to execution times
           → ∀ (W W' X : ℕ) → (cmd : Γ , Γᵗ , W =[ SKIP ]=> W')
           → (W ≡ X) → (W' ≡ X)
skip-sound Γ Γᵗ W .(W + 0) .W (TSKIP .W) refl rewrite +-comm W 0 = refl

-- Soundness theorem for Assign WCET rule
assign-sound : (Γ : String → Maybe (TProgTuple {ℕ}))
             → (Γᵗ : (String → ℕ))
             → (S : String) → (e : Aexp {ℕ})
             → (W W' : ℕ) → (cmd : Γ , Γᵗ , W =[ Var S := e ]=> W')
             → (W' ≡ W + (taeval Γᵗ e) + (Γᵗ "store"))
assign-sound Γ Γᵗ S e W .(W + taeval Γᵗ e + Γᵗ "store") (TASSIGN .S n .e .W)
  = refl

-- Deterministic exec
Δ-exec : (Γ : String → Maybe (TProgTuple {ℕ}))
         → (Γᵗ : String → ℕ)
         → ∀ (W W' W'' : ℕ) → (c1 : Cmd {ℕ})
         → (Γ , Γᵗ , W =[ c1 ]=> W')
         → (Γ , Γᵗ , W =[ c1 ]=> W'')
         → W' ≡ W''
Δ-exec Γ Γᵗ W .(W + taeval Γᵗ e + Γᵗ "store")
  .(W + taeval Γᵗ e + Γᵗ "store") (Var X := e) (TASSIGN .X n₁ .e .W)
  (TASSIGN .X n .e .W) = refl
Δ-exec Γ Γᵗ W .(W + 0) .(W + 0) .SKIP (TSKIP .W) (TSKIP .W) = refl
Δ-exec Γ Γᵗ W .(W + (W' + W''')) .(W + (W'' + W''''))
 .(c1 ; c2) (TSEQ c1 c2 .W W' W''' p1 p3) (TSEQ .c1 .c2 .W W'' W'''' p2 p4)
 with Δ-exec Γ Γᵗ W (W + W') (W + W'') c1 p1 p2
... | r with +-cancelˡ-≡ W r
... | refl
 with Δ-exec Γ Γᵗ (W + W') (W + (W' + W''')) (W + (W' + W'''')) c2 p3 p4
... | rr with +-cancelˡ-≡ W rr
... | rm with +-cancelˡ-≡ W' rm
... | refl = refl
Δ-exec Γ Γᵗ W .(W + 0 + tbeval Γᵗ b)
  .(W + 0 + tbeval Γᵗ b) WHILE b DO c END (TLF .b .c x .W)
  (TLF .b .c x₁ .W) = refl
Δ-exec Γ Γᵗ W .(W + Γᵗ "loop-count" * (W' + tbeval Γᵗ b) + _)
  .(W + 0 + tbeval Γᵗ b) WHILE b DO c END (TLT .b .c x .W W' x₂)
  (TLF .b .c x₁ .W) = ⊥-elim (contradiction-lemma b Γᵗ x x₁)
Δ-exec Γ Γᵗ W .(W + 0 + tbeval Γᵗ b)
  .(W + Γᵗ "loop-count" * (W'' + tbeval Γᵗ b) + _) WHILE b DO c END
  (TLF .b .c x .W) (TLT .b .c x₁ .W W'' x₂)
  = ⊥-elim (contradiction-lemma b Γᵗ x₁ x)
Δ-exec Γ Γᵗ W .(W + Γᵗ "loop-count" * (W' + tbeval Γᵗ b) + _)
  .(W + Γᵗ "loop-count" * (W'' + tbeval Γᵗ b) + _) WHILE b DO c END
  (TLT .b .c x .W W' x₃) (TLT .b .c x₁ .W W'' x₂)
  with Δ-exec Γ Γᵗ W (W + W') (W + W'') c x₃ x₂
... | l with +-cancelˡ-≡ W l
... | refl = refl
Δ-exec Γ Γᵗ W .(W + W' + tbeval Γᵗ b)
  .(W + W'' + tbeval Γᵗ b) IF b THEN t ELSE e END
  (TIFT n2 .b .t .e .W W' W'''' x x₄ x₅)
  (TIFT n1 .b .t .e .W W'' W''' x₁ x₂ x₃)
  with Δ-exec Γ Γᵗ W (W + W') (W + W'') t x₄ x₂
... | y with +-cancelˡ-≡ W y
... | refl = refl
Δ-exec Γ Γᵗ W .(W + W'''' + tbeval Γᵗ b)
  .(W + W'' + tbeval Γᵗ b) IF b THEN t ELSE e END
  (TIFE n2 .b .t .e .W W' W'''' x x₄ x₅)
  (TIFT n1 .b .t .e .W W'' W''' x₁ x₂ x₃)
  = ⊥-elim (contradiction-lemma b Γᵗ x₁ x)
Δ-exec Γ Γᵗ W .(W + W' + tbeval Γᵗ b)
  .(W + W''' + tbeval Γᵗ b) IF b THEN t ELSE e END
  (TIFT n2 .b .t .e .W W' W'''' x x₄ x₅)
  (TIFE n1 .b .t .e .W W'' W''' x₁ x₂ x₃)
  = ⊥-elim (contradiction-lemma b Γᵗ x x₁)
Δ-exec Γ Γᵗ W .(W + W'''' + tbeval Γᵗ b)
  .(W + W''' + tbeval Γᵗ b) IF b THEN t ELSE e END
  (TIFE n2 .b .t .e .W W' W'''' x x₄ x₅)
  (TIFE n1 .b .t .e .W W'' W''' x₁ x₂ x₃)
  with Δ-exec Γ Γᵗ W (W + W''') (W + W'''') e x₃ x₅
... | y with +-cancelˡ-≡ W y
... | refl = refl

-- Deterministic execution of a function
Δ-exec-func : (Γ : String → Maybe (TProgTuple {ℕ}))
              → (Γᵗ : String → ℕ) → (l : FuncCall {ℕ})
              → (W W' W'' : ℕ)
              → Γ , Γᵗ , W =[ l ]=>ᶠ W'
              → Γ , Γᵗ , W =[ l ]=>ᶠ W''
              → W' ≡ W''
Δ-exec-func Γ Γᵗ
  .(< getProgRetsT (Γ fname) >:= fname < getProgArgsT (Γ fname) >) W
  .(W + W' + getProgTimeT (Γ fname) + W'''')
  .(W + W'' + getProgTimeT (Γ fname) + W'''''')
  (Base fname .W W' .(getProgTimeT (Γ fname)) W'''' x refl x₁ x₂)
  (Base .fname .W W'' .(getProgTimeT (Γ fname)) W'''''' x₃ refl x₄ x₅)
  with args-sound Γᵗ (getProgArgsT (Γ fname)) W (W + W') x
  | args-sound Γᵗ (getProgArgsT (Γ fname)) W (W + W'') x₃
  | rets-sound Γᵗ (getProgRetsT (Γ fname)) (W + W' + getProgTimeT (Γ fname))
    (W + W' + getProgTimeT (Γ fname) + W'''') x₂
  | rets-sound Γᵗ (getProgRetsT (Γ fname)) (W + W'' + getProgTimeT (Γ fname))
    (W + W'' + getProgTimeT (Γ fname) + W'''''') x₅
... | l | l1 | r1 | r2
  with +-cancelˡ-≡ W l | +-cancelˡ-≡ W l1
... | refl | refl with +-cancelˡ-≡
  (W + numargs (getProgArgsT (Γ fname)) * Γᵗ "arg-copy"
  + getProgTimeT (Γ fname)) r2
... | refl with +-cancelˡ-≡
  (W + numargs (getProgArgsT (Γ fname)) * Γᵗ "arg-copy"
  + getProgTimeT (Γ fname)) r1
... | refl = refl
Δ-exec-func Γ Γᵗ .(l ||` r) W
  .(W + max X1 X2 + (2 * Γᵗ "fork" + 2 * Γᵗ "join"))
  .(W + max X3 X4 + (2 * Γᵗ "fork" + 2 * Γᵗ "join"))
  (PAR l r .W X1 X2 e1 e3) (PAR .l .r .W X3 X4 e2 e4)
  with Δ-exec-func Γ Γᵗ l W (W + X1) (W + X3) e1 e2
  | Δ-exec-func Γ Γᵗ r W (W + X2) (W + X4) e3 e4
... | m | y with +-cancelˡ-≡ W m | +-cancelˡ-≡ W y
... | refl | refl = refl

skip-cancel : ∀ (Γ : String → Maybe (TProgTuple {ℕ}))
               → (Γᵗ : String → ℕ)
               → ∀ (W1 W2 X1 X2 : ℕ)
               → (Γ , Γᵗ , W1 =[ SKIP ]=> (W1 + X1))
               → (Γ , Γᵗ , W2 =[ SKIP ]=> (W2 + X2))
               → X1 ≡ X2
skip-cancel Γ Γᵗ W1 W2 X1 X2 p1 p2 with (W1 + X1) in eq1
skip-cancel Γ Γᵗ W1 W2 X1 X2 (TSKIP .W1) p2 | .(W1 + 0)
  with +-cancelˡ-≡ W1 eq1
skip-cancel Γ Γᵗ W1 W2 X1 X2 (TSKIP .W1) p2 | .(W1 + 0) | refl
  with (W2 + X2) in eq2
skip-cancel Γ Γᵗ W1 W2 _ X2 (TSKIP .W1) (TSKIP .W2)
  | .(W1 + _) | refl | .(W2 + 0) with +-cancelˡ-≡ W2 eq2
... | refl = refl

assign-cancel : ∀ (Γ : String → Maybe (TProgTuple {ℕ}))
               → (Γᵗ : String → ℕ)
               → ∀ (W1 W2 X1 X2 : ℕ)
               → (S : String) → (e : Aexp {ℕ})
               → (Γ , Γᵗ , W1 =[ Var S := e ]=> (W1 + X1))
               → (Γ , Γᵗ , W2 =[ Var S := e ]=> (W2 + X2))
               → X1 ≡ X2
assign-cancel Γ Γᵗ W1 W2 X1 X2 S e cmd1 cmd2 with (W1 + X1) in eq1
  | (W2 + X2) in eq2
assign-cancel Γ Γᵗ W1 W2 X1 X2 S e (TASSIGN .S n .e .W1)
  (TASSIGN .S n₁ .e .W2) | .(W1 + taeval Γᵗ e + Γᵗ "store")
  | .(W2 + taeval Γᵗ e + Γᵗ "store")
  rewrite +-assoc W1 (taeval Γᵗ e) (Γᵗ "store")
  | +-assoc W2 (taeval Γᵗ e) (Γᵗ "store")
  with +-cancelˡ-≡ W1 eq1 | +-cancelˡ-≡ W2 eq2
... | refl | refl = refl

loop-cancel : ∀ (Γ : String → Maybe (TProgTuple {ℕ}))
               → (Γᵗ : String → ℕ)
               → ∀ (W1 W2 X1 X2 : ℕ)
               → (b : Bexp {ℕ})
               → (c : Cmd {ℕ})
               → (Γ , Γᵗ , W1 =[ (WHILE b DO c END) ]=> (W1 + X1))
               → (Γ , Γᵗ , W2 =[ (WHILE b DO c END) ]=> (W2 + X2))
               → X1 ≡ X2
ife-cancel : ∀ (Γ : String → Maybe (TProgTuple {ℕ}))
               → (Γᵗ : String → ℕ)
               → ∀ (W1 W2 X1 X2 : ℕ)
               → (b : Bexp {ℕ})
               → (t e : Cmd {ℕ})
               → (Γ , Γᵗ , W1 =[ ( IF b THEN t ELSE e END ) ]=> (W1 + X1))
               → (Γ , Γᵗ , W2 =[ ( IF b THEN t ELSE e END ) ]=> (W2 + X2))
               → X1 ≡ X2
seq-cancel : ∀ (Γ : String → Maybe (TProgTuple {ℕ}))
               → (Γᵗ : String → ℕ)
               → ∀ (W1 W2 X1 X2 : ℕ)
               → (c1 c2 : Cmd {ℕ})
               → (Γ , Γᵗ , W1 =[ ( c1 ; c2) ]=> (W1 + X1))
               → (Γ , Γᵗ , W2 =[ ( c1 ; c2) ]=> (W2 + X2))
               → X1 ≡ X2

-- The general case of cancellation.
eq-cancel : ∀ (Γ : String → Maybe (TProgTuple {ℕ}))
               → (Γᵗ : String → ℕ)
               → ∀ (c : Cmd {ℕ})
               → ∀ (W1 W2 X1 X2 : ℕ)
               → (Γ , Γᵗ , W1 =[ c ]=> (W1 + X1))
               → (Γ , Γᵗ , W2 =[ c ]=> (W2 + X2))
               → X1 ≡ X2

loop-cancel Γ Γᵗ W1 W2 X1 X2 b c cmd1 cmd2
  with (W1 + X1) in eq1 | (W2 + X2) in eq2
loop-cancel Γ Γᵗ W1 W2 X1 X2 b c (TLF .b .c x .W1)
  (TLF .b .c x₁ .W2) | .(W1 + 0 + tbeval Γᵗ b) | .(W2 + 0 + tbeval Γᵗ b)
  rewrite +-assoc W1 0 (tbeval Γᵗ b) | +-assoc W2 0 (tbeval Γᵗ b)
  with +-cancelˡ-≡ W1 eq1 | +-cancelˡ-≡ W2 eq2
... | refl | refl = refl
loop-cancel Γ Γᵗ W1 W2 X1 X2 b c (TLF .b .c x .W1)
  (TLT .b .c x₁ .W2 W' cmd2) | .(W1 + 0 + tbeval Γᵗ b)
  | .(W2 + Γᵗ "loop-count" * (W' + tbeval Γᵗ b) + tbeval Γᵗ b)
  = ⊥-elim (contradiction-lemma b Γᵗ x₁ x)
loop-cancel Γ Γᵗ W1 W2 X1 X2 b c (TLT .b .c x .W1 W' cmd1)
  (TLF .b .c x₁ .W2)
  | .(W1 + Γᵗ "loop-count" * (W' + tbeval Γᵗ b) + tbeval Γᵗ b)
  | .(W2 + 0 + tbeval Γᵗ b) = ⊥-elim (contradiction-lemma b Γᵗ x x₁)
loop-cancel Γ Γᵗ W1 W2 X1 X2 b c (TLT .b .c x .W1 W' cmd1)
  (TLT .b .c x₁ .W2 W'' cmd2)
  | .(W1 + Γᵗ "loop-count" * (W' + tbeval Γᵗ b) + tbeval Γᵗ b)
  | .(W2 + Γᵗ "loop-count" * (W'' + tbeval Γᵗ b) + tbeval Γᵗ b)
  with eq-cancel Γ Γᵗ c W1 W2 W' W'' cmd1 cmd2
... | refl with (Γᵗ "loop-count") | (tbeval Γᵗ b)
... | LC | BC rewrite +-assoc W2 (LC * (W' + BC)) BC
    | +-assoc W1 (LC * (W' + BC)) BC
    with +-cancelˡ-≡ W2 eq2 | +-cancelˡ-≡ W1 eq1
... | refl | refl = refl

ife-cancel Γ Γᵗ W1 W2 X1 X2 b t e p1 p2 with (W1 + X1) in eq1
  | (W2 + X2) in eq2
ife-cancel Γ Γᵗ W1 W2 X1 X2 b t e (TIFT n1 .b .t .e .W1 W' W'' x p1 p3)
  (TIFT n2 .b .t .e .W2 W''' W'''' x₁ p2 p4) | .(W1 + W' + tbeval Γᵗ b)
  | .(W2 + W''' + tbeval Γᵗ b) with eq-cancel Γ Γᵗ t W1 W2 W' W''' p1 p2
... | refl rewrite +-assoc W2 W' (tbeval Γᵗ b) | +-assoc W1 W' (tbeval Γᵗ b)
  with +-cancelˡ-≡ W2 eq2 | +-cancelˡ-≡ W1 eq1
... | refl | refl = refl
ife-cancel Γ Γᵗ W1 W2 X1 X2 b t e (TIFT n1 .b .t .e .W1 W' W'' x p1 p3)
  (TIFE n2 .b .t .e .W2 W''' W'''' x₁ p2 p4) | .(W1 + W' + tbeval Γᵗ b)
  | .(W2 + W'''' + tbeval Γᵗ b) = ⊥-elim (contradiction-lemma b Γᵗ x x₁)
ife-cancel Γ Γᵗ W1 W2 X1 X2 b t e (TIFE n1 .b .t .e .W1 W' W'' x p1 p3)
  (TIFT n2 .b .t .e .W2 W''' W'''' x₁ p2 p4) | .(W1 + W'' + tbeval Γᵗ b)
  | .(W2 + W''' + tbeval Γᵗ b) = ⊥-elim (contradiction-lemma b Γᵗ x₁ x)
ife-cancel Γ Γᵗ W1 W2 X1 X2 b t e (TIFE n1 .b .t .e .W1 W' W'' x p1 p3)
  (TIFE n2 .b .t .e .W2 W''' W'''' x₁ p2 p4) | .(W1 + W'' + tbeval Γᵗ b)
  | .(W2 + W'''' + tbeval Γᵗ b) rewrite +-assoc W1 W'' (tbeval Γᵗ b)
  | +-assoc W2 W'''' (tbeval Γᵗ b) with +-cancelˡ-≡ W2 eq2
  | +-cancelˡ-≡ W1 eq1 | eq-cancel Γ Γᵗ e W1 W2 W'' W'''' p3 p4
... | refl | refl | refl = refl

seq-cancel Γ Γᵗ W1 W2 X1 X2 c1 c2 p1 p2 with (W1 + X1) in eq1
  | (W2 + X2) in eq2
seq-cancel Γ Γᵗ W1 W2 X1 X2 c1 c2 (TSEQ .c1 .c2 .W1 W' W'' p1 p3)
  (TSEQ .c1 .c2 .W2 W''' W'''' p2 p4)
  | .(W1 + (W' + W'')) | .(W2 + (W''' + W''''))
  rewrite +-cancelˡ-≡ W1 eq1 | +-cancelˡ-≡ W2 eq2
  with eq-cancel Γ Γᵗ c1 W1 W2 W' W''' p1 p2
... | refl
  rewrite
     +-comm W'''  W''
     | +-comm W1 (W'' + W''') | +-assoc W'' W'''  W1 | +-comm W''' W1
     | +-comm W'' (W1 + W''') | +-comm W'''  W'''' | +-comm W2 (W'''' + W''')
     | +-assoc W'''' W'''  W2 | +-comm W''' W2 | +-comm W'''' (W2 + W''')
   with (W1 + W''') | (W2 + W''')
... | l | m
   with eq-cancel Γ Γᵗ c2 l m W'' W'''' p3 p4
... | refl  = refl

eq-cancel Γ Γᵗ SKIP W1 W2 X1 X2 p1 p2 = skip-cancel Γ Γᵗ W1 W2 X1 X2 p1 p2
eq-cancel Γ Γᵗ (Var x := r) W1 W2 X1 X2 p1 p2
  = assign-cancel Γ Γᵗ W1 W2 X1 X2 x r p1 p2
eq-cancel Γ Γᵗ (c ; c₁) W1 W2 X1 X2 p1 p2
  = seq-cancel Γ Γᵗ W1 W2 X1 X2 c c₁ p1 p2
eq-cancel Γ Γᵗ IF b THEN c ELSE c₁ END W1 W2 X1 X2 p1 p2
  = ife-cancel Γ Γᵗ W1 W2 X1 X2 b c c₁ p1 p2
eq-cancel Γ Γᵗ WHILE b DO c END W1 W2 X1 X2 p1 p2
  = loop-cancel Γ Γᵗ W1 W2 X1 X2 b c p1 p2

-- TODO: The function call case and concurrency cases will go here

-- Soundness theorem for Seq WCET rule
seq-sound : (Γ : String → Maybe (TProgTuple {ℕ}))
            → (Γᵗ : String → ℕ)
            → (c1 c2 : Cmd {ℕ})
            → (W X1 X2 W' : ℕ)
            → (cmd : Γ , Γᵗ , W =[ c1 ; c2 ]=> W')
            → (p1 : Γ , Γᵗ , W =[ c1 ]=> (W + X1))
            → (p2 : Γ , Γᵗ , W =[ c2 ]=> (W + X2))
            → (W' ≡ W + (X1 + X2))
seq-sound Γ Γᵗ c1 c2 W X1 X2 .(W + (W' + W''))
  (TSEQ .c1 .c2 .W W' W'' cmd cmd₁) p1 p2
  with Δ-exec Γ Γᵗ W (W + W') (W + X1) c1 cmd p1
... | q with +-cancelˡ-≡ W q
... | refl rewrite +-comm W (X1 + W'') | +-comm X1 W'' | +-assoc W'' X1 W
    | +-comm X1 W | +-comm W'' (W + X1) | +-comm X1 X2 | +-comm W (X2 + X1)
    | +-assoc X2 X1 W | +-comm X2 (X1 + W) | +-comm X1 W with (W + X1)
... | rl with eq-cancel Γ Γᵗ c2 rl W W'' X2 cmd₁ p2
... | refl = refl

-- Helping lemma for ife
plus-≤ : ∀ (m n p : ℕ) → (m ≤ n) → (m + p) ≤ (n + p)
plus-≤ .zero n p z≤n = m≤n+m p n
plus-≤ .(suc _) .(suc _) p (s≤s {m} {n} q) with plus-≤ m n p q
... | H0 = s≤s H0

≤-rela1 : ∀ (m n : ℕ) → ¬ (m ≤ n) → (n < m)
≤-rela1 zero n p = ⊥-elim (p z≤n)
≤-rela1 (suc m) zero p = s≤s z≤n
≤-rela1 (suc m) (suc n) p = s≤s (≤-rela1 m n (λ z → p (s≤s z)))

≤-rela2 : ∀ (m n : ℕ) → (suc n ≤ m) → (n ≤ m)
≤-rela2 m n p with n≤1+n n
... | q = ≤-trans q p

-- if-helper
if-helper : ∀ (X1 X2 : ℕ) → (X1 ≤ max X1 X2)
if-helper X1 X2 with (X1 ≤? X2)
... | false Relation.Nullary.because proof = ≤′⇒≤ ≤′-refl
... | true Relation.Nullary.because Relation.Nullary.ofʸ p = p

if-helper2 : ∀ (X1 X2 : ℕ) → (X2 ≤ max X1 X2)
if-helper2 X1 X2 with (X1 ≤? X2)
if-helper2 X1 X2 | false Relation.Nullary.because Relation.Nullary.ofⁿ ¬p
  with ≤-rela1 X1 X2 (¬p)
... | q = ≤-rela2 X1 X2 q
if-helper2 X1 X2 | true Relation.Nullary.because _ = ≤′⇒≤ ≤′-refl

-- Soundness theorem for If-else WCET rule
ife-sound : (Γ : String → Maybe (TProgTuple {ℕ}))
            → (Γᵗ : String → ℕ)
            → (t e : Cmd {ℕ})
            → (b : Bexp {ℕ})
            → (W X1 X2 W' : ℕ)
            → (tcmd : Γ , Γᵗ , W =[ t ]=> (W + X1))
            → (ecmd : Γ , Γᵗ , W =[ e ]=> (W + X2))
            → (cmd : Γ , Γᵗ , W =[ (IF b THEN t ELSE e END) ]=> W')
            → (W' ≤ W + (max X1 X2) + (tbeval Γᵗ b))
ife-sound Γ Γᵗ t e b W X1 X2 .(W + W' + tbeval Γᵗ b) tcmd ecmd
  (TIFT n1 .b .t .e .W W' W'' x cmd cmd₁)
  with Δ-exec Γ Γᵗ W (W + W') (W + X1) t cmd tcmd
... | l with +-cancelˡ-≡ W l
... | refl rewrite +-assoc W X1 (tbeval Γᵗ b) | +-comm W (X1 + (tbeval Γᵗ b))
    | +-assoc X1 (tbeval Γᵗ b) W with (tbeval Γᵗ b)
... | Y with max X1 X2 in eq
... | M rewrite +-assoc W M Y | +-comm W (M + Y) | +-assoc M Y W
    with (Y + W)
... | L with if-helper X1 X2 | eq
... | T | refl = plus-≤ X1 M L T
ife-sound Γ Γᵗ t e b W X1 X2 .(W + W'' + tbeval Γᵗ b) tcmd ecmd
  (TIFE n1 .b .t .e .W W' W'' x cmd cmd₁)
  with (tbeval Γᵗ b) | Δ-exec Γ Γᵗ W (W + W'') (W + X2) e cmd₁ ecmd
... | Y | l with +-cancelˡ-≡ W l
... | refl with max X1 X2 in eq
... | M rewrite +-assoc W X2 Y | +-assoc W M Y | +-comm W (X2 + Y)
    | +-comm W (M + Y) | +-assoc X2 Y W | +-assoc M Y W with (Y + W)
... | L with if-helper2 X1 X2 | eq
... | T | refl = plus-≤ X2 M L T

-- Helper for loop
loop-helper : ∀ (l g : ℕ) → (l ≤′ (g + l))
loop-helper l zero = ≤′-refl
loop-helper l (suc g) = ≤′-step (loop-helper l g)

-- XXX: Using well founded recursion here
loop-sound-≤′ : (Γ : String → Maybe (TProgTuple {ℕ}))
            → (Γᵗ : String → ℕ)
            → (c : Cmd {ℕ})
            → (b : Bexp {ℕ})
            → (W W' X1 : ℕ)
            → (Γ , Γᵗ , W =[ c ]=> (W + X1))
            → (cmd : Γ , Γᵗ , W =[ (WHILE b DO c END) ]=> W')
            → W' ≤′
              W + ((Γᵗ "loop-count") * (X1 + (tbeval Γᵗ b))) + (tbeval Γᵗ b)
loop-sound-≤′ Γ Γᵗ c b W .(W + 0 + tbeval Γᵗ b) X1 cmd (TLF .b .c x .W)
  with (Γᵗ "loop-count")
... | zero = ≤′-refl
... | suc m rewrite +-comm W 0
    with (tbeval Γᵗ b)
... | q
    with (X1 + q + m * (X1 + q))
... | t rewrite +-comm W t | +-assoc t W q with (W + q)
... | l = loop-helper l t
loop-sound-≤′  Γ Γᵗ c b W
  .(W + Γᵗ "loop-count" * (W' + tbeval Γᵗ b) + tbeval Γᵗ b) X1 cmd
  (TLT .b .c x .W W' cmd1)
  with Δ-exec Γ Γᵗ W (W + W') (W + X1) c cmd1 cmd
... | r with +-cancelˡ-≡ W r
... | refl = ≤′-refl

-- The general case
loop-sound : (Γ : String → Maybe (TProgTuple {ℕ}))
            → (Γᵗ : String → ℕ)
            → (c : Cmd {ℕ})
            → (b : Bexp {ℕ})
            → (W W' X1 : ℕ)
            → (Γ , Γᵗ , W =[ c ]=> (W + X1))
            → (cmd : Γ , Γᵗ , W =[ (WHILE b DO c END) ]=> W')
            → W' ≤
              W + ((Γᵗ "loop-count") * (X1 + (tbeval Γᵗ b))) + (tbeval Γᵗ b)
loop-sound Γ Γᵗ c b W W' X1 c2 cmd =
  ≤′⇒≤ (loop-sound-≤′ Γ Γᵗ c b W W' X1 c2 cmd)

-- The soundness theorem for a single function call
func-sound : (Γ : String → Maybe (TProgTuple {ℕ})) → ∀ (Γᵗ : String → ℕ)
             → ∀ (fname : String) → ∀ (W W' : ℕ)
             → Γ , Γᵗ , W =[ < getProgRetsT (Γ fname) >:=
                             fname < getProgArgsT (Γ fname) > ]=>ᶠ W'
             → W' ≡ (W +
                       ((numargs $ getProgArgsT $ (Γ fname)) * (Γᵗ "arg-copy"))
                    + (getProgTimeT (Γ fname))
                    + ((numrets $ getProgRetsT $ (Γ fname)) * (Γᵗ "ret-copy")))
func-sound Γ Γᵗ fname W .(W + W' + getProgTimeT (Γ fname) + W''')
  (Base .fname .W W' .(getProgTimeT (Γ fname)) W''' x refl x₁ x₂)
  with args-sound Γᵗ (getProgArgsT (Γ fname)) W (W + W') x
       | rets-sound Γᵗ (getProgRetsT (Γ fname))
         (W + W' + getProgTimeT (Γ fname))
         (W + W' + getProgTimeT (Γ fname) + W''') x₂
... | l | m with +-cancelˡ-≡ W l
... | refl
  with +-cancelˡ-≡ (W + numargs (getProgArgsT (Γ fname)) * Γᵗ "arg-copy"
                   + getProgTimeT (Γ fname)) m
... | refl = refl

-- The soundness theorem for PAR (||`) execution of threads
par-sound : (Γ : String → Maybe (TProgTuple {ℕ})) → ∀ (Γᵗ : String → ℕ)
            → (l r : FuncCall {ℕ}) → (W W' X1 X2 : ℕ)
            → Γ , Γᵗ , W =[ l ||` r ]=>ᶠ W'
            → Γ , Γᵗ , W =[ l ]=>ᶠ (W + X1)
            → Γ , Γᵗ , W =[ r ]=>ᶠ (W + X2)
            → W' ≡ W + (max X1 X2) + 2 * ((Γᵗ "fork") + (Γᵗ "join"))
par-sound Γ Γᵗ l r W .(W + max X3 X4 + (2 * Γᵗ "fork" + 2 * Γᵗ "join"))
  X1 X2 (PAR .l .r .W X3 X4 pare pare₁) parl parr
  with (Γᵗ "fork") | (Γᵗ "join")
... | tf | tj rewrite *-distribˡ-+ 2 tf tj
    | +-assoc tf tj 0 | +-comm tj 0 | +-comm tf 0
    | +-assoc tf tj (tf + tj) | +-comm tj (tf + tj)
    | +-assoc tf tj tj | +-comm tf (tf + (tj + tj))
    | +-comm tf (tj + tj) with (tf + tf + (tj + tj))
... | m with Δ-exec-func Γ Γᵗ l W (W + X1) (W + X3) parl pare
... | q with Δ-exec-func Γ Γᵗ r W (W + X2) (W + X4) parr pare₁
... | q2 with +-cancelˡ-≡ W q | +-cancelˡ-≡ W q2
... | refl | refl = refl


module Utils.Decidable where

open import Data.Nat
open import Data.Char
open import Data.String
open import Data.Bool
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable hiding (True; False)
open import Relation.Nullary
open import Data.Product
open import Data.Sum
open import Function
import Level as L

{-
A type class for decidable types.

The part we actually end up using in the formal semantics proofs is
mostly decidable equality (_≡⁇_).
-}

_=>_ : ∀ {α β} → Set α → Set β → Set (α L.⊔ β)
Dict => A = ⦃ _ : Dict ⦄ → A
infixr 5 _=>_

record Decidable {a}(A : Set a) : Set a where
  constructor rec
  field
    decide : Dec A

DecRel : ∀ {a b}{A : Set a}{B : Set b} → (A → B → Set (a L.⊔ b)) → Set (a L.⊔ b)
DecRel Rel = ∀ {x y} → Decidable (Rel x y)

DecEq : ∀ {a} → Set a → Set a
DecEq A = DecRel (_≡_ {_} {A})

_⁇ : ∀ {a} A → Decidable {a} A => Dec A
_⁇ A ⦃ dict ⦄ = Decidable.decide dict

_≡⁇_ : ∀ {a A} → DecEq {a} A => ((x y : A) → Dec (x ≡ y))
x ≡⁇ y = (x ≡ y) ⁇

True : ∀ {a} A → Decidable {a} A => Set
True A = T ⌊ A ⁇ ⌋

F : Bool → Set
F = T ∘ not

False : ∀ {a} A → Decidable {a} A => Set
False A = F ⌊ A ⁇ ⌋

_≤⁇_ : ∀ a b → Dec (a ≤ b)
_≤⁇_ = _≤?_

_<⁇_ : ∀ a b → Dec (a < b)
a <⁇ b = suc a ≤⁇ b

module _ where
  open import Data.Nat.Properties
  _≤′⁇_ : ∀ a b → Dec (a ≤′ b)
  _≤′⁇_ a b with a ≤⁇ b
  ... | yes p = yes (≤⇒≤′ p)
  ... | no  p = no (p ∘ ≤′⇒≤)

_<′⁇_ : ∀ a b → Dec (a <′ b)
a <′⁇ b = suc a ≤′⁇ b

instance
  DecEqBool : DecEq Bool
  DecEqBool = rec (_ Data.Bool.≟ _)

instance
  DecEqChar : DecEq Char
  DecEqChar = rec (_ Data.Char.≟ _)

module _ where
  open import Data.Fin
  open import Data.Fin.Properties

  instance
    DecEqFin : ∀ {n} → DecEq (Fin n)
    DecEqFin = rec (_ Data.Fin.Properties.≟ _)

instance
  DecEqℕ : DecEq ℕ
  DecEqℕ = rec (_ Data.Nat.≟ _)

instance
  DecEqString : DecEq String
  DecEqString = rec (_ Data.String.≟ _)

instance
  Decℕ≤ : DecRel _≤_
  Decℕ≤ = rec (_ ≤⁇ _)

instance
  Decℕ≤′ : DecRel _≤′_
  Decℕ≤′ = rec (_ ≤′⁇ _)

-- Conversions between decidable / boolean
--------------------------------------------------

T→∧ : ∀ {a b} → T (a ∧ b) → T a × T b
T→∧ {true} {true} x = _
T→∧ {true} {false} ()
T→∧ {false} ()

∧→T : ∀ {a b} → T a → T b → T (a ∧ b)
∧→T {true} {true} p1 p2 = _
∧→T {true} {false} p1 ()
∧→T {false} () p2

F-not-elim : ∀ {b} → F (not b) → T b
F-not-elim {true} p = p
F-not-elim {false} p = p

F-not-add : ∀ {b} → T b → F (not b)
F-not-add {true}  p = p
F-not-add {false} p = p

F-not-≡ : ∀ b → T b ≡ F (not b)
F-not-≡ true  = refl
F-not-≡ false = refl

TrueA→A : ∀ {a A}⦃ _ : Decidable {a} A ⦄ → True A → A
TrueA→A = toWitness

FalseA→¬A : ∀ {a A}⦃ _ : Decidable {a} A ⦄ → False A → ¬ A
FalseA→¬A = toWitnessFalse

A→TrueA : ∀ {a A}⦃ _ : Decidable {a} A ⦄ → A → True A
A→TrueA = fromWitness

¬A→FalseA : ∀ {a A}⦃ _ : Decidable {a} A ⦄ → ¬ A → False A
¬A→FalseA = fromWitnessFalse

T→≡true : ∀ {b} → T b → b ≡ true
T→≡true {true} p = refl
T→≡true {false} ()

≡true→T : ∀ {b} → b ≡ true → T b
≡true→T {true} p = _
≡true→T {false} ()

≡false→F : ∀ {b} → b ≡ false → F b
≡false→F {true} ()
≡false→F {false} p = _

F→≡false : ∀ {b} → F b → b ≡ false
F→≡false {true} ()
F→≡false {false} p = refl

A→≡true : ∀ {a A}{Q : Dec {a} A} → A → ⌊ Q ⌋ ≡ true
A→≡true = T→≡true ∘ fromWitness

¬A→≡false : ∀ {a A}{Q : Dec {a} A} → ¬ A → ⌊ Q ⌋ ≡ false
¬A→≡false = F→≡false ∘ fromWitnessFalse

≡true→A : ∀ {a A}{Q : Dec {a} A} → ⌊ Q ⌋ ≡ true → A
≡true→A = toWitness ∘ ≡true→T

≡false→¬A : ∀ {a A}{Q : Dec {a} A} → ⌊ Q ⌋ ≡ false → ¬ A
≡false→¬A = toWitnessFalse ∘ ≡false→F

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

instance
  Dec¬ :
    ∀ {α A}
    →  Decidable {α} A
    => Decidable (¬ A)

  Dec¬ {_}{A} = rec dec¬ where

    dec¬ : Dec (¬ A)
    dec¬ with A ⁇
    ... | yes p = no (λ z → z p)
    ... | no ¬p = yes ¬p

instance
  Dec⊎ :
    ∀ {α β A B}
    →  Decidable {α} A
    => Decidable {β} B
    => Decidable (A ⊎ B)

  Dec⊎ {_}{_}{A}{B} = rec dec⊎ where

    dec⊎ : Dec (A ⊎ B)
    dec⊎ with A ⁇ | B ⁇
    ... | yes p   | _      = yes (inj₁ p)
    ... | _       | yes p  = yes (inj₂ p)
    ... | no ¬p₁  | no ¬p₂ = no [ ¬p₁ , ¬p₂ ]′

instance
  Dec× :
    ∀ {α β A B}
    →  Decidable {α} A
    => Decidable {β} B
    => Decidable (A × B)

  Dec× {_}{_}{A}{B} = rec dec× where

    dec× : Dec (A × B)
    dec× with A ⁇ | B ⁇
    ... | yes p | yes p₁ = yes (p , p₁)
    ... | yes p | no ¬p  = no (¬p ∘ proj₂)
    ... | no ¬p | _      = no (¬p ∘ proj₁)


module Category.Functor.Const where
open import Category.Functor     using (RawFunctor    ; module RawFunctor    )
open import Category.Functor.Lawful
open import Relation.Binary.PropositionalEquality using (refl)

Const : ∀ {l₁ l₂} (R : Set l₂) (_ : Set l₁) → Set l₂
Const R _ = R

constFunctor : ∀ {l₁} {R : Set l₁} → RawFunctor (Const {l₁} R)
constFunctor = record { _<$>_ = λ _ z → z }

constLawfulFunctor : ∀ {l₁} {R : Set l₁} → LawfulFunctorImp (constFunctor {l₁} {R})
constLawfulFunctor = record { <$>-identity = refl ; <$>-compose = refl }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties, related to products, that rely on the K rule
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

module Data.Product.Properties.WithK where

open import Data.Product
open import Data.Product.Properties
open import Function
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- Equality

module _ {a b} {A : Set a} {B : Set b} where

  ,-injective : ∀ {a c : A} {b d : B} → (a , b) ≡ (c , d) → a ≡ c × b ≡ d
  ,-injective refl = refl , refl

module _ {a b} {A : Set a} {B : A → Set b} where

  ,-injectiveʳ : ∀ {a} {b c : B a} → (Σ A B ∋ (a , b)) ≡ (a , c) → b ≡ c
  ,-injectiveʳ refl = refl

  ≡-dec : Decidable _≡_ → (∀ {a} → Decidable {A = B a} _≡_) →
          Decidable {A = Σ A B} _≡_
  ≡-dec dec₁ dec₂ (a , x) (b , y) with dec₁ a b
  ... | no  a≢b  = no (a≢b ∘ ,-injectiveˡ)
  ... | yes refl with dec₂ x y
  ...   | no x≢y   = no (x≢y ∘ ,-injectiveʳ)
  ...   | yes refl = yes refl


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.S1.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.HITs.S1.Base
open import Cubical.HITs.PropositionalTruncation

isConnectedS¹ : (s : S¹) → ∥ base ≡ s ∥
isConnectedS¹ base = ∣ refl ∣
isConnectedS¹ (loop i) =
  squash ∣ (λ j → loop (i ∧ j)) ∣ ∣ (λ j → loop (i ∨ ~ j)) ∣ i

isGroupoidS¹ : isGroupoid S¹
isGroupoidS¹ s t =
  recPropTrunc isPropIsSet
    (λ p →
      subst (λ s → isSet (s ≡ t)) p
        (recPropTrunc isPropIsSet
          (λ q → subst (λ t → isSet (base ≡ t)) q isSetΩS¹)
          (isConnectedS¹ t)))
    (isConnectedS¹ s)


module Successor where

open import OscarPrelude

record Successor {ℓᴬ} (A : Set ℓᴬ) {ℓᴮ} (B : Set ℓᴮ) : Set (ℓᴬ ⊔ ℓᴮ)
 where
  field
    ⊹ : A → B

open Successor ⦃ … ⦄ public

instance SuccessorNat : Successor Nat Nat
Successor.⊹ SuccessorNat = suc

instance SuccessorLevel : Successor Level Level
Successor.⊹ SuccessorLevel = lsuc


----------------------------------------------------------------------------
-- Well-founded induction on the natural numbers
----------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.Induction.NonAcc.WF-I where

open import FOTC.Base

open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Well-founded induction
postulate
  <-wfind₁ : (A : D → Set) →
             (∀ {n} → N n → (∀ {m} → N m → m < n → A m) → A n) →
             ∀ {n} → N n → A n

postulate PN : ∀ {n m} → N n → m < n → N m

-- Well-founded induction removing N m from the second line.
<-wfind₂ : (A : D → Set) →
           (∀ {n} → N n → (∀ {m} → m < n → A m) → A n) →
           ∀ {n} → N n → A n
<-wfind₂ A h = <-wfind₁ A (λ Nn' h' → h Nn' (λ p → h' (PN Nn' p) p))

-- Well-founded induction removing N n from the second line.
<-wfind₃ : (A : D → Set) →
           (∀ {n} → (∀ {m} → N m → m < n → A m) → A n) →
           ∀ {n} → N n → A n
<-wfind₃ A h = <-wfind₁ A (λ Nn' h' → h h')


module Structure.Relator.Function.Proofs where

import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Functional
open import Structure.Relator.Function
open import Structure.Setoid
open import Structure.Setoid.Uniqueness
open import Structure.Relator.Properties
open import Structure.Relator
open import Type

private variable ℓ₁ ℓ₂ ℓ₃ ℓₗ ℓₒ ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₒ₄ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑ₄ : Lvl.Level

module _ {A : Type{ℓₒ₁}}{B : Type{ℓₒ₁ Lvl.⊔ ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ (φ : A → B → Stmt{ℓₗ}) ⦃ totality : Total(φ)⦄ ⦃ func : Function(φ)⦄ ⦃ _ : ∀{x} → UnaryRelator(φ(x)) ⦄ where
  -- There is a function for a binary relation that is total and function-like.
  relation-function-existence : ∃(f ↦ ∀{x}{y} → (f(x) ≡ y) ↔ φ(x)(y))
  relation-function-existence = [∃]-intro(f) ⦃ \{x y} → proof{x}{y} ⦄ where
    -- The function
    f : A → B
    f(x) = [∃]-witness(total(φ){x})

    -- Proof that the function returns the value that the binary relation defines the element from Y that an element from X is associated with.
    proof : ∀{x}{y} → (f(x) ≡ y) ↔ φ(x)(y)
    proof{x}{y} = [↔]-intro l r where
      r : (f(x) ≡ y) → φ(x)(y)
      r(fxy) = substitute₁(φ(x)) fxy ([∃]-proof(total(φ){x}))

      l : (f(x) ≡ y) ← φ(x)(y)
      l(φxy) = [∃!]-existence-eq-any(totalFunction(φ)) φxy

  -- Constructing a total function from a a binary operation with conditions.
  relation-function : A → B
  relation-function = [∃]-witness(relation-function-existence)

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ {f : A → B} where
  -- A function is total
  -- ∀{x} → ∃(y ↦ f(x) ≡ y)
  Function-totality : Total(x ↦ y ↦ f(x) ≡ y)
  Total.proof(Function-totality) {x} = [∃]-intro(f(x)) ⦃ reflexivity(_≡_) ⦄

module _ {X : Type{ℓₒ₁}} {Y : X → Type{ℓₒ₂}} {φ : (x : X) → Y(x) → Stmt{ℓₗ}} where
  -- Every binary predicate that have its first argument defined for all values
  -- have at least one choice function that can determine the second argument from the first.
  -- Proposition: ∀(X: Type)∀(Y: Type)∀(φ: X → Y → Stmt). (∀(x: X)∃(y: Y). φ(x)(y)) → (∃(choice: X → Y)∀(x: X). φ(x)(choice(x)))
  --   ∀(x: X)∃(y: Y). φ(x)(y) means that the predicate φ holds for every x and some y (which may depend on x). In other words: it associates every element in X with a subset of Y, a function (X → ℘(Y)).
  --   ∃(choice: X → Y)∀(x: X). φ(x)(choice(x)) means that there is a function that picks out a particular y.
  -- Note: This proposition can be recognised as one equivalent variant of "Axiom of Choice" from set theory when formulated in classical logic.
  -- Note: This is similar to what one does in the process of "Skolemization" for an existentially quantified formula in logic.
  dependent-function-predicate-choice : (∀{x : X} → ∃{Obj = Y(x)}(y ↦ φ(x)(y))) → ∃{Obj = (x : X) → Y(x)}(choice ↦ ∀{x : X} → φ(x)(choice(x)))
  dependent-function-predicate-choice(function) = [∃]-intro(x ↦ [∃]-witness(function{x})) ⦃ \{x} → [∃]-proof(function{x}) ⦄

module _ {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} {φ : X → Y → Stmt{ℓₗ}} where
  function-predicate-choice : (∀{x} → ∃(y ↦ φ(x)(y))) → ∃{Obj = X → Y}(choice ↦ ∀{x} → φ(x)(choice(x)))
  function-predicate-choice = dependent-function-predicate-choice

{-
module _ {ℓₗ₁ ℓₗ₂ ℓₒ} {X : Type{ℓₒ}} {P : (X → Stmt{ℓₗ₁}) → Stmt{ℓₗ₂}} where
  standard-choice : (∀{Q : X → Stmt{ℓₗ₁}} → P(Q) → (∃ P)) → ∃{Obj = (X → Stmt{ℓₗ₁}) → X}(f ↦ ∀{Q : X → Stmt{ℓₗ₁}} → P(Q) → Q(f(Q)))
  standard-choice ep = [∃]-intro (choice) ⦃ \{x} → proof{x} ⦄ where
    choice : (X → Stmt{ℓₗ₁}) → X
    choice(R) = [∃]-witness(ep{R} (pr))

    proof : ∀{Q : X → Stmt{ℓₗ₁}} → P(Q) → Q(choice(Q))
    proof{Q} pq = [∃]-proof(surjective{x})
-}


module Data.QuadTree.Implementation.Functors where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.QuadrantLenses

{-# FOREIGN AGDA2HS
{-# LANGUAGE Safe #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
import Data.Nat
import Data.Lens.Lens
import Data.Logic
import Data.QuadTree.Implementation.Definition
import Data.QuadTree.Implementation.ValidTypes
import Data.QuadTree.Implementation.QuadrantLenses
#-}

record FunctorEq (f : (y : Set) -> {{ eqT : Eq y }} -> Set) : Set₁ where
  field
    fmapₑ : {a b : Set} -> {{ eqA : Eq a }} {{ eqB : Eq b }} -> (a → b) → f a → f b
open FunctorEq public
{-# COMPILE AGDA2HS FunctorEq class #-}

quadrantFunctor : (dep : Nat) -> FunctorEq (λ y -> VQuadrant y {dep})
quadrantFunctor dep .fmapₑ fn (CVQuadrant (Leaf v) {p}) = (CVQuadrant (Leaf $ fn v) {p})
quadrantFunctor (S dep) .fmapₑ fn (CVQuadrant (Node a b c d) {p}) =
  (combine (fmapₑ (quadrantFunctor dep) fn sA) (fmapₑ (quadrantFunctor dep) fn sB) (fmapₑ (quadrantFunctor dep) fn sC) (fmapₑ (quadrantFunctor dep) fn sD)) where
  sA = CVQuadrant a {aSub a b c d p}
  sB = CVQuadrant b {bSub a b c d p}
  sC = CVQuadrant c {cSub a b c d p}
  sD = CVQuadrant d {dSub a b c d p}

toQt : {b : Set} -> {{ eqB : Eq b }}
  -> (dep w h : Nat) .(q : IsTrue (dep == log2up (if w < h then h else w))) -> VQuadrant b {dep} -> VQuadTree b {dep}
toQt dep w h q (CVQuadrant qd {p}) = CVQuadTree (Wrapper (w , h) qd) {p} {q}

quadtreeFunctor : (dep : Nat) -> FunctorEq (λ y -> VQuadTree y {dep})
quadtreeFunctor dep .fmapₑ {a} {b} fn (CVQuadTree (Wrapper (w , h) qd) {p} {q}) =
  toQt dep w h q (fmapₑ (quadrantFunctor dep) fn (CVQuadrant qd {p}))


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

open import Categories.Category using (Category)
open import Categories.Category.Monoidal using (Monoidal)

module Categories.Category.Monoidal.Reasoning {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

open import Data.Product using (_,_)

open import Categories.Functor renaming (id to idF)

private
  module C = Category C

open C hiding (id; identityˡ; identityʳ; assoc)

private
  variable
    X Y : Obj
    f g h i : X ⇒ Y

open Monoidal M using (_⊗₁_; ⊗)
open Functor ⊗ using (F-resp-≈; homomorphism)
open HomReasoning public

infixr 6 _⟩⊗⟨_ refl⟩⊗⟨_
infixl 7 _⟩⊗⟨refl

⊗-resp-≈ : f ≈ h → g ≈ i → (f ⊗₁ g) ≈ (h ⊗₁ i)
⊗-resp-≈ p q = F-resp-≈ (p , q)

⊗-resp-≈ˡ : f ≈ h → (f ⊗₁ g) ≈ (h ⊗₁ g)
⊗-resp-≈ˡ p = ⊗-resp-≈ p Equiv.refl

⊗-resp-≈ʳ : g ≈ i → (f ⊗₁ g) ≈ (f ⊗₁ i)
⊗-resp-≈ʳ p = ⊗-resp-≈ Equiv.refl p

_⟩⊗⟨_ : f ≈ h → g ≈ i → (f ⊗₁ g) ≈ (h ⊗₁ i)
_⟩⊗⟨_ = ⊗-resp-≈

refl⟩⊗⟨_ : g ≈ i → (f ⊗₁ g) ≈ (f ⊗₁ i)
refl⟩⊗⟨_ = ⊗-resp-≈ʳ

_⟩⊗⟨refl : f ≈ h → (f ⊗₁ g) ≈ (h ⊗₁ g)
_⟩⊗⟨refl = ⊗-resp-≈ˡ

-- removing the {_} makes the whole thing not type check anymore for some reason
-- an issue was raised on the main agda GitHub repository about this
-- (https://github.com/agda/agda/issues/4140)
-- if this is fixed feel free to remove the {_}
⊗-distrib-over-∘ : ((f ∘ h) ⊗₁ (g ∘ i)) ≈ ((f ⊗₁ g) ∘ (h ⊗₁ i))
⊗-distrib-over-∘ {_} = homomorphism
  -- This also corresponds with the graphical coherence property of diagrams modelling monoidal categories:
--   |        |         |   |
--  [h]      [i]       [h] [i]
--   |        |    ≈    |   |
--  [f]      [g]        |   |
--   |        |         |   |
--                     [f] [g]
--                      |   |

-- Parallel-to-serial conversions
--
--   |   |        |   |       |   |
--   |   |        |  [g]     [f]  |
--  [f] [g]   =   |   |   =   |   |
--   |   |       [f]  |       |  [g]
--   |   |        |   |       |   |

serialize₁₂ : ∀ {X₁ Y₁ X₂ Y₂} {f : X₁ ⇒ Y₁} {g : X₂ ⇒ Y₂} →
              f ⊗₁ g ≈ f ⊗₁ C.id ∘ C.id ⊗₁ g
serialize₁₂ {f = f} {g} = begin
  f ⊗₁ g                     ≈˘⟨ C.identityʳ ⟩⊗⟨ C.identityˡ ⟩
  (f ∘ C.id) ⊗₁ (C.id ∘ g)   ≈⟨ ⊗-distrib-over-∘ ⟩
  f ⊗₁ C.id ∘ C.id ⊗₁ g      ∎

serialize₂₁ : ∀ {X₁ Y₁ X₂ Y₂} {f : X₁ ⇒ Y₁} {g : X₂ ⇒ Y₂} →
              f ⊗₁ g ≈ C.id ⊗₁ g ∘ f ⊗₁ C.id
serialize₂₁ {f = f} {g} = begin
  f ⊗₁ g                     ≈˘⟨ C.identityˡ ⟩⊗⟨ C.identityʳ ⟩
  (C.id ∘ f) ⊗₁ (g ∘ C.id)   ≈⟨ ⊗-distrib-over-∘ ⟩
  C.id ⊗₁ g ∘ f ⊗₁ C.id      ∎

-- Split a composite in the first component
--
--   |   |        |   |       |   |
--  [g]  |       [g]  |      [g] [h]
--   |  [h]   =   |   |   =   |   |
--  [f]  |       [f] [h]     [f]  |
--   |   |        |   |       |   |

split₁ʳ : ∀ {X₁ Y₁ Z₁ X₂ Y₂} {f : Y₁ ⇒ Z₁} {g : X₁ ⇒ Y₁} {h : X₂ ⇒ Y₂} →
          (f ∘ g) ⊗₁ h ≈ f ⊗₁ h ∘ g ⊗₁ C.id
split₁ʳ {f = f} {g} {h} = begin
  (f ∘ g) ⊗₁ h            ≈˘⟨ refl⟩⊗⟨ C.identityʳ ⟩
  (f ∘ g) ⊗₁ (h ∘ C.id)   ≈⟨ ⊗-distrib-over-∘ ⟩
  f ⊗₁ h ∘ g ⊗₁ C.id      ∎

split₁ˡ : ∀ {X₁ Y₁ Z₁ X₂ Y₂} {f : Y₁ ⇒ Z₁} {g : X₁ ⇒ Y₁} {h : X₂ ⇒ Y₂} →
          (f ∘ g) ⊗₁ h ≈ f ⊗₁ C.id ∘ g ⊗₁ h
split₁ˡ {f = f} {g} {h} = begin
  (f ∘ g) ⊗₁ h            ≈˘⟨ refl⟩⊗⟨ C.identityˡ ⟩
  (f ∘ g) ⊗₁ (C.id ∘ h)   ≈⟨ ⊗-distrib-over-∘ ⟩
  f ⊗₁ C.id ∘ g ⊗₁ h      ∎

-- Split a composite in the second component
--
--   |   |        |   |       |   |
--   |  [h]       |  [h]     [f] [h]
--  [f]  |    =   |   |   =   |   |
--   |  [g]      [f] [g]      |  [g]
--   |   |        |   |       |   |

split₂ʳ : ∀ {X₁ Y₁ X₂ Y₂ Z₂} {f : X₁ ⇒ Y₁} {g : Y₂ ⇒ Z₂} {h : X₂ ⇒ Y₂} →
          f ⊗₁ (g ∘ h) ≈ f ⊗₁ g ∘ C.id ⊗₁ h
split₂ʳ {f = f} {g} {h} = begin
  f ⊗₁ (g ∘ h)            ≈˘⟨ C.identityʳ ⟩⊗⟨refl ⟩
  (f ∘ C.id) ⊗₁ (g ∘ h)   ≈⟨ ⊗-distrib-over-∘ ⟩
  f ⊗₁ g ∘ C.id ⊗₁ h      ∎

split₂ˡ : ∀ {X₁ Y₁ X₂ Y₂ Z₂} {f : X₁ ⇒ Y₁} {g : Y₂ ⇒ Z₂} {h : X₂ ⇒ Y₂} →
          f ⊗₁ (g ∘ h) ≈ C.id ⊗₁ g ∘ f ⊗₁ h
split₂ˡ {f = f} {g} {h} = begin
  f ⊗₁ (g ∘ h)            ≈˘⟨ C.identityˡ ⟩⊗⟨refl ⟩
  (C.id ∘ f) ⊗₁ (g ∘ h)   ≈⟨ ⊗-distrib-over-∘ ⟩
  C.id ⊗₁ g ∘ f ⊗₁ h      ∎


module UniDB.Morph.Sum where

open import UniDB.Spec

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

data Sum (Ξ Ζ : MOR) (γ₁ γ₂ : Dom) : Set where
  inl : Ξ γ₁ γ₂ → Sum Ξ Ζ γ₁ γ₂
  inr : Ζ γ₁ γ₂ → Sum Ξ Ζ γ₁ γ₂

instance
  iUpSum : {Ξ Ζ : MOR} {{upΞ : Up Ξ}} {{upΖ : Up Ζ}} → Up (Sum Ξ Ζ)
  _↑₁ {{iUpSum}} (inl ξ) = inl (ξ ↑₁)
  _↑₁ {{iUpSum}} (inr ζ) = inr (ζ ↑₁)
  _↑_ {{iUpSum}} ξ 0 = ξ
  _↑_ {{iUpSum}} ξ (suc δ⁺) = ξ ↑ δ⁺ ↑₁
  ↑-zero {{iUpSum}} ξ = refl
  ↑-suc {{iUpSum}} ξ δ⁺ = refl

  iLkSum :
    {T : STX}
    {Ξ : MOR} {{lkTΞ : Lk T Ξ}}
    {Ζ : MOR} {{lkTΖ : Lk T Ζ}} →
    Lk T (Sum Ξ Ζ)
  lk {{iLkSum {T} {Ξ} {Ζ}}} (inl ξ) i = lk {T} {Ξ} ξ i
  lk {{iLkSum {T} {Ξ} {Ζ}}} (inr ζ) i = lk {T} {Ζ} ζ i

  iLkUpSum :
    {T : STX} {{vrT : Vr T}} {{wkT : Wk T}}
    {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{lkUpTΞ : LkUp T Ξ}}
    {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} {{lkUpTΖ : LkUp T Ζ}} →
    LkUp T (Sum Ξ Ζ)
  lk-↑₁-zero {{iLkUpSum {T} {Ξ} {Ζ}}} (inl ξ) = lk-↑₁-zero {T} {Ξ} ξ
  lk-↑₁-zero {{iLkUpSum {T} {Ξ} {Ζ}}} (inr ζ) = lk-↑₁-zero {T} {Ζ} ζ
  lk-↑₁-suc {{iLkUpSum {T} {Ξ} {Ζ}}} (inl ξ) = lk-↑₁-suc {T} {Ξ} ξ
  lk-↑₁-suc {{iLkUpSum {T} {Ξ} {Ζ}}} (inr ζ) = lk-↑₁-suc {T} {Ζ} ζ

module _
  (Ξ Ζ : MOR) {{upΞ : Up Ξ}} {{upΖ : Up Ζ}}
  where

  inl-↑ : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (δ : Dom) →
    inl {Ξ} {Ζ} ξ ↑ δ ≡ inl (ξ ↑ δ)
  inl-↑ ξ zero    rewrite ↑-zero ξ              = refl
  inl-↑ ξ (suc δ) rewrite inl-↑ ξ δ | ↑-suc ξ δ = refl

  inr-↑ : {γ₁ γ₂ : Dom} (ζ : Ζ γ₁ γ₂) (δ : Dom) →
    inr {Ξ} {Ζ} ζ ↑ δ ≡ inr (ζ ↑ δ)
  inr-↑ ζ zero    rewrite ↑-zero ζ              = refl
  inr-↑ ζ (suc δ) rewrite inr-↑ ζ δ | ↑-suc ζ δ = refl

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


-- This test case seems to be due to Andreas Abel, Andrea Vezzosi and
-- NAD. The code below should be rejected.

open import Agda.Builtin.Size

data SizeLt (i : Size) : Set where
  size : (j : Size< i) → SizeLt i

-- Legal again in 2.5.1
getSize : ∀{i} → SizeLt i → Size
getSize (size j) = j

-- Structurally inductive (c), coinductive via sizes.
data U (i : Size) : Set where
  c : ((s : SizeLt i) → U (getSize s)) → U i

data ⊥ : Set where

empty : U ∞ → ⊥
empty (c f) = empty (f (size ∞))  -- f x <= f < c f

-- If U is a data type this should not be possible:
inh : ∀ i → U i
inh i = c λ{ (size j) → inh j }

absurd : ⊥
absurd = empty (inh ∞)


{-

This file contains:

- Definition of groupoid quotients

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

open import Cubical.Foundations.Prelude
open import Cubical.Relation.Binary.Base

-- Groupoid quotients as a higher inductive type:
-- For the definition, only transitivity is needed
data _//_ {ℓ ℓ'} (A : Type ℓ) {R : A → A → Type ℓ'}
          (Rt : BinaryRelation.isTrans R) : Type (ℓ-max ℓ ℓ') where
  [_] : (a : A) → A // Rt
  eq// : {a b : A} → (r : R a b) → [ a ] ≡ [ b ]
  comp// : {a b c : A} → (r : R a b) → (s : R b c)
          → PathP (λ j → [ a ] ≡ eq// s j) (eq// r) (eq// (Rt a b c r s))
  squash// : ∀ (x y : A // Rt) (p q : x ≡ y) (r s : p ≡ q) → r ≡ s

{- The comp// constructor fills the square:

  eq// (Rt a b c r s)
    [a]— — — >[c]
     ‖         ^
     ‖         | eq// s   ^
     ‖         |        j |
    [a]— — — >[b]         ∙ — >
       eq// r               i

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

comp'// : {ℓ ℓ' : Level} (A : Type ℓ) {R : A → A → Type ℓ'}
          (Rt : BinaryRelation.isTrans R)
          {a b c : A} → (r : R a b) → (s : R b c)
          → eq// {Rt = Rt} (Rt a b c r s) ≡ eq// r ∙ eq// s
comp'// A Rt r s i = compPath-unique refl (eq// r) (eq// s)
  (eq// {Rt = Rt} (Rt _ _ _ r s) , comp// r s)
  (eq// r ∙ eq// s , compPath-filler (eq// r) (eq// s)) i .fst


{-# OPTIONS --without-K #-}
-- most of this is subsumed by crypto-agda Search code
open import Type hiding (★)
open import Data.Nat.NP hiding (_==_) renaming (_<=_ to _ℕ<=_)
open import Data.Bits
open import Data.Bit hiding (_==_)
open import Data.Bool.Properties using (not-involutive)
import Data.Vec.NP as V
open V hiding (rewire; rewireTbl; sum) renaming (map to vmap; swap to vswap)

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Function.NP hiding (_→⟨_⟩_)
open import Algebra.FunctionProperties.NP

module Data.Bits.Search where
module Search {i} {I : ★ i} (`1 : I) (`2*_ : I → I)
              {a} {A : I → ★ a} (_∙_ : ∀ {m} → A m → A m → A (`2* m)) where

  `2^_ : ℕ → I
  `2^_ = fold `1 `2*_

  search : ∀ {n} → (Bits n → A `1) → A (`2^ n)
  search {zero}  f = f []
  search {suc n} f = search (f ∘ 0∷_) ∙ search (f ∘ 1∷_)

  searchBit : (Bit → A `1) → A (`2* `1)
  searchBit f = f 0b ∙ f 1b

  -- search-ext
  search-≗ : ∀ {n} (f g : Bits n → A `1) → f ≗ g → search f ≡ search g
  search-≗ {zero}  f g f≗g = f≗g []
  search-≗ {suc n} f g f≗g
    rewrite search-≗ (f ∘ 0∷_) (g ∘ 0∷_) (f≗g ∘ 0∷_)
          | search-≗ (f ∘ 1∷_) (g ∘ 1∷_) (f≗g ∘ 1∷_) = refl

  module Comm (∙-comm : ∀ {m} (x y : A m) → x ∙ y ≡ y ∙ x) where

    {- This pad bit vector allows to specify which bit do we negate in the vector. -}
    search-comm : ∀ {n} (pad : Bits n) (f : Bits n → A `1) → search f ≡ search (f ∘ _⊕_ pad)
    search-comm {zero} pad f = refl
    search-comm {suc n} (b ∷ pad) f
      rewrite search-comm pad (f ∘ 0∷_)
              | search-comm pad (f ∘ 1∷_)
      with b
    ... | true  = ∙-comm (search (f ∘ 0∷_ ∘ _⊕_ pad)) _
    ... | false = refl
  open Comm public

module SimpleSearch {a} {A : ★ a} (_∙_ : A → A → A) where

    open Search 1 2*_ {A = const A} _∙_ public

    module SearchUnit ε (ε∙ε : ε ∙ ε ≡ ε) where
        search-constε≡ε : ∀ n → search {n = n} (const ε) ≡ ε
        search-constε≡ε zero = refl
        search-constε≡ε (suc n) rewrite search-constε≡ε n = ε∙ε

    searchBit-search : ∀ n (f : Bits (suc n) → A) → searchBit (λ b → search (f ∘ _∷_ b)) ≡ search f
    searchBit-search n f = refl

    search-≗₂ : ∀ {m n} (f g : Bits m → Bits n → A) → f ≗₂ g
                  → search (search ∘ f) ≡ search (search ∘ g)
    search-≗₂ f g f≗g = search-≗ (search ∘ f) (search ∘ g) (λ xs →
                          search-≗ (f xs) (g xs) (λ ys →
                            f≗g xs ys))

    search-+ : ∀ {m n} (f : Bits (m + n) → A) →
                 search {m + n} f
               ≡ search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
    search-+ {zero} f = refl
    search-+ {suc m} f rewrite search-+ {m} (f ∘ 0∷_)
                             | search-+ {m} (f ∘ 1∷_) = refl

    module SearchInterchange (∙-interchange : Interchange _≡_ _∙_ _∙_) where

        search-dist : ∀ {n} (f₀ f₁ : Bits n → A) → search (λ x → f₀ x ∙ f₁ x) ≡ search f₀ ∙ search f₁
        search-dist {zero}  _ _ = refl
        search-dist {suc n} f₀ f₁
          rewrite search-dist (f₀ ∘ 0∷_) (f₁ ∘ 0∷_)
                | search-dist (f₀ ∘ 1∷_) (f₁ ∘ 1∷_)
                = ∙-interchange _ _ _ _

        search-searchBit : ∀ {n} (f : Bits (suc n) → A) →
                             search (λ xs → searchBit (λ b → f (b ∷ xs))) ≡ search f
        search-searchBit f = search-dist (f ∘ 0∷_) (f ∘ 1∷_)

        search-search : ∀ {m n} (f : Bits (m + n) → A) →
                          search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                        ≡ search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
        search-search {zero} f = refl
        search-search {suc m} {n} f
          rewrite search-search {m} {n} (f ∘ 0∷_)
                | search-search {m} {n} (f ∘ 1∷_)
                | search-searchBit {n} (λ { (b ∷ ys) → search {m} (λ xs → f (b ∷ xs ++ ys)) })
                = refl
        {- -- It might also be done by using search-dist twice and commutativity of addition.
           -- However, this also affect 'f' and makes this proof actually longer.
           search-search {m} {n} f =
                             search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                           ≡⟨ {!!} ⟩
                             search {m + n} f
                           ≡⟨ {!!} ⟩
                             search {n + m} (f ∘ vswap n)
                           ≡⟨ {!!} ⟩
                             search {n} (λ ys → search {m} (λ xs → f (vswap n (ys ++ xs))))
                           ≡⟨ {!!} ⟩
                             search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
                           ∎
                           where open ≡-Reasoning
         -}

        search-swap : ∀ {m n} (f : Bits (m + n) → A) → search {n + m} (f ∘ vswap n) ≡ search {m + n} f
        search-swap {m} {n} f =
                     search {n + m} (f ∘ vswap n)
                   ≡⟨ search-+ {n} {m} (f ∘ vswap n) ⟩
                     search {n} (λ ys → search {m} (λ xs → f (vswap n (ys ++ xs))))
                   ≡⟨ search-≗₂ {n} {m}
                                (λ ys → f ∘ vswap n ∘ _++_ ys)
                                (λ ys → f ∘ flip _++_ ys)
                                (λ ys xs → cong f (swap-++ n ys xs)) ⟩
                     search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
                   ≡⟨ sym (search-search {m} {n} f) ⟩
                     search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                   ≡⟨ sym (search-+ {m} {n} f) ⟩
                     search {m + n} f
                   ∎ where open ≡-Reasoning

        search-0↔1 : ∀ {n} (f : Bits n → A) → search {n} (f ∘ 0↔1) ≡ search {n} f
        search-0↔1 {zero}        _ = refl
        search-0↔1 {suc zero}    _ = refl
        search-0↔1 {suc (suc n)} _ = ∙-interchange _ _ _ _

    module Bij (∙-comm : Commutative _≡_ _∙_)
              (∙-interchange : Interchange _≡_ _∙_ _∙_) where
        open SearchInterchange ∙-interchange using (search-0↔1)
        open import Data.Bits.OperationSyntax hiding (_∙_)
        search-bij : ∀ {n} f (g : Bits n → A) → search (g ∘ eval f) ≡ search g
        search-bij `id     _ = refl
        search-bij `0↔1    f = search-0↔1 f
        search-bij (f `⁏ g) h
          rewrite search-bij f (h ∘ eval g)
                | search-bij g h
                = refl
        search-bij {suc n} (`id   `∷ f) g
          rewrite search-bij (f 0b) (g ∘ 0∷_)
                | search-bij (f 1b) (g ∘ 1∷_)
                = refl
        search-bij {suc n} (`notᴮ `∷ f) g
          rewrite search-bij (f 1b) (g ∘ 0∷_)
                | search-bij (f 0b) (g ∘ 1∷_)
                = ∙-comm _ _

|de-morgan| : ∀ {n} (f g : Bits n → Bit) → f |∨| g ≗ not ∘ ((not ∘ f) |∧| (not ∘ g))
|de-morgan| f g x with f x
... | true = refl
... | false = sym (not-involutive _)

open SimpleSearch

search-de-morgan : ∀ {n} op (f g : Bits n → Bit) →
                   search op (f |∨| g) ≡ search op (not ∘ ((not ∘ f) |∧| (not ∘ g)))
search-de-morgan op f g = search-≗ op _ _ (|de-morgan| f g)

search-hom :
  ∀ {n a b}
    {A : ★ a} {B : ★ b}
    (_+_ : A → A → A)
    (_*_ : B → B → B)
    (f : A → B)
    (p : Bits n → A)
    (hom : ∀ x y → f (x + y) ≡ f x * f y)
    → f (search _+_ p) ≡ search _*_ (f ∘ p)
search-hom {zero}  _   _   _ _ _   = refl
search-hom {suc n} _+_ _*_ f p hom =
   trans (hom _ _)
         (cong₂ _*_ (search-hom _+_ _*_ f (p ∘ 0∷_) hom)
                    (search-hom _+_ _*_ f (p ∘ 1∷_) hom))


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

module EqBool where

open import Data.Bool

record HasEqBool {a} (A : Set a) : Set a where
  field _==_ : A → A → Bool

open HasEqBool ⦃ ... ⦄ public

open import Data.List as List using (List; _∷_; [])

==[] : ∀ {a} {A : Set a} → ⦃ _ : HasEqBool A ⦄ → List A → List A → Bool
==[] [] [] = true
==[] [] (x ∷ ys) = false
==[] (x ∷ xs) [] = false
==[] (x ∷ xs) (y ∷ ys) = x == y ∧ ==[] xs ys

instance
  eqList : ∀ {a} {A : Set a} → ⦃ _ : HasEqBool A ⦄ → HasEqBool (List A)
  _==_ ⦃ eqList ⦄ = ==[]

open import Data.Nat using (ℕ)
instance
  eqNat : HasEqBool ℕ
  _==_ ⦃ eqNat ⦄ = Agda.Builtin.Nat._==_
    where import Agda.Builtin.Nat

instance
  eqBool : HasEqBool Bool
  _==_ ⦃ eqBool ⦄ false false = true
  _==_ ⦃ eqBool ⦄ false true = false
  _==_ ⦃ eqBool ⦄ true y = y

open import Data.String using (String)
instance
  eqString : HasEqBool String
  _==_ ⦃ eqString ⦄ = Data.String._==_
    where import Data.String