Added N92, ..., N99.

Added N92, ..., N99.

Ignore-this: 15470ce8f8307c4d1efbc233b4f22c57

darcs-hash:20110215220045-3bd4e-69a5d3b054fc1ddbd83411fd8b0c6b6448d70a42.gz

------------------------------------------------------------------------------
-- The unary numbers are LTC natural numbers
------------------------------------------------------------------------------

module LTC.Data.Nat.Unary.IsN-ATP where

open import LTC.Base

open import LTC.Data.Nat.Type
open import LTC.Data.Nat.Unary.Numbers

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

postulate
  N0  : N zero
  N1  : N one
  N10 : N ten
{-# ATP prove N0 #-}
{-# ATP prove N1 #-}
{-# ATP prove N10 #-}

postulate
  N11 : N eleven
{-# ATP prove N11 #-}

postulate
  N89 : N eighty-nine
  N90 : N ninety
{-# ATP prove N89 #-}
{-# ATP prove N90 #-}

postulate
  N91  : N ninety-one
  N92  : N ninety-two
  N93  : N ninety-three
  N94  : N ninety-four
  N95  : N ninety-five
  N96  : N ninety-six
  N97  : N ninety-seven
  N98  : N ninety-eight
  N99  : N ninety-nine
  N100 : N one-hundred
{-# ATP prove N91 #-}
{-# ATP prove N92 #-}
{-# ATP prove N93 #-}
{-# ATP prove N94 #-}
{-# ATP prove N95 #-}
{-# ATP prove N96 #-}
{-# ATP prove N97 #-}
{-# ATP prove N98 #-}
{-# ATP prove N99 #-}
{-# ATP prove N100 #-}

postulate
  N101 : N hundred-one
  N111 : N hundred-eleven
{-# ATP prove N101 #-}
{-# ATP prove N111 #-}

------------------------------------------------------------------------------
-- The unary numbers are LTC natural numbers
------------------------------------------------------------------------------

module LTC.Data.Nat.Unary.IsN-ATP where

open import LTC.Base

open import LTC.Data.Nat.Type
open import LTC.Data.Nat.Unary.Numbers

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

postulate
  N0  : N zero
  N1  : N one
  N10 : N ten
{-# ATP prove N0 #-}
{-# ATP prove N1 #-}
{-# ATP prove N10 #-}

postulate
  N11 : N eleven
{-# ATP prove N11 #-}

postulate
  N89 : N eighty-nine
  N90 : N ninety
{-# ATP prove N89 #-}
{-# ATP prove N90 #-}

postulate
  N91  : N ninety-one
  N100 : N one-hundred
{-# ATP prove N91 #-}
{-# ATP prove N100 #-}

postulate
  N101 : N hundred-one
  N111 : N hundred-eleven
{-# ATP prove N101 #-}
{-# ATP prove N111 #-}


updating to second PDF

updating to second PDF

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      _⟨_⇒_⟩   : dhexp → htyp → htyp → dhexp

  -- notation for chaining together agreeable casts
  _⟨_⇒_⇒_⟩ : dhexp → htyp → htyp → htyp → dhexp
  d ⟨ t1 ⇒ t2 ⇒ t3 ⟩ = d ⟨ t1 ⇒ t2 ⟩ ⟨ t2 ⇒ t3 ⟩

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- todo: this probably belongs in contexts, but need to abstract it.
  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × (tctx × htyp))
  u ::[ Γ ] τ = u , (Γ , τ)

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of u?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of u?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts? should this
  -- be judgemental rather than functional?

  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp : ∀{Γ e1 τ τ1 τ2 τ2' d1 Δ1 e2 d2 Δ2 } →
              -- Δ1 ## Δ2 → -- todo: need to think about disjointness and context rep
              Γ ⊢ e1 ⇒ τ1 ~> d1 ⊣ Δ1 →
              τ1 ▸arr τ2 ==> τ →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> (d1 ⟨ τ1 ⇒ τ2 ==> τ ⟩) ∘ (d2 ⟨ τ2' ⇒ τ2 ⟩) ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ  ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> d ⟨ τ ⇒ τ' ⟩ ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → e ≠ ⦇⦈[ u ]) →
                  ((e' : hexp) (u : Nat) → e ≠ ⦇ e' ⦈[ u ]) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ  ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ  ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) (xd∈σ : (x , d) ∈ σ) →
            Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ} →
             Δ , Γ ⊢ d1 :: τ1 ==> τ →
             Δ , Γ ⊢ d2 :: τ1 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ1 τ2} →
             Δ , Γ ⊢ d :: τ1 →
             τ1 ~ τ2 →
             Δ , Γ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2

  -- substitution;; todo: maybe get a premise that it's final; analagous to "value substitution"
  [_/_]_ : dhexp → Nat → dhexp → dhexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X y
  [ d / y ] (·λ x [ x₁ ] d') = ·λ x [ x₁ ] ( [ d / y ] d') -- TODO: i *think* barendrecht's saves us here, or at least i want it to. may need to reformulat this as a relation --> set
  [ d / y ] ⦇⦈⟨ u , σ ⟩ = ⦇⦈⟨ u , σ ⟩
  [ d / y ] ⦇ d' ⦈⟨ u , σ  ⟩ =  ⦇ [ d / y ] d' ⦈⟨ u , σ ⟩
  [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (d' ⟨ τ1 ⇒ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒ τ2 ⟩

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  -- ground
  data _ground : (τ : htyp) → Set where
    GBase : b ground
    GHole : ⦇⦈ ==> ⦇⦈ ground

  data _boxedval : (d : dhexp) → Set where
    BVVal : ∀{d} → d val → d boxedval
    BVArrCast : ∀{ d τ1 τ2 τ3 τ4 } →
                τ1 ==> τ2 ≠ τ3 ==> τ4 →
                d boxedval →
                d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ boxedval
    BVHoleCast : ∀{ τ d } → τ ground → d boxedval → d ⟨ τ ⇒ ⦇⦈ ⟩ boxedval

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d1' d2 τ1 τ2 τ3 τ4} →
                       d1 ≠ (d1' ⟨(τ1 ==> τ2) ⇒ (τ3 ==> τ4)⟩)  →
                       d1 indet →
                       d2 final →
                       (d1 ∘ d2) indet -- todo: should there be two ap rules?
      ICastArr : ∀{d τ1 τ2 τ3 τ4} →
                 τ1 ==> τ2 ≠ τ3 ==> τ4 →
                 d indet →
                 d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ indet
      ICastGroundHole : ∀{ τ d } →
                        τ ground →
                        d indet →
                        d ⟨ τ ⇒  ⦇⦈ ⟩ indet
      ICastHoleGround : ∀ { d d' τ τ' } →
                        d ≠ (d' ⟨ τ' ⇒ ⦇⦈ ⟩) →
                        d indet →
                        τ ground →
                        d ⟨ ⦇⦈ ⇒ τ ⟩ indet

    -- final
    data _final : (d : dhexp) → Set where
      FBoxed : ∀{d} → d boxedval → d final
      FIndet : ∀{d} → d indet → d final

 --  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    _∘₁_ : ectx → dhexp → ectx
    _∘₂_ : dhexp → ectx → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst ) → ectx
    _⟨_⇒_⟩   : ectx → htyp → htyp → ectx

 --ε is an evaluation context
  data _evalctx : (ε : ectx) → Set where
    ECDot : ⊙ evalctx
    ECAp1 : ∀{d ε} →
            ε evalctx →
            (ε ∘₁ d) evalctx
    ECAp2 : ∀{d ε} →
            d final →
            ε evalctx →
            (d ∘₂ ε) evalctx
    ECNEHole : ∀{ε u σ} →
               ε evalctx →
               ⦇ ε ⦈⟨ u , σ ⟩ evalctx
    ECCast : ∀{ ε τ1 τ2} →
             ε evalctx →
             (ε ⟨ τ1 ⇒ τ2 ⟩) evalctx

  -- d is the result of filling the hole in ε with d'
  data _==_⟦_⟧ : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FHOuter : ∀{d} → d == ⊙ ⟦ d ⟧ -- this used to a have a premise of being final for some reason
    FHAp1 : ∀{d1 d1' d2 ε} →
           d1 == ε ⟦ d1' ⟧ →
           (d1 ∘ d2) == (ε ∘₁ d2) ⟦ d1' ⟧
    FHAp2 : ∀{d1 d2 d2' ε} →
           d1 final →
           d2 == ε ⟦ d2' ⟧ →
           (d1 ∘ d2) == (d1 ∘₂ ε) ⟦ d2' ⟧
    FHNEHole : ∀{ d d' ε u σ} →
              d == ε ⟦ d' ⟧ →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⦇ ε ⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧
    FHCast : ∀{ d d' ε τ1 τ2 } →
            d == ε ⟦ d' ⟧ →
            d ⟨ τ1 ⇒ τ2 ⟩ == ε ⟨ τ1 ⇒ τ2 ⟩ ⟦ d' ⟧

  -- instruction transition judgement
  data _→>_ : (d d' : dhexp) → Set where
    ITLam : ∀{ x τ d1 d2 } →
            d2 final →
            ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) -- this is very unlikely to work long term
    ITCastID : ∀{d τ } →
               d final →
               (d ⟨ τ ⇒ τ ⟩) →> d
    ITCastSucceed : ∀{d τ } →
                    d final →
                    τ ground →
                    (d ⟨ τ ⇒ ⦇⦈ ⇒ τ ⟩) →> d
    ITApCast : ∀{d1 d2 τ1 τ2 τ1' τ2' } →
               d1 final →
               d2 final →
               ((d1 ⟨ (τ1 ==> τ2) ⇒ (τ1' ==> τ2')⟩) ∘ d2) →> ((d1 ∘ (d2 ⟨ τ1' ⇒ τ1 ⟩)) ⟨ τ2 ⇒ τ2' ⟩)
    ITGround : ∀{ d τ1 τ2 } →
               d final →
               (d ⟨ τ1 ==> τ2 ⇒ ⦇⦈ ⟩) →> (d ⟨ τ1 ==> τ2 ⇒ ⦇⦈ ==> ⦇⦈ ⇒ ⦇⦈ ⟩)
    ITExpand : ∀{d τ1 τ2 } →
               d final →
               τ1 ==> τ2 ≠ ⦇⦈ ==> ⦇⦈ →
               (d ⟨ ⦇⦈ ⇒ τ1 ==> τ2 ⟩) →> (d ⟨ ⦇⦈ ⇒ ⦇⦈ ==> ⦇⦈ ⇒ τ1 ==> τ2 ⟩)

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε ⟦ d0 ⟧ →
           d0 →> d0' →
           d' == ε ⟦ d0' ⟧ →
           Δ ⊢ d ↦ d'

  data _casterr : (d : dhexp) → Set where
    CECastFinal : ∀ {d τ1 τ2} →
                  d final →
                  τ1 ground →
                  τ2 ground →
                  τ1 ≠ τ2 →
                  d ⟨ τ1 ⇒ ⦇⦈ ⇒ τ2 ⟩ casterr
    CECong : ∀{ d ε d0} →
             d == ε ⟦ d0 ⟧ →
             d0 casterr →
             d casterr

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      _⟨_⇒_⟩   : dhexp → htyp → htyp → dhexp

  -- notation for chaining together agreeable casts
  _⟨_⇒_⇒_⟩ : dhexp → htyp → htyp → htyp → dhexp
  d ⟨ t1 ⇒ t2 ⇒ t3 ⟩ = d ⟨ t1 ⇒ t2 ⟩ ⟨ t2 ⇒ t3 ⟩

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- todo: this probably belongs in contexts, but need to abstract it.
  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × (tctx × htyp))
  u ::[ Γ ] τ = u , (Γ , τ)

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of u?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of u?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts? should this
  -- be judgemental rather than functional?

  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp : ∀{Γ e1 τ τ1 τ2 τ2' d1 Δ1 e2 d2 Δ2 } →
              -- Δ1 ## Δ2 → -- todo: need to think about disjointness and context rep
              Γ ⊢ e1 ⇒ τ1 ~> d1 ⊣ Δ1 →
              τ1 ▸arr τ2 ==> τ →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> (d1 ⟨ τ1 ⇒ τ2 ==> τ ⟩) ∘ (d2 ⟨ τ2' ⇒ τ2 ⟩) ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ  ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> d ⟨ τ ⇒ τ' ⟩ ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → e ≠ ⦇⦈[ u ]) →
                  ((e' : hexp) (u : Nat) → e ≠ ⦇ e' ⦈[ u ]) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ  ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ  ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) (xd∈σ : (x , d) ∈ σ) →
            Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ} →
             Δ , Γ ⊢ d1 :: τ1 ==> τ →
             Δ , Γ ⊢ d2 :: τ1 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ1 τ2} →
             Δ , Γ ⊢ d :: τ1 →
             τ1 ~ τ2 →
             Δ , Γ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2

  -- substitution;; todo: maybe get a premise that it's final; analagous to "value substitution"
  [_/_]_ : dhexp → Nat → dhexp → dhexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X y
  [ d / y ] (·λ x [ x₁ ] d') = ·λ x [ x₁ ] ( [ d / y ] d') -- TODO: i *think* barendrecht's saves us here, or at least i want it to. may need to reformulat this as a relation --> set
  [ d / y ] ⦇⦈⟨ u , σ ⟩ = ⦇⦈⟨ u , σ ⟩
  [ d / y ] ⦇ d' ⦈⟨ u , σ  ⟩ =  ⦇ [ d / y ] d' ⦈⟨ u , σ ⟩
  [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (d' ⟨ τ1 ⇒ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒ τ2 ⟩

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  -- ground
  data _ground : (τ : htyp) → Set where
    GBase : b ground
    GHole : ⦇⦈ ==> ⦇⦈ ground

  data _boxedval : (d : dhexp) → Set where
    BVVal : ∀{d} → d val → d boxedval
    BVArrCast : ∀{ d τ1 τ2 τ3 τ4 } →
                τ1 ==> τ2 ≠ τ3 ==> τ4 →
                d boxedval →
                d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ boxedval
    BVHoleCast : ∀{ τ d } → τ ground → d boxedval → d ⟨ τ ⇒ ⦇⦈ ⟩ boxedval

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d1' d2 τ1 τ2 τ3 τ4} →
                       d1 ≠ (d1' ⟨(τ1 ==> τ2) ⇒ (τ3 ==> τ4)⟩)  →
                       d1 indet →
                       d2 final →
                       (d1 ∘ d2) indet -- todo: should there be two ap rules?
      ICastArr : ∀{d τ1 τ2 τ3 τ4} →
                 τ1 ==> τ2 ≠ τ3 ==> τ4 →
                 d indet →
                 d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ indet
      ICastGroundHole : ∀{ τ d } → τ ground → d indet → d ⟨ τ ⇒  ⦇⦈ ⟩ indet

    -- final
    data _final : (d : dhexp) → Set where
      FBoxed : ∀{d} → d boxedval → d final
      FIndet : ∀{d} → d indet → d final

 --  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    _∘₁_ : ectx → dhexp → ectx
    _∘₂_ : dhexp → ectx → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst ) → ectx
    _⟨_⇒_⟩   : ectx → htyp → htyp → ectx

 --ε is an evaluation context
  data _evalctx : (ε : ectx) → Set where
    ECDot : ⊙ evalctx
    ECAp1 : ∀{d ε} →
            ε evalctx →
            (ε ∘₁ d) evalctx
    ECAp2 : ∀{d ε} →
            d final →
            ε evalctx →
            (d ∘₂ ε) evalctx
    ECNEHole : ∀{ε u σ} →
               ε evalctx →
               ⦇ ε ⦈⟨ u , σ ⟩ evalctx
    ECCast : ∀{ ε τ1 τ2} →
             ε evalctx →
             (ε ⟨ τ1 ⇒ τ2 ⟩) evalctx

  -- d is the result of filling the hole in ε with d'
  data _==_⟦_⟧ : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FHOuter : ∀{d} → d == ⊙ ⟦ d ⟧ -- this used to a have a premise of being final for some reason
    FHAp1 : ∀{d1 d1' d2 ε} →
           d1 == ε ⟦ d1' ⟧ →
           (d1 ∘ d2) == (ε ∘₁ d2) ⟦ d1' ⟧
    FHAp2 : ∀{d1 d2 d2' ε} →
           d1 final →
           d2 == ε ⟦ d2' ⟧ →
           (d1 ∘ d2) == (d1 ∘₂ ε) ⟦ d2' ⟧
    FHNEHole : ∀{ d d' ε u σ} →
              d == ε ⟦ d' ⟧ →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⦇ ε ⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧
    FHCast : ∀{ d d' ε τ1 τ2 } →
            d == ε ⟦ d' ⟧ →
            d ⟨ τ1 ⇒ τ2 ⟩ == ε ⟨ τ1 ⇒ τ2 ⟩ ⟦ d' ⟧

  -- instruction transition judgement
  data _→>_ : (d d' : dhexp) → Set where
    ITLam : ∀{ x τ d1 d2 } →
            d2 final →
            ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) -- this is very unlikely to work long term
    ITCastID : ∀{d τ } →
               d final →
               (d ⟨ τ ⇒ τ ⟩) →> d
    ITCastSucceed : ∀{d τ } →
                    d final →
                    τ ground →
                    (d ⟨ τ ⇒ ⦇⦈ ⇒ τ ⟩) →> d
    ITApCast : ∀{d1 d2 τ1 τ2 τ1' τ2' } →
               d1 final →
               d2 final →
               ((d1 ⟨ (τ1 ==> τ2) ⇒ (τ1' ==> τ2')⟩) ∘ d2) →> ((d1 ∘ (d2 ⟨ τ1' ⇒ τ1 ⟩)) ⟨ τ2 ⇒ τ2' ⟩)
    ITGround : ∀{ d τ1 τ2 } →
               d final →
               (d ⟨ τ1 ==> τ2 ⇒ ⦇⦈ ⟩) →> (d ⟨ τ1 ==> τ2 ⇒ ⦇⦈ ==> ⦇⦈ ⇒ ⦇⦈ ⟩)
    ITExpand : ∀{d τ1 τ2 } →
               d final →
               τ1 ==> τ2 ≠ ⦇⦈ ==> ⦇⦈ →
               (d ⟨ ⦇⦈ ⇒ τ1 ==> τ2 ⟩) →> (d ⟨ ⦇⦈ ⇒ ⦇⦈ ==> ⦇⦈ ⇒ τ1 ==> τ2 ⟩)

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε ⟦ d0 ⟧ →
           d0 →> d0' →
           d' == ε ⟦ d0' ⟧ →
           Δ ⊢ d ↦ d'

  data _casterr : (d : dhexp) → Set where
    CECastFinal : ∀ {d τ1 τ2} →
                  d final →
                  τ1 ground →
                  τ2 ground →
                  τ1 ≠ τ2 →
                  d ⟨ τ1 ⇒ ⦇⦈ ⇒ τ2 ⟩ casterr
    CECong : ∀{ d ε d0} →
             d == ε ⟦ d0 ⟧ →
             d0 casterr →
             d casterr


Adapt file to Agda 2.5.3 and agda-stdlib 0.14

{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.ANormalUntyped where

open import Data.Empty
open import Data.Unit using (⊤)
open import Data.Product
open import Data.Nat
import Data.Integer.Base as I
open I using (ℤ)
open import Data.Integer.Base using (ℤ)
open import Relation.Binary.PropositionalEquality

{- Typed deBruijn indexes for untyped languages. -}

-- Using a record gives an eta rule saying that all types are equal.
record Type : Set where
  constructor Uni

record DType : Set where
  constructor DUni

open import Base.Syntax.Context Type public
import Base.Syntax.Context DType as DC

data Term (Γ : Context) : Set where
  var : (x : Var Γ Uni) →
    Term Γ
  lett : (f : Var Γ Uni) → (x : Var Γ Uni) → Term (Uni • Γ) → Term Γ

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = DUni • ΔΔ Γ

derive-dvar : ∀ {Δ} → (x : Var Δ Uni) → DC.Var (ΔΔ Δ) DUni
derive-dvar this = DC.this
derive-dvar (that x) = DC.that (derive-dvar x)

data DTerm : (Δ : Context) → Set where
  dvar : ∀ {Δ} (x : DC.Var (ΔΔ Δ) DUni) →
    DTerm Δ
  dlett : ∀ {Δ} →
    (f : Var Δ Uni) →
    (x : Var Δ Uni) →
    (t : Term (Uni • Δ)) →
    (df : DC.Var (ΔΔ Δ) DUni) →
    (dx : DC.Var (ΔΔ Δ) DUni) →
    (dt : DTerm (Uni • Δ)) →
    DTerm Δ

derive-dterm : ∀ {Δ} → (t : Term Δ) → DTerm Δ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

{-
deriveC Δ (lett f x t) = dlett df x dx
-}

-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
--   cvar : (x : Var Γ τ) Δ →
--     ΔCTerm Γ τ Δ
--   clett : ∀ {σ τ₁ κ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
--     ΔCTerm (τ₁ • Γ) τ (? • Δ) →
--     ΔCTerm Γ τ Δ

weaken-term : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ →
  Term Γ₂
weaken-term Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
weaken-term Γ₁≼Γ₂ (lett f x t) = lett (weaken-var Γ₁≼Γ₂ f) (weaken-var Γ₁≼Γ₂ x) (weaken-term (keep _ • Γ₁≼Γ₂) t)

-- I don't necessarily recommend having a separate syntactic category for
-- functions, but we should prove a fundamental lemma for them too, somehow.
-- I'll probably end up with some ANF allowing lambdas to do the semantics.
data Fun (Γ : Context) : Set where
  term : Term Γ → Fun Γ
  abs : ∀ {σ} → Fun (σ • Γ) → Fun Γ

data DFun (Δ : Context) : Set where
  dterm : DTerm Δ → DFun Δ
  dabs : DFun (Uni • Δ) → DFun Δ

derive-dfun : ∀ {Δ} → (t : Fun Δ) → DFun Δ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

weaken-fun : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Fun Γ₁ →
  Fun Γ₂
weaken-fun Γ₁≼Γ₂ (term x) = term (weaken-term Γ₁≼Γ₂ x)
weaken-fun Γ₁≼Γ₂ (abs f) = abs (weaken-fun (keep _ • Γ₁≼Γ₂) f)

data Val : Type → Set
data DVal : DType → Set
-- data Val (τ : Type) : Set

open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

import Base.Denotation.Environment DType DVal as D

-- data Val (τ : Type) where
data Val where
  closure : ∀ {Γ} → (t : Fun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → Val Uni
  intV : ∀ (n : ℕ) → Val Uni

data DVal where
  dclosure : ∀ {Γ} → (dt : DFun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → (dρ : D.⟦ ΔΔ Γ ⟧Context) → DVal DUni
  dintV : ∀ (n : ℤ) → DVal DUni

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = D.⟦ ΔΔ Δ ⟧Context

-- ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
-- ⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
-- ⟦ lett f x t ⟧Term ρ = ⟦ t ⟧Term (⟦ f ⟧Var ρ (⟦ x ⟧Var ρ) • ρ)

-- XXX separate syntax is a bit dangerous. Also, do I want to be so accurate relative to the original model?
data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Term Γ → ℕ → Val Uni → Set

data _F⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Fun Γ → ℕ → Val Uni → Set where
  abs : ∀ {t : Fun (Uni • Γ)} →
    ρ F⊢ abs t ↓[ 0 ] closure t ρ
  term : ∀ {v} n (t : Term Γ) →
    ρ ⊢ t ↓[ n ] v →
    ρ F⊢ term t ↓[ n ] v

data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) where
  var : ∀ (x : Var Γ Uni) →
    ρ ⊢ var x ↓[ 0 ] (⟦ x ⟧Var ρ)
  lett : ∀ n1 n2 {Γ' ρ′ v1 v2 v3} {f x t t'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    ρ ⊢ lett f x t ↓[ suc (suc (n1 + n2)) ] v3
  -- lit : ∀ n →
  --   ρ ⊢ const (lit n) ↓[ 0 ] intV n

-- data _D_⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : D.⟦ ΔΔ Γ ⟧Context) : DTerm Γ → ℕ → DVal DUni → Set where
--   dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
--     ρ D dρ ⊢ dvar x ↓[ 0 ] (D.⟦ x ⟧Var dρ)
--   dlett : ∀ n1 n2 n3 n4 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
--     ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
--     ρ ⊢ var x ↓[ 0 ] v1 →
--     (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
--     (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
--     -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
--     -- definitions.
--     ρ D dρ ⊢ dvar df ↓[ 0 ] dclosure {Γ'} dt' ρ'' dρ' →
--     ρ D dρ ⊢ dvar dx ↓[ 0 ] dv1 →
--     (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓[ n3 ] dv2 →
--     (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓[ n4 ] dv3 →
--     ρ D dρ ⊢ dlett f x t df dx dt ↓[ suc (suc (n1 + n2)) ] dv3

-- Do I need to damn count steps here? No.

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DTerm Γ → DVal DUni → Set

data _D_F⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DFun Γ → DVal DUni → Set where
  dabs : ∀ {dt : DFun (Uni • Γ)} →
    ρ D dρ F⊢ dabs dt ↓ dclosure dt ρ dρ
  dterm : ∀ {dv} (dt : DTerm Γ) →
    ρ D dρ ⊢ dt ↓ dv →
    ρ D dρ F⊢ dterm dt ↓ dv

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) where
  dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
    ρ D dρ ⊢ dvar x ↓ (D.⟦ x ⟧Var dρ)
  dlett : ∀ n1 n2 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
    -- definitions.
    ρ D dρ ⊢ dvar df ↓ dclosure {Γ'} dt' ρ'' dρ' →
    ρ D dρ ⊢ dvar dx ↓ dv1 →
    (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓ dv2 →
    (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓ dv3 →
    ρ D dρ ⊢ dlett f x t df dx dt ↓ dv3

open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Relation.Binary hiding (_⇒_)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

suc∸suc : ∀ m n → n < m → suc (m ∸ suc n) ≡ m ∸ n
suc∸suc (suc m) zero (s≤s n<m) = refl
suc∸suc (suc m) (suc n) (s≤s n<m) = suc∸suc m n n<m

lemlt : ∀ j k → suc j < k → k ∸ suc j < k
lemlt j (suc k) (s≤s j<k) = s≤s (∸-mono {k} {k} {j} {0} ≤-refl z≤n)

lemlt′ : ∀ j k → suc j <′ k → k ∸ suc j <′ k
lemlt′ j k j<′k = ≤⇒≤′ (lemlt j k (≤′⇒≤ j<′k))

open import Induction.WellFounded
open import Induction.Nat
rrelT3-Type : ℕ → Set₁
rrelT3-Type n =
  ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
  (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set

rrelV3-Type : ℕ → Set₁
rrelV3-Type n = ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set

rrelTV3-Type : ℕ → Set₁
rrelTV3-Type n = rrelT3-Type n × rrelV3-Type n

-- The type of the function availalbe for recursive calls.
rrelTV3-recSubCallsT : ℕ → Set₁
rrelTV3-recSubCallsT n = (k : ℕ) → k < n → rrelTV3-Type k

mutual
  -- Assemble together
  rrelTV3-step : ∀ n → rrelTV3-recSubCallsT n → rrelTV3-Type n
  rrelTV3-step n rec-rrelTV3 =
    let rrelV3-n = rrelV3-step n rec-rrelTV3
    in rrelT3-step n rec-rrelTV3 rrelV3-n , rrelV3-n
  rrelTV3 =  <-rec rrelTV3-Type rrelTV3-step
  rrelT3 : ∀ n → rrelT3-Type n
  rrelT3 n =  proj₁ (rrelTV3 n)
  rrelV3 : ∀ n → rrelV3-Type n
  rrelV3 n =  proj₂ (rrelTV3 n)

  s-rrelV3 :
    ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
    ∀ j → j < k → rrelV3-Type (k ∸ j)
  s-rrelV3 k rec-rrelTV3 rrelV3-k 0 _ = rrelV3-k
  s-rrelV3 k rec-rrelTV3 rrelV3-k (suc j) sucj<k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt j k sucj<k))
  -- Have the same context for t1, dt and t2? Yeah, good, that's what we want in the end...
  -- Though we might want more flexibility till when we have replacement
  -- changes.
  rrelT3-step : ∀ k → rrelTV3-recSubCallsT k →
    rrelV3-Type k →
    -- rrelV3-Type n
    ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
      (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
  rrelT3-step k rec-rrelTV3 rrelV3-k =
    λ t1 dt t2 ρ1 dρ ρ2 →
    ∀ j (j<k : j < k) n2 →
    (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    s-rrelV3 k rec-rrelTV3 rrelV3-k j j<k v1 dv v2
    -- where
    --   s-rrelV3 : ∀ j → j <′ k → rrelV3-Type (k ∸ j)
    --   -- If j = 0, we can't do a recursive call on (k - j) because that's not
    --   -- well-founded. Luckily, we don't need to, just use relV as defined at
    --   -- the same level.
    --   -- Yet, this will be a pain in proofs.
    --   s-rrelV3 0 _ = rrelV3-k
    --   s-rrelV3 (suc j) sucj<′k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt′ j k sucj<′k))

  rrelV3-step : ∀ n → rrelTV3-recSubCallsT n →
    -- rrelV3-Type n
    ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set
  rrelV3-step n rec-rrelTV3 (intV v1) (dintV dv) (intV v2) = dv I.+ (I.+ v1) ≡ (I.+ v2)
  rrelV3-step n rec-rrelTV3 (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) =
      -- Require a proof that the two contexts match:
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        proj₂ (rec-rrelTV3 k k<n) v1 dv v2 →
        proj₁ (rec-rrelTV3 k k<n)
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-step n rec-rrelTV3 _ _ _ = ⊥

open import Postulate.Extensionality
mutual
  rrelT3-equiv : ∀ k {Γ} {t1 : Fun Γ} {dt t2 ρ1 dρ ρ2} →
    rrelT3 k t1 dt t2 ρ1 dρ ρ2 ≡
    ∀ j (j<k : j < k) n2 →
    ∀ (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    rrelV3 j v1 dv v2
  rrelT3-equiv n = cong (λ □ → ∀ j → □ j) (ext (λ j → {!!}))

  rrelV3-equiv : ∀ n {Γ1 Γ2 ΔΓ t1 dt t2 ρ1 ρ' dρ ρ2} →
    rrelV3 n (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) ≡ Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 →
        rrelV3 k v1 dv v2 →
        rrelT3 k
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-equiv n = cong (λ □ → Σ (_ ≡ _ × _ ≡ _) □) (ext (λ { (eq1 , eq2) →
    cong
      (λ □ →
         (λ { (refl , refl)
                → ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 → □ k k<n v1 dv v2
            })
         eq1 eq2)
      (ext (λ x → ext {!!}))}))
  --
  -- cong (λ □ → ∀ k → (k<n : k <′ n) → □ k k<n)
  -- rrelV3-equiv k

rrelρ3 : ℕ → ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3 n ∅ ∅ ∅ ∅ = ⊤
rrelρ3 n (Uni • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) = rrelV3 n v1 dv v2 × rrelρ3 n Γ ρ1 dρ ρ2

--
rfundamental3 : ∀ {Γ} (t : Fun Γ) → ∀ k ρ1 dρ ρ2 → (ρρ : rrelρ3 k Γ ρ1 dρ ρ2) → rrelT3 k t (derive-dfun t) t ρ1 dρ ρ2
rfundamental3 (term x) k ρ1 dρ ρ2 ρρ j j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 = {!!}
rfundamental3 {Γ} (abs t) k ρ1 dρ ρ2 ρρ .0 j<k .0 (closure .t .ρ1) (closure .t .ρ2) abs abs = dclosure (derive-dfun t) ρ1 dρ , 0 , dabs , (refl , refl) , {!body !}
  where
    body1 : ∀ k₁ (k₁<k : k₁ <′ k) → (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → rrelV3 k₁ v1 dv v2 → rrelT3 k₁ t (derive-dfun t) t (v1 • ρ1) (dv • dρ) (v2 • ρ2)
    body1 = λ k₁ k₁<k v1 dv v2 x v3 v4 j n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
    rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
    !}
  -- λ
  -- { k₁ k<n v1 dv v2 vv v3 v4 0 n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- !}
  -- -- (Some.wfRec-builder rrelTV3-Type rrelTV3-step k₁
  --                     -- (<-well-founded′ k k₁ k<n))

  -- -- All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k k₁ k<n : rrelTV3-Type k₁
  -- --
  -- ; k₁ k<n v1 dv v2 vv v3 v4 (suc j) n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- !}
  -- -- rfundamental3 t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 {!suc j !} n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- }

  --   -- ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
  --   -- ∀ j → j <′ k → rrelV3-Type (k ∸ j)
  --   foo : s-rrelV3 k
  --     (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k)
  --     (rrelV3-step k (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k))
  --     j j<k v1 (dclosure (derive-dfun t) ρ1 dρ) v2
  --   foo with j
  --   ... | s = {!!}

{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.ANormalUntyped where

open import Data.Empty
open import Data.Unit using (⊤)
open import Data.Product
open import Data.Nat
import Data.Integer.Base as I
open I using (ℤ)
open import Data.Integer.Base using (ℤ)
open import Relation.Binary.PropositionalEquality

{- Typed deBruijn indexes for untyped languages. -}

-- Using a record gives an eta rule saying that all types are equal.
record Type : Set where
  constructor Uni

record DType : Set where
  constructor DUni

open import Base.Syntax.Context Type public
import Base.Syntax.Context DType as DC

data Term (Γ : Context) : Set where
  var : (x : Var Γ Uni) →
    Term Γ
  lett : (f : Var Γ Uni) → (x : Var Γ Uni) → Term (Uni • Γ) → Term Γ

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = DUni • ΔΔ Γ

derive-dvar : ∀ {Δ} → (x : Var Δ Uni) → DC.Var (ΔΔ Δ) DUni
derive-dvar this = DC.this
derive-dvar (that x) = DC.that (derive-dvar x)

data DTerm : (Δ : Context) → Set where
  dvar : ∀ {Δ} (x : DC.Var (ΔΔ Δ) DUni) →
    DTerm Δ
  dlett : ∀ {Δ} →
    (f : Var Δ Uni) →
    (x : Var Δ Uni) →
    (t : Term (Uni • Δ)) →
    (df : DC.Var (ΔΔ Δ) DUni) →
    (dx : DC.Var (ΔΔ Δ) DUni) →
    (dt : DTerm (Uni • Δ)) →
    DTerm Δ

derive-dterm : ∀ {Δ} → (t : Term Δ) → DTerm Δ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

{-
deriveC Δ (lett f x t) = dlett df x dx
-}

-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
--   cvar : (x : Var Γ τ) Δ →
--     ΔCTerm Γ τ Δ
--   clett : ∀ {σ τ₁ κ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
--     ΔCTerm (τ₁ • Γ) τ (? • Δ) →
--     ΔCTerm Γ τ Δ

weaken-term : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ →
  Term Γ₂
weaken-term Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
weaken-term Γ₁≼Γ₂ (lett f x t) = lett (weaken-var Γ₁≼Γ₂ f) (weaken-var Γ₁≼Γ₂ x) (weaken-term (keep _ • Γ₁≼Γ₂) t)

-- I don't necessarily recommend having a separate syntactic category for
-- functions, but we should prove a fundamental lemma for them too, somehow.
-- I'll probably end up with some ANF allowing lambdas to do the semantics.
data Fun (Γ : Context) : Set where
  term : Term Γ → Fun Γ
  abs : ∀ {σ} → Fun (σ • Γ) → Fun Γ

data DFun (Δ : Context) : Set where
  dterm : DTerm Δ → DFun Δ
  dabs : DFun (Uni • Δ) → DFun Δ

derive-dfun : ∀ {Δ} → (t : Fun Δ) → DFun Δ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

weaken-fun : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Fun Γ₁ →
  Fun Γ₂
weaken-fun Γ₁≼Γ₂ (term x) = term (weaken-term Γ₁≼Γ₂ x)
weaken-fun Γ₁≼Γ₂ (abs f) = abs (weaken-fun (keep _ • Γ₁≼Γ₂) f)

data Val : Type → Set
data DVal : DType → Set
-- data Val (τ : Type) : Set

open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

import Base.Denotation.Environment DType DVal as D

-- data Val (τ : Type) where
data Val where
  closure : ∀ {Γ} → (t : Fun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → Val Uni
  intV : ∀ (n : ℕ) → Val Uni

data DVal where
  dclosure : ∀ {Γ} → (dt : DFun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → (dρ : D.⟦ ΔΔ Γ ⟧Context) → DVal DUni
  dintV : ∀ (n : ℤ) → DVal DUni

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = D.⟦ ΔΔ Δ ⟧Context

-- ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
-- ⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
-- ⟦ lett f x t ⟧Term ρ = ⟦ t ⟧Term (⟦ f ⟧Var ρ (⟦ x ⟧Var ρ) • ρ)

-- XXX separate syntax is a bit dangerous. Also, do I want to be so accurate relative to the original model?
data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Term Γ → ℕ → Val Uni → Set

data _F⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Fun Γ → ℕ → Val Uni → Set where
  abs : ∀ {t : Fun (Uni • Γ)} →
    ρ F⊢ abs t ↓[ 0 ] closure t ρ
  term : ∀ {v} n (t : Term Γ) →
    ρ ⊢ t ↓[ n ] v →
    ρ F⊢ term t ↓[ n ] v

data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) where
  var : ∀ (x : Var Γ Uni) →
    ρ ⊢ var x ↓[ 0 ] (⟦ x ⟧Var ρ)
  lett : ∀ n1 n2 {Γ' ρ′ v1 v2 v3} {f x t t'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    ρ ⊢ lett f x t ↓[ suc (suc (n1 + n2)) ] v3
  -- lit : ∀ n →
  --   ρ ⊢ const (lit n) ↓[ 0 ] intV n

-- data _D_⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : D.⟦ ΔΔ Γ ⟧Context) : DTerm Γ → ℕ → DVal DUni → Set where
--   dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
--     ρ D dρ ⊢ dvar x ↓[ 0 ] (D.⟦ x ⟧Var dρ)
--   dlett : ∀ n1 n2 n3 n4 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
--     ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
--     ρ ⊢ var x ↓[ 0 ] v1 →
--     (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
--     (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
--     -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
--     -- definitions.
--     ρ D dρ ⊢ dvar df ↓[ 0 ] dclosure {Γ'} dt' ρ'' dρ' →
--     ρ D dρ ⊢ dvar dx ↓[ 0 ] dv1 →
--     (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓[ n3 ] dv2 →
--     (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓[ n4 ] dv3 →
--     ρ D dρ ⊢ dlett f x t df dx dt ↓[ suc (suc (n1 + n2)) ] dv3

-- Do I need to damn count steps here? No.

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DTerm Γ → DVal DUni → Set

data _D_F⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DFun Γ → DVal DUni → Set where
  dabs : ∀ {dt : DFun (Uni • Γ)} →
    ρ D dρ F⊢ dabs dt ↓ dclosure dt ρ dρ
  dterm : ∀ {dv} (dt : DTerm Γ) →
    ρ D dρ ⊢ dt ↓ dv →
    ρ D dρ F⊢ dterm dt ↓ dv

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) where
  dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
    ρ D dρ ⊢ dvar x ↓ (D.⟦ x ⟧Var dρ)
  dlett : ∀ n1 n2 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
    -- definitions.
    ρ D dρ ⊢ dvar df ↓ dclosure {Γ'} dt' ρ'' dρ' →
    ρ D dρ ⊢ dvar dx ↓ dv1 →
    (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓ dv2 →
    (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓ dv3 →
    ρ D dρ ⊢ dlett f x t df dx dt ↓ dv3

open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Relation.Binary hiding (_⇒_)
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

suc∸suc : ∀ m n → n < m → suc (m ∸ suc n) ≡ m ∸ n
suc∸suc (suc m) zero (s≤s n<m) = refl
suc∸suc (suc m) (suc n) (s≤s n<m) = suc∸suc m n n<m

lemlt : ∀ j k → suc j < k → k ∸ suc j < k
lemlt j (suc k) (s≤s j<k) = s≤s (∸-mono {k} {k} {j} {0} ≤-refl z≤n)

lemlt′ : ∀ j k → suc j <′ k → k ∸ suc j <′ k
lemlt′ j k j<′k = ≤⇒≤′ (lemlt j k (≤′⇒≤ j<′k))

open import Induction.WellFounded
open import Induction.Nat
rrelT3-Type : ℕ → Set₁
rrelT3-Type n =
  ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
  (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set

rrelV3-Type : ℕ → Set₁
rrelV3-Type n = ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set

rrelTV3-Type : ℕ → Set₁
rrelTV3-Type n = rrelT3-Type n × rrelV3-Type n

-- The type of the function availalbe for recursive calls.
rrelTV3-recSubCallsT : ℕ → Set₁
rrelTV3-recSubCallsT n = (k : ℕ) → k <′ n → rrelTV3-Type k

mutual
  -- Assemble together
  rrelTV3-step : ∀ n → rrelTV3-recSubCallsT n → rrelTV3-Type n
  rrelTV3-step n rec-rrelTV3 =
    let rrelV3-n = rrelV3-step n rec-rrelTV3
    in rrelT3-step n rec-rrelTV3 rrelV3-n , rrelV3-n
  rrelTV3 = <-rec rrelTV3-Type rrelTV3-step
  rrelT3 : ∀ n → rrelT3-Type n
  rrelT3 n = proj₁ (rrelTV3 n)
  rrelV3 : ∀ n → rrelV3-Type n
  rrelV3 n = proj₂ (rrelTV3 n)

  s-rrelV3 :
    ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
    ∀ j → j <′ k → rrelV3-Type (k ∸ j)
  s-rrelV3 k rec-rrelTV3 rrelV3-k 0 _ = rrelV3-k
  s-rrelV3 k rec-rrelTV3 rrelV3-k (suc j) sucj<′k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt′ j k sucj<′k))
  -- Have the same context for t1, dt and t2? Yeah, good, that's what we want in the end...
  -- Though we might want more flexibility till when we have replacement
  -- changes.
  rrelT3-step : ∀ k → rrelTV3-recSubCallsT k →
    rrelV3-Type k →
    -- rrelV3-Type n
    ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
      (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
  rrelT3-step k rec-rrelTV3 rrelV3-k =
    λ t1 dt t2 ρ1 dρ ρ2 →
    ∀ j (j<k : j <′ k) n2 →
    (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    s-rrelV3 k rec-rrelTV3 rrelV3-k j j<k v1 dv v2
    -- where
    --   s-rrelV3 : ∀ j → j <′ k → rrelV3-Type (k ∸ j)
    --   -- If j = 0, we can't do a recursive call on (k - j) because that's not
    --   -- well-founded. Luckily, we don't need to, just use relV as defined at
    --   -- the same level.
    --   -- Yet, this will be a pain in proofs.
    --   s-rrelV3 0 _ = rrelV3-k
    --   s-rrelV3 (suc j) sucj<′k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt′ j k sucj<′k))

  rrelV3-step : ∀ n → rrelTV3-recSubCallsT n →
    -- rrelV3-Type n
    ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set
  rrelV3-step n rec-rrelTV3 (intV v1) (dintV dv) (intV v2) = dv I.+ (I.+ v1) ≡ (I.+ v2)
  rrelV3-step n rec-rrelTV3 (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) =
      -- Require a proof that the two contexts match:
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 →
        proj₂ (rec-rrelTV3 k k<n) v1 dv v2 →
        proj₁ (rec-rrelTV3 k k<n)
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-step n rec-rrelTV3 _ _ _ = ⊥

open import Postulate.Extensionality
mutual
  rrelT3-equiv : ∀ k {Γ} {t1 : Fun Γ} {dt t2 ρ1 dρ ρ2} →
    rrelT3 k t1 dt t2 ρ1 dρ ρ2 ≡
    ∀ j (j<k : j <′ k) n2 →
    ∀ (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    rrelV3 j v1 dv v2
  rrelT3-equiv n = cong (λ □ → ∀ j → □ j) (ext (λ j → {!!}))

  rrelV3-equiv : ∀ n {Γ1 Γ2 ΔΓ t1 dt t2 ρ1 ρ' dρ ρ2} →
    rrelV3 n (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) ≡ Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 →
        rrelV3 k v1 dv v2 →
        rrelT3 k
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-equiv n = cong (λ □ → Σ (_ ≡ _ × _ ≡ _) □) (ext (λ { (eq1 , eq2) →
    cong
      (λ □ →
         (λ { (refl , refl)
                → ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 → □ k k<n v1 dv v2
            })
         eq1 eq2)
      (ext (λ x → ext {!!}))}))
  --
  -- cong (λ □ → ∀ k → (k<n : k <′ n) → □ k k<n)
  -- rrelV3-equiv k

rrelρ3 : ℕ → ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3 n ∅ ∅ ∅ ∅ = ⊤
rrelρ3 n (Uni • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) = rrelV3 n v1 dv v2 × rrelρ3 n Γ ρ1 dρ ρ2

--
rfundamental3 : ∀ {Γ} (t : Fun Γ) → ∀ k ρ1 dρ ρ2 → (ρρ : rrelρ3 k Γ ρ1 dρ ρ2) → rrelT3 k t (derive-dfun t) t ρ1 dρ ρ2
rfundamental3 (term x) k ρ1 dρ ρ2 ρρ j j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 = {!!}
rfundamental3 {Γ} (abs t) k ρ1 dρ ρ2 ρρ .0 j<k .0 (closure .t .ρ1) (closure .t .ρ2) abs abs = dclosure (derive-dfun t) ρ1 dρ , 0 , dabs , (refl , refl) , {!body !}
  where
    body1 : ∀ k₁ (k₁<k : k₁ <′ k) → (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → rrelV3 k₁ v1 dv v2 → rrelT3 k₁ t (derive-dfun t) t (v1 • ρ1) (dv • dρ) (v2 • ρ2)
    body1 = λ k₁ k₁<k v1 dv v2 x v3 v4 j n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
    rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
    !}
  -- λ
  -- { k₁ k<n v1 dv v2 vv v3 v4 0 n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- !}
  -- -- (Some.wfRec-builder rrelTV3-Type rrelTV3-step k₁
  --                     -- (<-well-founded′ k k₁ k<n))

  -- -- All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k k₁ k<n : rrelTV3-Type k₁
  -- --
  -- ; k₁ k<n v1 dv v2 vv v3 v4 (suc j) n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- !}
  -- -- rfundamental3 t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 {!suc j !} n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- }

  --   -- ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
  --   -- ∀ j → j <′ k → rrelV3-Type (k ∸ j)
  --   foo : s-rrelV3 k
  --     (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k)
  --     (rrelV3-step k (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k))
  --     j j<k v1 (dclosure (derive-dfun t) ρ1 dρ) v2
  --   foo with j
  --   ... | s = {!!}


matrix om levels voor te stellen

matrix om levels voor te stellen

{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin
  open import Data.List
  open import Data.Vec renaming (map to vmap; lookup to vlookup)

  module Matrix where
    data Matrix (A : Set) : ℕ → ℕ → Set where
      Mat : {w h : ℕ} → Vec (Vec A w) h → Matrix A w h

    lookup : ∀ {w h} {A : Set} → Fin h → Fin w → Matrix A w h → A
    lookup row column (Mat rows) = vlookup column (vlookup row rows)

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa Color : Set where
    _KT : Color → KoopaTroopa Color

  data Material : Set where
    gas    : Material
    -- liquid : Material
    solid  : Material

  record Position : Set where
    constructor pos
    field
      x   : ℕ
      y   : ℕ
      mat : Material

  data _follows_ : Position → Position → Set where
    stay  : ∀ {p} → p follows p
    next  : ∀ {x y mat} → pos (suc x) y mat follows pos x y mat
    back  : ∀ {x y mat} → pos x y mat follows pos (suc x) y mat
    -- jump  : ∀ {x y mat} → pos x (suc y) mat follows pos x y mat
    fall  : ∀ {x y mat} → pos x y mat follows pos x (suc y) mat

  infixr 5 _↠⟨_⟩_
  data Path (Koopa : KoopaTroopa Color) : Position → Position → Set where
    []  : ∀ {p} → Path Koopa p p
    _↠⟨_⟩_ : {q r : Position} → (p : Position) → q follows p
                → (qs : Path Koopa q r) → Path Koopa p r

  example_level : Matrix Position
  example_level = []

  ex_path : Path (Red KT) (pos 0 0 solid) (pos 0 0 solid)
  ex_path = pos 0 0 solid ↠⟨ next ⟩
            pos 1 0 solid ↠⟨ back ⟩
            pos 0 0 solid ↠⟨ stay ⟩ []

{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
open import Data.Nat

data Color : Set where
  Green : Color
  Red : Color

data KoopaTroopa Color : Set where
  _KT : Color → KoopaTroopa Color

record Position : Set where
  constructor pos
  field
    x : ℕ
    y : ℕ

data _follows_ : Position → Position → Set where
  still : ∀ {p} → p follows p
  next  : ∀ {x y} → pos (suc x) y follows pos x y
  back  : ∀ {x y} → pos x y follows pos (suc x) y
  -- jump  : ∀ {x y} → pos x (suc y) follows pos x y
  fall  : ∀ {x y} → pos x y follows pos x (suc y)

data Path (Koopa : KoopaTroopa Color) : Position → Position → Set where
  []  : ∀ {p} → Path Koopa p p
  _↠[_]_ : {q r : Position} → (p : Position) → q follows p
           → (qs : Path Koopa q r) → Path Koopa p r

ex_path : Path (Red KT) (pos 0 0) (pos 0 0)
ex_path = pos 0 0 ↠[ next ] (pos 1 0 ↠[ back ] [])


sha1: just display the cost

sha1: just display the cost

-- https://upload.wikimedia.org/wikipedia/commons/e/e2/SHA-1.svg
-- http://www.faqs.org/rfcs/rfc3174.html
open import Type
open import Data.Nat.NP
open import Data.Bool using (if_then_else_)
import Data.Vec as V
open V using (Vec; []; _∷_)
--open import Data.Product
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module sha1 where

module FunSHA1
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU renaming (`⊤ to `𝟙; `Bit to `𝟚)
    open FunOps funOps renaming (_∘_ to _`∘_)

    Word : T
    Word = `Bits 32

    map²ʷ : (`𝟚 `× `𝟚 `→ `𝟚) → Word `× Word `→ Word
    map²ʷ = zipWith

    mapʷ : (`𝟚 `→ `𝟚) → Word `→ Word
    mapʷ = map

    lift : ∀ {Γ A B} → (A `→ B) → Γ `→ A → Γ `→ B
    lift f g = g ⁏ f

    lift₂ : ∀ {Γ A B C} → (A `× B `→ C) → Γ `→ A → Γ `→ B → Γ `→ C
    lift₂ op₂ f₀ f₁ = < f₀ , f₁ > ⁏ op₂

    `not : ∀ {Γ} (f : Γ `→ Word) → Γ `→ Word
    `not = lift (mapʷ not)

    infixr 3 _`⊕_
    _`⊕_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`⊕_ = lift₂ (map²ʷ <xor>)

    infixr 3 _`∧_
    _`∧_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∧_ = lift₂ (map²ʷ <and>)

    infixr 2 _`∨_
    _`∨_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∨_ = lift₂ (map²ʷ <or>)

    open import Solver.Linear

    module LinSolver = Syntaxᶠ linRewiring

    --iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ `Vec B n

    iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
    iter {zero}  F = <[]>
    iter {suc n} F = < id × < uncons × uncons > >
                   ⁏ (helper ⁏ < F × id > ⁏ < swap × id > ⁏ assoc ⁏ < id × iter F >)
                   ⁏ <∷>

      where
        open LinSolver
        helper = λ {A} {B} {D} {VA} {VB} →
          rewireᶠ (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])
                  (λ a b d va vb → (d , (a , va) , (b , vb)) ↦ (d , a , b) , (va , vb))

    <⊞> adder : Word `× Word `→ Word
    adder = <tt⁏ <0b> , id > ⁏ iter full-adder
    <⊞> = adder

    infixl 4 _`⊞_
    _`⊞_ : ∀ {A} (f g : A `→ Word) → A `→ Word
    _`⊞_ = lift₂ <⊞>

    <_,_,_> : ∀ {Γ A B C} → Γ `→ A → Γ `→ B → Γ `→ C → Γ `→ (A `× B `× C)
    < f₀ , f₁ , f₂ > = < f₀ , < f₁ , f₂ > >

    <_,_,_,_,_> : ∀ {Γ A B C D E} → Γ `→ A → Γ `→ B → Γ `→ C
                                  → Γ `→ D → Γ `→ E
                                  → Γ `→ (A `× B `× C `× D `× E)
    < f₀ , f₁ , f₂ , f₃ , f₄ > = < f₀ , < f₁ , < f₂ , f₃ , f₄ > > >

    <<<₅ : `Endo Word
    <<<₅ = rot-left 5

    <<<₃₀ : `Endo Word
    <<<₃₀ = rot-left 30

    Word² = Word `× Word
    Word³ = Word `× Word²
    Word⁴ = Word `× Word³
    Word⁵ = Word `× Word⁴

    open import Data.Digit

    bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    bits ℓ n₀ =  constBits (L▹V (L.map F▹𝟚 (proj₁ (toDigits 2 n₀))))
      where open import Data.List as L
            open import Data.Product
            open import Data.Two
            L▹V : ∀ {n} → List 𝟚 → Vec 𝟚 n
            L▹V {zero} xs = []
            L▹V {suc n} [] = V.replicate 0'
            L▹V {suc n} (x ∷ xs) = x ∷ L▹V xs
            F▹𝟚 : Fin 2 → 𝟚
            F▹𝟚 zero    = 0'
            F▹𝟚 (suc _) = 1'

            {-
    [_-_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m - n mod p ] = {!!}

    [_+_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m + n mod p ] = {!!}
    -}

    #ʷ = bits 32

    <⊞⁵> : Word⁵ `× Word⁵ `→ Word⁵
    <⊞⁵> = helper ⁏ < <⊞> × < <⊞> × < <⊞> × < <⊞> × <⊞> > > > >
      where
        open LinSolver
        helper = λ {A} {B} {C} {D} {E} {F} {G} {H} {I} {J} →
          rewireᶠ (A ∷ B ∷ C ∷ D ∷ E ∷ F ∷ G ∷ H ∷ I ∷ J ∷ [])
                  (λ a b c d e f g h i j →
                    ((a , b , c , d , e) , (f , g , h , i , j) ↦
                     ((a , f) , (b , g) , (c , h) , (d , i) , (e , j))))

    iterateⁿ : ∀ {A} n → (Fin n → `Endo A) → `Endo A
    iterateⁿ zero    f = id
    iterateⁿ (suc n) f = f zero ⁏ iterateⁿ n (f ∘ suc)

    _²⁰ : ∀ {A} → (Fin 20 → `Endo A) → `Endo A
    _²⁰ = iterateⁿ 20

    module _ where

      K₀ = #ʷ 0x5A827999
      K₂ = #ʷ 0x6ED9EBA1
      K₄ = #ʷ 0x8F1BBCDC
      K₆ = #ʷ 0xCA62C1D6

      H0 = #ʷ 0x67452301
      H1 = #ʷ 0xEFCDAB89
      H2 = #ʷ 0x98BADCFE
      H3 = #ʷ 0x10325476
      H4 = #ʷ 0xC3D2E1F0

      A B C D E : Word⁵ `→ Word
      A = fst
      B = snd ⁏ fst
      C = snd ⁏ snd ⁏ fst
      D = snd ⁏ snd ⁏ snd ⁏ fst
      E = snd ⁏ snd ⁏ snd ⁏ snd

      F₀ = B `∧ C `∨ `not B `∧ D
      F₂ = B `⊕ C `⊕ D
      F₄ = B `∧ C `∨ B `∧ D `∨ C `∧ D
      F₆ = F₂

      module _ (F : Word⁵ `→ Word)
               (K : `𝟙  `→ Word)
               (W : `𝟙  `→ Word) where
        Iteration = < A' , A , (B ⁏ <<<₃₀) , C , D >
          where A' = F `⊞ E `⊞ (A ⁏ <<<₅) `⊞ (tt ⁏ W) `⊞ (tt ⁏ K)

      module _ (W : Fin 80 → `𝟙 `→ Word) where
        W₀ W₂ W₄ W₆ : Fin 20 → `𝟙 `→ Word
        W₀ = W ∘ inject+ 60 ∘ raise  0
        W₂ = W ∘ inject+ 40 ∘ raise 20
        W₄ = W ∘ inject+ 20 ∘ raise 40
        W₆ = W ∘ inject+  0 ∘ raise 60

        Iteration⁸⁰ : `Endo Word⁵
        Iteration⁸⁰ =
          (Iteration F₀ K₀ ∘ W₀)²⁰ ⁏
          (Iteration F₂ K₂ ∘ W₂)²⁰ ⁏
          (Iteration F₄ K₄ ∘ W₄)²⁰ ⁏
          (Iteration F₆ K₆ ∘ W₆)²⁰

        pad0s : ℕ → ℕ
        pad0s zero = 512 ∸ 65
        pad0s (suc _) = STUCK where postulate STUCK : ℕ
        -- pad0s n = [ 512 - [ n + 65 mod 512 ] mod 512 ]

        paddedLength : ℕ → ℕ
        paddedLength n = n + (1 + pad0s n + 64)

        padding : ∀ {n} → `Bits n `→ `Bits (paddedLength n)
        padding {n} = < id ,tt⁏ <1∷ < <0ⁿ> {pad0s n} ++ bits 64 n > > > ⁏ append

        ite : Endo (`Endo Word⁵)
        ite f = dup ⁏ first f ⁏ <⊞⁵>

        hash-block : `Endo Word⁵
        hash-block = ite Iteration⁸⁰

      ite' : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word)
             → ((Fin 80 → `𝟙 `→ Word) → `Endo Word⁵) → `Endo Word⁵
      ite' zero    W f = id
      ite' (suc n) W f = f (W zero) ⁏ ite' n (W ∘ suc) f

      SHA1 : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word) → `𝟙 `→ Word⁵
      SHA1 n W = < H0 , H1 , H2 , H3 , H4 >
               ⁏ ite' n W hash-block

      SHA1-on-0s : `𝟙 `→ Word⁵
      SHA1-on-0s = SHA1 1 (λ _ _ → <0ⁿ>)

module AgdaSHA1 where
  open import FunUniverse.Agda
  open FunSHA1 agdaFunOps
  open import Data.Two

open import IO
import IO.Primitive
open import Data.One
open import Data.Two
open import Data.Product
open import Coinduction
putBit : 𝟚 → IO 𝟙
putBit 1' = putStr "1"
putBit 0' = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
put× : ∀ {A B : Set} → (A → IO 𝟙) → (B → IO 𝟙) → (A × B) → IO 𝟙
put× pA pB (x , y) = ♯ pA x >> ♯ pB y
{-
main : IO.Primitive.IO 𝟙
main = IO.run (put× putBits (put× putBits (put× putBits (put× putBits
          putBits))) AgdaSHA1.SHA1-on-0s)
-}
firstBit : ∀ {A : Set} → (V.Vec 𝟚 32 × A) → 𝟚
firstBit ((b ∷ _) , _) = b
import FunUniverse.Cost as Cost
open import Data.Nat.Show
sha1-cost : ℕ
sha1-cost = FunSHA1.SHA1-on-0s Cost.timeOps
main : IO.Primitive.IO 𝟙
--main = IO.run (putBit (firstBit (AgdaSHA1.SHA1-on-0s _)))
main = IO.run (putStrLn (show sha1-cost))

-- -}

-- https://upload.wikimedia.org/wikipedia/commons/e/e2/SHA-1.svg
-- http://www.faqs.org/rfcs/rfc3174.html
open import Type
open import Data.Nat.NP
open import Data.Bool using (if_then_else_)
import Data.Vec as V
open V using (Vec; []; _∷_)
--open import Data.Product
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module sha1 where

module FunSHA1
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU renaming (`⊤ to `𝟙; `Bit to `𝟚)
    open FunOps funOps renaming (_∘_ to _`∘_)

    Word : T
    Word = `Bits 32

    map²ʷ : (`𝟚 `× `𝟚 `→ `𝟚) → Word `× Word `→ Word
    map²ʷ = zipWith

    mapʷ : (`𝟚 `→ `𝟚) → Word `→ Word
    mapʷ = map

    lift : ∀ {Γ A B} → (A `→ B) → Γ `→ A → Γ `→ B
    lift f g = g ⁏ f

    lift₂ : ∀ {Γ A B C} → (A `× B `→ C) → Γ `→ A → Γ `→ B → Γ `→ C
    lift₂ op₂ f₀ f₁ = < f₀ , f₁ > ⁏ op₂

    `not : ∀ {Γ} (f : Γ `→ Word) → Γ `→ Word
    `not = lift (mapʷ not)

    infixr 3 _`⊕_
    _`⊕_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`⊕_ = lift₂ (map²ʷ <xor>)

    infixr 3 _`∧_
    _`∧_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∧_ = lift₂ (map²ʷ <and>)

    infixr 2 _`∨_
    _`∨_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
    _`∨_ = lift₂ (map²ʷ <or>)

    open import Solver.Linear

    module LinSolver = Syntaxᶠ linRewiring

    --iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ `Vec B n

    iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
    iter {zero}  F = <[]>
    iter {suc n} F = < id × < uncons × uncons > >
                   ⁏ (helper ⁏ < F × id > ⁏ < swap × id > ⁏ assoc ⁏ < id × iter F >)
                   ⁏ <∷>

      where
        open LinSolver
        helper = λ {A} {B} {D} {VA} {VB} →
          rewireᶠ (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])
                  (λ a b d va vb → (d , (a , va) , (b , vb)) ↦ (d , a , b) , (va , vb))

    <⊞> adder : Word `× Word `→ Word
    adder = <tt⁏ <0b> , id > ⁏ iter full-adder
    <⊞> = adder

    infixl 4 _`⊞_
    _`⊞_ : ∀ {A} (f g : A `→ Word) → A `→ Word
    _`⊞_ = lift₂ <⊞>

    <_,_,_> : ∀ {Γ A B C} → Γ `→ A → Γ `→ B → Γ `→ C → Γ `→ (A `× B `× C)
    < f₀ , f₁ , f₂ > = < f₀ , < f₁ , f₂ > >

    <_,_,_,_,_> : ∀ {Γ A B C D E} → Γ `→ A → Γ `→ B → Γ `→ C
                                  → Γ `→ D → Γ `→ E
                                  → Γ `→ (A `× B `× C `× D `× E)
    < f₀ , f₁ , f₂ , f₃ , f₄ > = < f₀ , < f₁ , < f₂ , f₃ , f₄ > > >

    <<<₅ : `Endo Word
    <<<₅ = rot-left 5

    <<<₃₀ : `Endo Word
    <<<₃₀ = rot-left 30

    Word² = Word `× Word
    Word³ = Word `× Word²
    Word⁴ = Word `× Word³
    Word⁵ = Word `× Word⁴

    open import Data.Digit

    bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    bits ℓ n₀ =  constBits (L▹V (L.map F▹𝟚 (proj₁ (toDigits 2 n₀))))
      where open import Data.List as L
            open import Data.Product
            open import Data.Two
            L▹V : ∀ {n} → List 𝟚 → Vec 𝟚 n
            L▹V {zero} xs = []
            L▹V {suc n} [] = V.replicate 0'
            L▹V {suc n} (x ∷ xs) = x ∷ L▹V xs
            F▹𝟚 : Fin 2 → 𝟚
            F▹𝟚 zero    = 0'
            F▹𝟚 (suc _) = 1'

            {-
    [_-_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m - n mod p ] = {!!}

    [_+_mod_] : ℕ → ℕ → ℕ → ℕ
    [ m + n mod p ] = {!!}
    -}

    #ʷ = bits 32

    <⊞⁵> : Word⁵ `× Word⁵ `→ Word⁵
    <⊞⁵> = helper ⁏ < <⊞> × < <⊞> × < <⊞> × < <⊞> × <⊞> > > > >
      where
        open LinSolver
        helper = λ {A} {B} {C} {D} {E} {F} {G} {H} {I} {J} →
          rewireᶠ (A ∷ B ∷ C ∷ D ∷ E ∷ F ∷ G ∷ H ∷ I ∷ J ∷ [])
                  (λ a b c d e f g h i j →
                    ((a , b , c , d , e) , (f , g , h , i , j) ↦
                     ((a , f) , (b , g) , (c , h) , (d , i) , (e , j))))

    iterateⁿ : ∀ {A} n → (Fin n → `Endo A) → `Endo A
    iterateⁿ zero    f = id
    iterateⁿ (suc n) f = f zero ⁏ iterateⁿ n (f ∘ suc)

    _²⁰ : ∀ {A} → (Fin 20 → `Endo A) → `Endo A
    _²⁰ = iterateⁿ 20

    module _ where

      K₀ = #ʷ 0x5A827999
      K₂ = #ʷ 0x6ED9EBA1
      K₄ = #ʷ 0x8F1BBCDC
      K₆ = #ʷ 0xCA62C1D6

      H0 = #ʷ 0x67452301
      H1 = #ʷ 0xEFCDAB89
      H2 = #ʷ 0x98BADCFE
      H3 = #ʷ 0x10325476
      H4 = #ʷ 0xC3D2E1F0

      A B C D E : Word⁵ `→ Word
      A = fst
      B = snd ⁏ fst
      C = snd ⁏ snd ⁏ fst
      D = snd ⁏ snd ⁏ snd ⁏ fst
      E = snd ⁏ snd ⁏ snd ⁏ snd

      F₀ = B `∧ C `∨ `not B `∧ D
      F₂ = B `⊕ C `⊕ D
      F₄ = B `∧ C `∨ B `∧ D `∨ C `∧ D
      F₆ = F₂

      module _ (F : Word⁵ `→ Word)
               (K : `𝟙  `→ Word)
               (W : `𝟙  `→ Word) where
        Iteration = < A' , A , (B ⁏ <<<₃₀) , C , D >
          where A' = F `⊞ E `⊞ (A ⁏ <<<₅) `⊞ (tt ⁏ W) `⊞ (tt ⁏ K)

      module _ (W : Fin 80 → `𝟙 `→ Word) where
        W₀ W₂ W₄ W₆ : Fin 20 → `𝟙 `→ Word
        W₀ = W ∘ inject+ 60 ∘ raise  0
        W₂ = W ∘ inject+ 40 ∘ raise 20
        W₄ = W ∘ inject+ 20 ∘ raise 40
        W₆ = W ∘ inject+  0 ∘ raise 60

        Iteration⁸⁰ : `Endo Word⁵
        Iteration⁸⁰ =
          (Iteration F₀ K₀ ∘ W₀)²⁰ ⁏
          (Iteration F₂ K₂ ∘ W₂)²⁰ ⁏
          (Iteration F₄ K₄ ∘ W₄)²⁰ ⁏
          (Iteration F₆ K₆ ∘ W₆)²⁰

        pad0s : ℕ → ℕ
        pad0s zero = 512 ∸ 65
        pad0s (suc _) = STUCK where postulate STUCK : ℕ
        -- pad0s n = [ 512 - [ n + 65 mod 512 ] mod 512 ]

        paddedLength : ℕ → ℕ
        paddedLength n = n + (1 + pad0s n + 64)

        padding : ∀ {n} → `Bits n `→ `Bits (paddedLength n)
        padding {n} = < id ,tt⁏ <1∷ < <0ⁿ> {pad0s n} ++ bits 64 n > > > ⁏ append

        ite : Endo (`Endo Word⁵)
        ite f = dup ⁏ first f ⁏ <⊞⁵>

        hash-block : `Endo Word⁵
        hash-block = ite Iteration⁸⁰

      ite' : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word)
             → ((Fin 80 → `𝟙 `→ Word) → `Endo Word⁵) → `Endo Word⁵
      ite' zero    W f = id
      ite' (suc n) W f = f (W zero) ⁏ ite' n (W ∘ suc) f

      SHA1 : ∀ n (W : Fin n → Fin 80 → `𝟙 `→ Word) → `𝟙 `→ Word⁵
      SHA1 n W = < H0 , H1 , H2 , H3 , H4 >
               ⁏ ite' n W hash-block

module AgdaSHA1 where
  open import FunUniverse.Agda
  open FunSHA1 agdaFunOps
  open import Data.Two

  SHA1-on-0s : Word⁵
  SHA1-on-0s = SHA1 1 (λ _ _ _ → V.replicate 0') _

open import IO
import IO.Primitive
open import Data.One
open import Data.Two
open import Data.Product
open import Coinduction
putBit : 𝟚 → IO 𝟙
putBit 1' = putStr "1"
putBit 0' = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
put× : ∀ {A B : Set} → (A → IO 𝟙) → (B → IO 𝟙) → (A × B) → IO 𝟙
put× pA pB (x , y) = ♯ pA x >> ♯ pB y
{-
main : IO.Primitive.IO 𝟙
main = IO.run (put× putBits (put× putBits (put× putBits (put× putBits
          putBits))) AgdaSHA1.SHA1-on-0s)
-}
firstBit : ∀ {A : Set} → (V.Vec 𝟚 32 × A) → 𝟚
firstBit ((b ∷ _) , _) = b
main : IO.Primitive.IO 𝟙
main = IO.run (putBit (firstBit AgdaSHA1.SHA1-on-0s))

-- -}


Cosmetic change.

Cosmetic change.

Ignore-this: 4f681c804a67430813f97c1cc20b44f4

darcs-hash:20120217140437-3bd4e-99fea7a6d09b6da3ebeb66c427a3870abfba4dab.gz

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Data.Stream
open import FOTC.Data.Stream.Equality

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

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS {x} {xs} h₁ with (Stream-gfp₁ h₁)
... | e , es , Ses , h₂ = subst Stream (sym (∧-proj₂ (∷-injective h₂))) Ses

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  helper₁ : ∀ {ws} → P₁ ws →
            ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  helper₁ {ws} (zs , ws≈zs) with ≈-gfp₁ ws≈zs
  ... | w' , ws' , zs' , ws'≈zs' , ws≡w'∷ws' , _ =
    w' , ws' , (zs' , ws'≈zs') , ws≡w'∷ws'

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  helper₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  helper₂  {zs} (ws , ws≈zs) with ≈-gfp₁ ws≈zs
  ... | w' , ws' , zs' , ws'≈zs' , _ , zs≡w'∷zs' =
    w' , zs' , (ws' , ws'≈zs') , zs≡w'∷zs'

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Data.Stream
open import FOTC.Data.Stream.Equality

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

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS {x} {xs} h with (Stream-gfp₁ h)
... | e , es , Ses , x∷xs≡e∷es =
  subst Stream (sym (∧-proj₂ (∷-injective x∷xs≡e∷es))) Ses

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  helper₁ : ∀ {ws} → P₁ ws →
            ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  helper₁ {ws} (zs , ws≈zs) with ≈-gfp₁ ws≈zs
  ... | w' , ws' , zs' , ws'≈zs' , ws≡w'∷ws' , _ =
    w' , ws' , (zs' , ws'≈zs') , ws≡w'∷ws'

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  helper₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  helper₂  {zs} (ws , ws≈zs) with ≈-gfp₁ ws≈zs
  ... | w' , ws' , zs' , ws'≈zs' , _ , zs≡w'∷zs' =
    w' , zs' , (ws' , ws'≈zs') , zs≡w'∷zs'


Cosmetic changes.

Cosmetic changes.

Ignore-this: 981da50b6a4557259e63b1fa4b1d4776

darcs-hash:20101122135209-3bd4e-172a2e198641c1e2c9f1f1fed9823867e89255ca.gz

------------------------------------------------------------------------------
-- Equations for the greatest common divisor
------------------------------------------------------------------------------

module PCF.Examples.GCD.EquationsER where

open import LTC.Base
open import LTC.BaseER using ( subst )

import Lib.Relation.Binary.EqReasoning
open module APER = Lib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

open import PCF.Examples.GCD.GCD using ( gcd ; gcdh )

open import PCF.LTC.Data.Nat
  using ( _-_
        ; N ; sN -- The LTC natural numbers type.
        )
open import PCF.LTC.Data.Nat.Inequalities using ( _>_ ; GT ; LE )
open import PCF.LTC.Data.Nat.Inequalities.PropertiesER using ( x≤y→x≯y )

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

-- Note: This module was written for the version of gcd using the
-- lambda abstractions, but we can use it with the version of gcd
-- using super-combinators.

private
  -- Before to prove some properties for 'gcd i j' it is convenient
  -- to descompose the behavior of the function step by step.

  -- Initially, we define the possible states (gcd-s₁,
  -- gcd-s₂, ...). Then we write down the proof for
  -- the execution step from the state p to the state q
  -- (e.g proof₂₋₃ : (m n : D) → gcd-s₂ m n → gcd-s₃ m n).

  -- The functions gcd-00, gcd-Sm0, gcd-0Sn, gcd-m>n and
  -- gcd-m>n show the use of the states gcd-s₁, gcd-s₂, ..., and the
  -- proofs associated with the execution steps.

  ----------------------------------------------------------------------------
  -- The steps

  -- Initially, the conversion rule fix-f is applied.
  gcd-s₁ : D → D → D
  gcd-s₁ m n = gcdh (fix gcdh) ∙ m ∙ n

  -- First argument application.
  gcd-s₂ : D → D
  gcd-s₂ m = lam (λ n →
                    if (isZero n)
                       then (if (isZero m)
                                then error
                                else m)
                       else (if (isZero m)
                                then n
                                else (if (m > n)
                                         then fix gcdh ∙ (m - n) ∙ n
                                         else fix gcdh ∙ m ∙ (n - m))))

  -- Second argument application.
  gcd-s₃ : D → D → D
  gcd-s₃ m n = if (isZero n)
                  then (if (isZero m)
                           then error
                           else m)
                  else (if (isZero m)
                           then n
                           else (if (m > n)
                                    then fix gcdh ∙ (m - n) ∙ n
                                    else fix gcdh ∙ m ∙ (n - m)))

  -- Conversion (first if_then_else) 'isZero n = b'.
  gcd-s₄ : D → D → D → D
  gcd-s₄ m n b = if b
                  then (if (isZero m)
                           then error
                           else m)
                  else (if (isZero m)
                           then n
                           else (if (m > n)
                                    then fix gcdh ∙ (m - n) ∙ n
                                    else fix gcdh ∙ m ∙ (n - m)))

  -- Conversion first if_then_else when 'if true ...'.
  gcd-s₅ : D → D
  gcd-s₅ m  = if (isZero m) then error else m

  -- Conversion first if_then_else when 'if false ...'.
  gcd-s₆ : D → D → D
  gcd-s₆ m n = if (isZero m)
                  then n
                  else (if (m > n)
                           then fix gcdh ∙ (m - n) ∙ n
                           else fix gcdh ∙ m ∙ (n - m))

  -- Conversion (second if_then_else) 'isZero m = b'.
  gcd-s₇ : D → D → D
  gcd-s₇ m b = if b then error else m

  -- Conversion (third if_then_else) 'isZero m = b'.
  gcd-s₈ : D → D → D → D
  gcd-s₈ m n b = if b
                    then n
                    else (if (m > n)
                             then fix gcdh ∙ (m - n) ∙ n
                             else fix gcdh ∙ m ∙ (n - m))

  -- Conversion third if_then_else, when 'if false ...'.
  gcd-s₉ : D → D → D
  gcd-s₉ m n = if (m > n)
                   then fix gcdh ∙ (m - n) ∙ n
                   else fix gcdh ∙ m ∙ (n - m)

  -- Conversion (fourth if_then_else) 'gt m n = b'.
  gcd-s₁₀ : D → D → D → D
  gcd-s₁₀ m n b = if b
                     then fix gcdh ∙ (m - n) ∙ n
                     else fix gcdh ∙ m ∙ (n - m)

  ----------------------------------------------------------------------------
  -- The execution steps

  {-
  To prove the execution steps
  (e.g. proof₃₋₄ : (m n : D) → gcd-s₃ m n → gcd_s₄ m n),
  we usually need to prove that

                         C [m] ≡ C [n] (1)

  given that
                             m ≡ n,    (2)

  where (2) is a conversion rule usually.
  We prove (1) using
  'subst : {A : Set}(P : A → Set){x y : A} → x ≡ y → P x → P y'
  where
   P is given by λ m → C [m ] ≡ C [n],
   x ≡ y is given n ≡ m (actually, we use sym (m ≡ n)), and
   P x is given by C [n] ≡ C [n] (i.e. refl).
  -}

  -- Application of the conversion rule fix-f.
  proof₀₋₁ : (m n : D) → fix gcdh ∙ m ∙ n ≡ gcd-s₁ m n
  proof₀₋₁ m n = subst (λ x → x ∙ m ∙ n ≡ gcdh (fix gcdh) ∙ m ∙ n)
                       (sym (fix-f gcdh))
                       refl

  -- Application of the first argument.
  proof₁₋₂ : (m n : D) → gcd-s₁ m n ≡ gcd-s₂ m ∙ n
  proof₁₋₂ m n = subst (λ x → x ∙ n ≡ gcd-s₂ m ∙ n)
                       (sym (beta gcd-s₂ m))
                       refl

  -- Second argument application.
  proof₂₋₃ : (m n : D) → gcd-s₂ m ∙ n ≡ gcd-s₃ m n
  proof₂₋₃ m n  = beta (gcd-s₃ m) n

  -- Conversion (first if_then_else) 'isZero n = b' using that proof.
  proof₃₋₄ : (m n b : D) → isZero n ≡ b → gcd-s₃ m n ≡ gcd-s₄ m n b
  proof₃₋₄ m n b prf = subst (λ x → gcd-s₄ m n x ≡ gcd-s₄ m n b)
                             (sym prf)
                             refl

  -- Conversion first if_then_else when 'if true ...' using if-true.
  proof₄₋₅ : (m n : D) → gcd-s₄ m n true ≡ gcd-s₅ m
  proof₄₋₅ m _ = if-true (gcd-s₅ m)

  -- Conversion first if_then_else when 'if false ...' using if-false.
  proof₄₋₆ : (m n : D) → gcd-s₄ m n false ≡ gcd-s₆ m n
  proof₄₋₆ m n = if-false (gcd-s₆ m n)

  -- -- Conversion (second if_then_else) 'isZero m = b' using that proof.
  proof₅₋₇ : (m b : D) → isZero m ≡ b → gcd-s₅ m ≡ gcd-s₇ m b
  proof₅₋₇ m b prf = subst (λ x → gcd-s₇ m x ≡ gcd-s₇ m b)
                           (sym prf)
                           refl

  -- Conversion (third if_then_else) 'isZero m = b' using that proof.
  proof₆₋₈ : (m n b : D) → isZero m ≡ b → gcd-s₆ m n ≡ gcd-s₈ m n b
  proof₆₋₈ m n b prf = subst (λ x → gcd-s₈ m n x ≡ gcd-s₈ m n b)
                             (sym prf)
                             refl

  -- Conversion second if_then_else when 'if true ...' using if-true.
  proof₇₊ : (m : D) → gcd-s₇ m true ≡ error
  proof₇₊ _ = if-true error

  -- Conversion second if_then_else when 'if false ...' using if-false.
  proof₇₋ : (m : D) → gcd-s₇ m false ≡ m
  proof₇₋ m = if-false m

  -- Conversion third if_then_else when 'if true ...' using if-true.
  proof₈₊ : (m n : D) → gcd-s₈ m n true ≡ n
  proof₈₊ _ n = if-true n

  -- Conversion third if_then_else when 'if false ...' using if-false.
  proof₈₋₉ : (m n : D) → gcd-s₈ m n false ≡ gcd-s₉ m n
  proof₈₋₉ m n = if-false (gcd-s₉ m n)

  -- Conversion (fourth if_then_else) 'gt m n = b' using that proof.
  proof₉₋₁₀ : (m n b : D) → m > n ≡ b → gcd-s₉ m n ≡ gcd-s₁₀ m n b
  proof₉₋₁₀ m n b prf = subst (λ x → gcd-s₁₀ m n x ≡ gcd-s₁₀ m n b)
                              (sym prf)
                              refl

  -- Conversion fourth if_then_else when 'if true ...' using if-true.
  proof₁₀₊ : (m n : D) → gcd-s₁₀ m n true ≡ fix gcdh ∙ (m - n) ∙ n
  proof₁₀₊ m n = if-true (fix gcdh ∙ (m - n) ∙ n)

  -- Conversion fourth if_then_else when 'if was ...' using if-false.
  proof₁₀₋ : (m n : D) → gcd-s₁₀ m n false ≡ fix gcdh ∙ m ∙ (n - m)
  proof₁₀₋ m n = if-false (fix gcdh ∙ m ∙ (n - m))

------------------------------------------------------------------------------
-- The five equations for gcd

-- First equation.
-- We do not use this equation for reasoning about gcd.
gcd-00 : gcd zero zero ≡ error
gcd-00 =
  begin
    gcd zero zero         ≡⟨ proof₀₋₁ zero zero ⟩
    gcd-s₁ zero zero      ≡⟨ proof₁₋₂ zero zero ⟩
    gcd-s₂ zero ∙ zero    ≡⟨ proof₂₋₃ zero zero ⟩
    gcd-s₃ zero zero      ≡⟨ proof₃₋₄ zero zero true isZero-0 ⟩
    gcd-s₄ zero zero true ≡⟨ proof₄₋₅ zero zero ⟩
    gcd-s₅ zero           ≡⟨ proof₅₋₇ zero true isZero-0 ⟩
    gcd-s₇ zero true      ≡⟨ proof₇₊  zero ⟩
    error
  ∎

-- Second equation.
gcd-S0 : (m : D) → gcd (succ m) zero ≡ succ m
gcd-S0 m =
  begin
    gcd (succ m) zero         ≡⟨ proof₀₋₁ (succ m) zero ⟩
    gcd-s₁ (succ m) zero      ≡⟨ proof₁₋₂ (succ m) zero ⟩
    gcd-s₂ (succ m) ∙ zero    ≡⟨ proof₂₋₃ (succ m) zero ⟩
    gcd-s₃ (succ m) zero      ≡⟨ proof₃₋₄ (succ m) zero true isZero-0 ⟩
    gcd-s₄ (succ m) zero true ≡⟨ proof₄₋₅ (succ m) zero ⟩
    gcd-s₅ (succ m)           ≡⟨ proof₅₋₇ (succ m) false (isZero-S m) ⟩
    gcd-s₇ (succ m) false     ≡⟨ proof₇₋  (succ m) ⟩
    succ m
  ∎

-- Third equation.
gcd-0S : (n : D) → gcd zero (succ n) ≡ succ n
gcd-0S n =
  begin
    gcd zero (succ n)          ≡⟨ proof₀₋₁ zero (succ n) ⟩
    gcd-s₁ zero (succ n)       ≡⟨ proof₁₋₂ zero (succ n) ⟩
    gcd-s₂ zero ∙ (succ n)     ≡⟨ proof₂₋₃ zero (succ n) ⟩
    gcd-s₃ zero (succ n)       ≡⟨ proof₃₋₄ zero (succ n) false (isZero-S n) ⟩
    gcd-s₄ zero (succ n) false ≡⟨ proof₄₋₆ zero (succ n) ⟩
    gcd-s₆ zero (succ n)       ≡⟨ proof₆₋₈ zero (succ n) true isZero-0 ⟩
    gcd-s₈ zero (succ n) true  ≡⟨ proof₈₊  zero (succ n) ⟩
    succ n
  ∎

-- Fourth equation.
gcd-S>S : (m n : D) → GT (succ m) (succ n) →
          gcd (succ m) (succ n) ≡ gcd (succ m - succ n) (succ n)

gcd-S>S m n Sm>Sn =
  begin
    gcd (succ m) (succ n)          ≡⟨ proof₀₋₁ (succ m) (succ n) ⟩
    gcd-s₁ (succ m) (succ n)       ≡⟨ proof₁₋₂ (succ m) (succ n) ⟩
    gcd-s₂ (succ m) ∙ (succ n)     ≡⟨ proof₂₋₃ (succ m) (succ n) ⟩
    gcd-s₃ (succ m) (succ n)       ≡⟨ proof₃₋₄ (succ m) (succ n)
                                               false (isZero-S n)
                                   ⟩
    gcd-s₄ (succ m) (succ n) false ≡⟨ proof₄₋₆ (succ m) (succ n) ⟩
    gcd-s₆ (succ m) (succ n)       ≡⟨ proof₆₋₈ (succ m) (succ n)
                                               false (isZero-S m)
                                   ⟩
    gcd-s₈ (succ m) (succ n) false ≡⟨ proof₈₋₉ (succ m) (succ n) ⟩
    gcd-s₉ (succ m) (succ n)       ≡⟨ proof₉₋₁₀ (succ m) (succ n) true Sm>Sn ⟩
    gcd-s₁₀ (succ m) (succ n) true ≡⟨ proof₁₀₊  (succ m) (succ n) ⟩
    fix gcdh ∙ (succ m - succ n) ∙ succ n
  ∎

-- TODO: This equation requires N m and N n.
-- Fifth equation.
gcd-S≤S : {m n : D} → N m → N n → LE (succ m) (succ n) →
          gcd (succ m) (succ n) ≡ gcd (succ m) (succ n - succ m)
gcd-S≤S {m} {n} Nm Nn Sm≤Sn =
  begin
    gcd (succ m) (succ n)           ≡⟨ proof₀₋₁ (succ m) (succ n) ⟩
    gcd-s₁ (succ m) (succ n)        ≡⟨ proof₁₋₂ (succ m) (succ n) ⟩
    gcd-s₂ (succ m) ∙ (succ n)      ≡⟨ proof₂₋₃ (succ m) (succ n) ⟩
    gcd-s₃ (succ m) (succ n)        ≡⟨ proof₃₋₄ (succ m) (succ n)
                                                false (isZero-S n)
                                    ⟩
    gcd-s₄ (succ m) (succ n) false  ≡⟨ proof₄₋₆ (succ m) (succ n) ⟩
    gcd-s₆ (succ m) (succ n)        ≡⟨ proof₆₋₈ (succ m) (succ n)
                                                false (isZero-S m)
                                    ⟩
    gcd-s₈ (succ m) (succ n) false  ≡⟨ proof₈₋₉ (succ m) (succ n) ⟩
    gcd-s₉ (succ m) (succ n)        ≡⟨ proof₉₋₁₀ (succ m) (succ n)
                                                 false
                                                 (x≤y→x≯y (sN Nm) (sN Nn) Sm≤Sn)
                                    ⟩
    gcd-s₁₀ (succ m) (succ n) false ≡⟨ proof₁₀₋ (succ m) (succ n) ⟩
    fix gcdh ∙ succ m ∙ (succ n - succ m)
  ∎

------------------------------------------------------------------------------
-- Equations for the greatest common divisor
------------------------------------------------------------------------------

module PCF.Examples.GCD.EquationsER where

open import LTC.Base
open import LTC.BaseER using ( subst )

import Lib.Relation.Binary.EqReasoning
open module APER = Lib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

open import PCF.Examples.GCD.GCD using ( gcd ; gcdh )

open import PCF.LTC.Data.Nat
  using ( _-_
        ; N ; sN -- The LTC natural numbers type.
        )
open import PCF.LTC.Data.Nat.Inequalities using ( _>_ ; GT ; LE )
open import PCF.LTC.Data.Nat.Inequalities.PropertiesER using ( x≤y→x≯y )

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

-- Note: This module was written for the version of gcd using the
-- lambda abstractions, but we can use it with the version of gcd
-- using super-combinators.

private
  -- Before to prove some properties for 'gcd i j' it is convenient
  -- to descompose the behavior of the function step by step.

  -- Initially, we define the possible states (gcd-s₁,
  -- gcd-s₂, ...). Then we write down the proof for
  -- the execution step from the state p to the state q
  -- (e.g proof₂₋₃ : (m n : D) → gcd-s₂ m n → gcd-s₃ m n).

  -- The functions gcd-00, gcd-Sm0, gcd-0Sn, gcd-m>n and
  -- gcd-m>n show the use of the states gcd-s₁, gcd-s₂, ..., and the
  -- proofs associated with the execution steps.

  ----------------------------------------------------------------------------
  -- The steps

  -- Initially, the conversion rule fix-f is applied.
  gcd-s₁ : D → D → D
  gcd-s₁ m n = gcdh (fix gcdh) ∙ m ∙ n

  -- First argument application.
  gcd-s₂ : D → D
  gcd-s₂ m = lam (λ n →
                    if (isZero n)
                       then (if (isZero m)
                                then error
                                else m)
                       else (if (isZero m)
                                then n
                                else (if (m > n)
                                         then fix gcdh ∙ (m - n) ∙ n
                                         else fix gcdh ∙ m ∙ (n - m))))

  -- Second argument application.
  gcd-s₃ : D → D → D
  gcd-s₃ m n = if (isZero n)
                  then (if (isZero m)
                           then error
                           else m)
                  else (if (isZero m)
                           then n
                           else (if (m > n)
                                    then fix gcdh ∙ (m - n) ∙ n
                                    else fix gcdh ∙ m ∙ (n - m)))

  -- Conversion (first if_then_else) 'isZero n = b'.
  gcd-s₄ : D → D → D → D
  gcd-s₄ m n b = if b
                  then (if (isZero m)
                           then error
                           else m)
                  else (if (isZero m)
                           then n
                           else (if (m > n)
                                    then fix gcdh ∙ (m - n) ∙ n
                                    else fix gcdh ∙ m ∙ (n - m)))

  -- Conversion first if_then_else when 'if true ...'.
  gcd-s₅ : D → D
  gcd-s₅ m  = if (isZero m) then error else m

  -- Conversion first if_then_else when 'if false ...'.
  gcd-s₆ : D → D → D
  gcd-s₆ m n = if (isZero m)
                  then n
                  else (if (m > n)
                           then fix gcdh ∙ (m - n) ∙ n
                           else fix gcdh ∙ m ∙ (n - m))

  -- Conversion (second if_then_else) 'isZero m = b'.
  gcd-s₇ : D → D → D
  gcd-s₇ m b = if b then error else m

  -- Conversion (third if_then_else) 'isZero m = b'.
  gcd-s₈ : D → D → D → D
  gcd-s₈ m n b = if b
                    then n
                    else (if (m > n)
                             then fix gcdh ∙ (m - n) ∙ n
                             else fix gcdh ∙ m ∙ (n - m))

  -- Conversion third if_then_else, when 'if false ...'.
  gcd-s₉ : D → D → D
  gcd-s₉ m n = if (m > n)
                   then fix gcdh ∙ (m - n) ∙ n
                   else fix gcdh ∙ m ∙ (n - m)

  -- Conversion (fourth if_then_else) 'gt m n = b'.
  gcd-s₁₀ : D → D → D → D
  gcd-s₁₀ m n b = if b
                     then fix gcdh ∙ (m - n) ∙ n
                     else fix gcdh ∙ m ∙ (n - m)

  ----------------------------------------------------------------------------
  -- The execution steps

  {-
  To prove the execution steps
  (e.g. proof₃₋₄ : (m n : D) → gcd-s₃ m n → gcd_s₄ m n),
  we usually need to prove that

                         C [m] ≡ C [n] (1)

  given that
                             m ≡ n,    (2)

  where (2) is a conversion rule usually.
  We prove (1) using
  'subst : {A : Set}(P : A → Set){x y : A} → x ≡ y → P x → P y'
  where
   P is given by λ m → C [m ] ≡ C [n],
   x ≡ y is given n ≡ m (actually, we use sym (m ≡ n)), and
   P x is given by C [n] ≡ C [n] (i.e. refl).
  -}

  -- Application of the conversion rule fix-f.
  proof₀₋₁ : (m n : D) → fix gcdh ∙ m ∙ n ≡ gcd-s₁ m n
  proof₀₋₁ m n = subst (λ x → x ∙ m ∙ n ≡ gcdh (fix gcdh) ∙ m ∙ n)
                       (sym (fix-f gcdh))
                       refl

  -- Application of the first argument.
  proof₁₋₂ : (m n : D) → gcd-s₁ m n ≡ gcd-s₂ m ∙ n
  proof₁₋₂ m n = subst (λ x → x ∙ n ≡ gcd-s₂ m ∙ n) (sym (beta gcd-s₂ m)) refl

  -- Second argument application.
  proof₂₋₃ : (m n : D) → gcd-s₂ m ∙ n ≡ gcd-s₃ m n
  proof₂₋₃ m n  = beta (gcd-s₃ m) n

  -- Conversion (first if_then_else) 'isZero n = b' using that proof.
  proof₃₋₄ : (m n b : D) → isZero n ≡ b → gcd-s₃ m n ≡ gcd-s₄ m n b
  proof₃₋₄ m n b prf = subst (λ x → gcd-s₄ m n x ≡ gcd-s₄ m n b)
                             (sym prf )
                             refl

  -- Conversion first if_then_else when 'if true ...' using if-true.
  proof₄₋₅ : (m n : D) → gcd-s₄ m n true ≡ gcd-s₅ m
  proof₄₋₅ m _ = if-true (gcd-s₅ m)

  -- Conversion first if_then_else when 'if false ...' using if-false.
  proof₄₋₆ : (m n : D) → gcd-s₄ m n false ≡ gcd-s₆ m n
  proof₄₋₆ m n = if-false (gcd-s₆ m n)

  -- -- Conversion (second if_then_else) 'isZero m = b' using that proof.
  proof₅₋₇ : (m b : D) → isZero m ≡ b → gcd-s₅ m ≡ gcd-s₇ m b
  proof₅₋₇ m b prf = subst (λ x → gcd-s₇ m x ≡ gcd-s₇ m b)
                           (sym prf )
                           refl

  -- Conversion (third if_then_else) 'isZero m = b' using that proof.
  proof₆₋₈ : (m n b : D) → isZero m ≡ b → gcd-s₆ m n ≡ gcd-s₈ m n b
  proof₆₋₈ m n b prf = subst (λ x → gcd-s₈ m n x ≡ gcd-s₈ m n b)
                              (sym prf)
                              refl

  -- Conversion second if_then_else when 'if true ...' using if-true.
  proof₇₊ : (m : D) → gcd-s₇ m true ≡ error
  proof₇₊ _ = if-true error

  -- Conversion second if_then_else when 'if false ...' using if-false.
  proof₇₋ : (m : D) → gcd-s₇ m false ≡ m
  proof₇₋ m = if-false m

  -- Conversion third if_then_else when 'if true ...' using if-true.
  proof₈₊ : (m n : D) → gcd-s₈ m n true ≡ n
  proof₈₊ _ n = if-true n

  -- Conversion third if_then_else when 'if false ...' using if-false.
  proof₈₋₉ : (m n : D) → gcd-s₈ m n false ≡ gcd-s₉ m n
  proof₈₋₉ m n = if-false (gcd-s₉ m n)

  -- Conversion (fourth if_then_else) 'gt m n = b' using that proof.
  proof₉₋₁₀ : (m n b : D) → m > n ≡ b → gcd-s₉ m n ≡ gcd-s₁₀ m n b
  proof₉₋₁₀ m n b prf = subst (λ x → gcd-s₁₀ m n x ≡ gcd-s₁₀ m n b)
                              (sym prf)
                              refl

  -- Conversion fourth if_then_else when 'if true ...' using if-true.
  proof₁₀₊ : (m n : D) → gcd-s₁₀ m n true ≡ fix gcdh ∙ (m - n) ∙ n
  proof₁₀₊ m n = if-true (fix gcdh ∙ (m - n) ∙ n)

  -- Conversion fourth if_then_else when 'if was ...' using if-false.
  proof₁₀₋ : (m n : D) → gcd-s₁₀ m n false ≡ fix gcdh ∙ m ∙ (n - m)
  proof₁₀₋ m n = if-false (fix gcdh ∙ m ∙ (n - m))

------------------------------------------------------------------------------
-- The five equations for gcd

-- First equation.
-- We do not use this equation for reasoning about gcd.
gcd-00 : gcd zero zero ≡ error
gcd-00 =
  begin
    gcd zero zero         ≡⟨ proof₀₋₁ zero zero ⟩
    gcd-s₁ zero zero      ≡⟨ proof₁₋₂ zero zero ⟩
    gcd-s₂ zero ∙ zero    ≡⟨ proof₂₋₃ zero zero ⟩
    gcd-s₃ zero zero      ≡⟨ proof₃₋₄ zero zero true isZero-0 ⟩
    gcd-s₄ zero zero true ≡⟨ proof₄₋₅ zero zero ⟩
    gcd-s₅ zero           ≡⟨ proof₅₋₇ zero true isZero-0 ⟩
    gcd-s₇ zero true      ≡⟨ proof₇₊  zero ⟩
    error
  ∎

-- Second equation.
gcd-S0 : (m : D) → gcd (succ m) zero ≡ succ m
gcd-S0 m =
  begin
    gcd (succ m) zero         ≡⟨ proof₀₋₁ (succ m) zero ⟩
    gcd-s₁ (succ m) zero      ≡⟨ proof₁₋₂ (succ m) zero ⟩
    gcd-s₂ (succ m) ∙ zero    ≡⟨ proof₂₋₃ (succ m) zero ⟩
    gcd-s₃ (succ m) zero      ≡⟨ proof₃₋₄ (succ m) zero true isZero-0 ⟩
    gcd-s₄ (succ m) zero true ≡⟨ proof₄₋₅ (succ m) zero ⟩
    gcd-s₅ (succ m)           ≡⟨ proof₅₋₇ (succ m) false (isZero-S m) ⟩
    gcd-s₇ (succ m) false     ≡⟨ proof₇₋  (succ m) ⟩
    succ m
  ∎

-- Third equation.
gcd-0S : (n : D) → gcd zero (succ n) ≡ succ n
gcd-0S n =
  begin
    gcd zero (succ n)          ≡⟨ proof₀₋₁ zero (succ n) ⟩
    gcd-s₁ zero (succ n)       ≡⟨ proof₁₋₂ zero (succ n) ⟩
    gcd-s₂ zero ∙ (succ n)     ≡⟨ proof₂₋₃ zero (succ n) ⟩
    gcd-s₃ zero (succ n)       ≡⟨ proof₃₋₄ zero (succ n) false (isZero-S n) ⟩
    gcd-s₄ zero (succ n) false ≡⟨ proof₄₋₆ zero (succ n) ⟩
    gcd-s₆ zero (succ n)       ≡⟨ proof₆₋₈ zero (succ n) true isZero-0 ⟩
    gcd-s₈ zero (succ n) true  ≡⟨ proof₈₊  zero (succ n) ⟩
    succ n
  ∎

-- Fourth equation.
gcd-S>S : (m n : D) → GT (succ m) (succ n) →
          gcd (succ m) (succ n) ≡ gcd (succ m - succ n) (succ n)

gcd-S>S m n Sm>Sn =
  begin
    gcd (succ m) (succ n)          ≡⟨ proof₀₋₁ (succ m) (succ n) ⟩
    gcd-s₁ (succ m) (succ n)       ≡⟨ proof₁₋₂ (succ m) (succ n) ⟩
    gcd-s₂ (succ m) ∙ (succ n)     ≡⟨ proof₂₋₃ (succ m) (succ n) ⟩
    gcd-s₃ (succ m) (succ n)       ≡⟨ proof₃₋₄ (succ m) (succ n)
                                               false (isZero-S n)
                                   ⟩
    gcd-s₄ (succ m) (succ n) false ≡⟨ proof₄₋₆ (succ m) (succ n) ⟩
    gcd-s₆ (succ m) (succ n)       ≡⟨ proof₆₋₈ (succ m) (succ n)
                                               false (isZero-S m)
                                   ⟩
    gcd-s₈ (succ m) (succ n) false ≡⟨ proof₈₋₉ (succ m) (succ n) ⟩
    gcd-s₉ (succ m) (succ n)       ≡⟨ proof₉₋₁₀ (succ m) (succ n) true Sm>Sn ⟩
    gcd-s₁₀ (succ m) (succ n) true ≡⟨ proof₁₀₊  (succ m) (succ n) ⟩
    fix gcdh ∙ (succ m - succ n) ∙ succ n
  ∎

-- TODO: This equation requires N m and N n.
-- Fifth equation.
gcd-S≤S : {m n : D} → N m → N n → LE (succ m) (succ n) →
          gcd (succ m) (succ n) ≡ gcd (succ m) (succ n - succ m)
gcd-S≤S {m} {n} Nm Nn Sm≤Sn =
  begin
    gcd (succ m) (succ n)           ≡⟨ proof₀₋₁ (succ m) (succ n) ⟩
    gcd-s₁ (succ m) (succ n)        ≡⟨ proof₁₋₂ (succ m) (succ n) ⟩
    gcd-s₂ (succ m) ∙ (succ n)      ≡⟨ proof₂₋₃ (succ m) (succ n) ⟩
    gcd-s₃ (succ m) (succ n)        ≡⟨ proof₃₋₄ (succ m) (succ n)
                                                false (isZero-S n)
                                    ⟩
    gcd-s₄ (succ m) (succ n) false  ≡⟨ proof₄₋₆ (succ m) (succ n) ⟩
    gcd-s₆ (succ m) (succ n)        ≡⟨ proof₆₋₈ (succ m) (succ n)
                                                false (isZero-S m)
                                    ⟩
    gcd-s₈ (succ m) (succ n) false  ≡⟨ proof₈₋₉ (succ m) (succ n) ⟩
    gcd-s₉ (succ m) (succ n)        ≡⟨ proof₉₋₁₀ (succ m) (succ n)
                                                 false
                                                 (x≤y→x≯y (sN Nm) (sN Nn) Sm≤Sn)
                                    ⟩
    gcd-s₁₀ (succ m) (succ n) false ≡⟨ proof₁₀₋ (succ m) (succ n) ⟩
    fix gcdh ∙ succ m ∙ (succ n - succ m)
  ∎


Added missing module.

Added missing module.

Ignore-this: b1d8c2d0e90bb5f4874cf5181001321

darcs-hash:20110306025334-3bd4e-fde575b74ea4bced9c1a439dec94a46ed58839c0.gz

------------------------------------------------------------------------------
-- All the common modules
------------------------------------------------------------------------------

module Common.Everything where

open import Common.Data.Empty
open import Common.Data.Product
open import Common.Data.Sum
open import Common.Data.Unit

open import Common.Function

open import Common.LogicalConstants

open import Common.Relation.Binary.PreorderReasoning
open import Common.Relation.Binary.PropositionalEquality
open import Common.Relation.Nullary
open import Common.Relation.Unary

open import Common.Universe

------------------------------------------------------------------------------
-- All the common modules
------------------------------------------------------------------------------

module Common.Everything where

open import Common.Data.Empty
open import Common.Data.Product
open import Common.Data.Sum
open import Common.Data.Unit

open import Common.Function

open import Common.LogicalConstants

open import Common.Relation.Binary.PreorderReasoning
open import Common.Relation.Binary.PropositionalEquality
open import Common.Relation.Unary

open import Common.Universe