few more cases of #14, including an elided exercise in loop unrolling

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity
open import lemmas-progress-checks

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time: that boxed values, indeterminates, cast errors, and
-- expressions that step are pairwise disjoint.
--
-- note that as a consequence of currying and comutativity of products,
-- this means that there are six theorems to prove. in addition to those,
-- we also prove several convenince forms that combine theorems about
-- indeterminate and boxed value forms into the same statement about final
-- forms, which mirrors the mutual definition of indeterminate and final
-- and saves some redundant argumentation.
module progress-checks where
  -- boxed values are not indeterminates
  boxedval-not-indet : ∀{d} → d boxedval → d indet → ⊥
  boxedval-not-indet (BVVal VConst) ()
  boxedval-not-indet (BVVal VLam) ()
  boxedval-not-indet (BVArrCast x bv) (ICastArr x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastGroundHole x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = boxedval-not-indet bv ind

  -- boxed values are not errors
  boxedval-not-err : ∀{d} → d boxedval → d casterr → ⊥
  boxedval-not-err (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  boxedval-not-err (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  boxedval-not-err (BVArrCast x bv) (CECong FHOuter er) = boxedval-not-err bv (ce-castarr er)
  boxedval-not-err (BVArrCast x bv) (CECong (FHCast x₁) er) = boxedval-not-err bv (CECong x₁ er)
  boxedval-not-err (BVHoleCast x bv) (CECong FHOuter er) = boxedval-not-err bv (ce-castth er)
  boxedval-not-err (BVHoleCast x bv) (CECong (FHCast x₁) er) = boxedval-not-err bv (CECong x₁ er)
  boxedval-not-err (BVVal x) (CECong FHOuter er) = boxedval-not-err (BVVal x) er
  boxedval-not-err (BVVal ()) (CECong (FHAp1 x₁) er)
  boxedval-not-err (BVVal ()) (CECong (FHAp2 x₁ x₂) er)
  boxedval-not-err (BVVal ()) (CECong (FHNEHole x₁) er)
  boxedval-not-err (BVVal ()) (CECong (FHCast x₁) er)

  -- boxed values don't step
  boxedval-not-step : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  boxedval-not-step (BVVal VConst) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVVal VLam) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  boxedval-not-step (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)
  boxedval-not-step (BVHoleCast () bv) (d' , Step FHOuter (ITCastID x₁) FHOuter)
  boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
  boxedval-not-step (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround x₁ x₂) FHOuter) = x₂ refl
  boxedval-not-step (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- indeterminates are not errors
    indet-not-err : ∀{d} → d indet → d casterr → ⊥
    indet-not-err IEHole (CECong FHOuter err) = indet-not-err IEHole err
    indet-not-err (INEHole x) (CECong FHOuter err) = final-not-err x (ce-nehole err)
    indet-not-err (INEHole x) (CECong (FHNEHole x₁) err) = final-not-err x (CECong x₁ err)
    indet-not-err (IAp x indet x₁) (CECong FHOuter err)
      with ce-ap err
    ... | Inl d1err = indet-not-err indet d1err
    ... | Inr d2err = final-not-err x₁ d2err
    indet-not-err (IAp x indet x₁) (CECong (FHAp1 x₂) err) = indet-not-err indet (CECong x₂ err)
    indet-not-err (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = final-not-err x₁ (CECong x₃ err)
    indet-not-err (ICastArr x indet) (CECong FHOuter err) = indet-not-err indet (ce-castarr err)
    indet-not-err (ICastArr x indet) (CECong (FHCast x₁) err) = indet-not-err indet (CECong x₁ err)
    indet-not-err (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    indet-not-err (ICastGroundHole x indet) (CECong FHOuter err) = indet-not-err indet (ce-castth err)
    indet-not-err (ICastGroundHole x indet) (CECong (FHCast x₁) err) = indet-not-err indet (CECong x₁ err)
    indet-not-err (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    indet-not-err (ICastHoleGround x indet x₁) (CECong FHOuter err) = indet-not-err indet (ce-castht err x)
    indet-not-err (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = indet-not-err indet (CECong x₂ err)

    -- final expressions are not errors
    final-not-err : ∀{d} → d final → d casterr → ⊥
    final-not-err (FBoxed x) err = boxedval-not-err x err
    final-not-err (FIndet x) err = indet-not-err x err

  mutual
    -- indeterminates don't step
    indet-not-step : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    indet-not-step IEHole (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = final-sub-not-trans x x₁ x₂
    indet-not-step (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    indet-not-step (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄)
    indet-not-step (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = final-not-step f (_ , Step x₃ x₄ x₆)
    indet-not-step (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    indet-not-step (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    indet-not-step (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround _ y) FHOuter) = y refl
    indet-not-step (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    indet-not-step (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    indet-not-step (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)

    -- final expressions don't step
    final-not-step : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    final-not-step (FBoxed x) stp = boxedval-not-step x stp
    final-not-step (FIndet x) stp = indet-not-step x stp

  -- errors don't step
  err-not-step : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    -- cast fail cases
  err-not-step (CECastFail x x₁ () x₃) (_ , Step FHOuter (ITCastID x₄) FHOuter)
  err-not-step (CECastFail x x₁ x₂ x₃) (_ , Step FHOuter (ITCastSucceed x₄ x₅) FHOuter) = x₃ refl
  err-not-step (CECastFail x x₁ GHole x₃) (_ , Step FHOuter (ITExpand x₄ x₅) FHOuter) = x₅ refl
  err-not-step (CECastFail x () x₂ x₃) (_ , Step (FHCast FHOuter) (ITCastID x₄) (FHCast FHOuter))
  err-not-step (CECastFail x () x₂ x₃) (_ , Step (FHCast FHOuter) (ITCastSucceed x₄ x₅) (FHCast FHOuter))
  err-not-step (CECastFail x GHole x₂ x₃) (_ , Step (FHCast FHOuter) (ITGround x₄ x₅) (FHCast FHOuter)) = x₅ refl
  err-not-step (CECastFail x x₁ x₂ x₃) (_ , Step (FHCast (FHCast x₄)) x₅ (FHCast (FHCast x₆))) = final-not-step x (_ , Step x₄ x₅ x₆)

    -- congruence cases
  err-not-step (CECong FHOuter ce) (π1 , Step FHOuter x₂ FHOuter) = err-not-step ce (π1 , Step FHOuter x₂ FHOuter)
  err-not-step (CECong (FHAp1 FHOuter) (CECong FHOuter ce)) (_ , Step FHOuter (ITLam x₂) FHOuter) = boxedval-not-err (BVVal VLam) ce
  err-not-step (CECong (FHAp1 x) ce) (_ , Step FHOuter (ITApCast x₁ x₂) FHOuter) = {!!} -- final-not-err x₁ (CECong {!!} ce) -- proably case on x, but get incomplete pattern garbage
  err-not-step (CECong (FHAp2 x x₁) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!} -- cyrus: possibly another counter example
  err-not-step (CECong (FHNEHole x) ce) (π1 , Step FHOuter () FHOuter)
  err-not-step (CECong (FHCast x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!} -- cyrus: only obvious thing to do is case on x₂, doesn't seem to get anywhere

  err-not-step (CECong FHOuter ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃))
    with ce-ap ce
  ... | Inl d1err = err-not-step d1err (_ , Step x₁ x₂ x₃)
  ... | Inr d2err = {!Step x₁ x₂ x₃!} -- cyrus: this is a counter example, d2 is a casterror but d1 isn't yet a value so the whole thing steps
  err-not-step (CECong (FHAp1 x) ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = final-not-step x (_ , Step x₂ x₃ x₄)

  err-not-step (CECong FHOuter ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅))
    with ce-ap ce
  ... | Inl d1err = final-not-err x₄ d1err
  ... | Inr d2err = err-not-step d2err (_ , Step x₂ x₃ x₅)
  err-not-step (CECong (FHAp1 x) ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = final-not-err x₁ (ce-out-cast ce x)
  err-not-step (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = err-not-step (ce-out-cast ce x₁) (_ , Step x₃ x₄ x₆)

  err-not-step (CECong FHOuter ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = err-not-step (ce-nehole ce) (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHNEHole x) ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)

  err-not-step (CECong FHOuter ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!} -- err-not-step {!!} (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHCast x) ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity
open import lemmas-progress-checks

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that boxed values, indeterminates, cast
-- errors, and expressions that step are pairwise disjoint. (note that as a
-- consequence of currying and comutativity of products, this means that
-- there are six theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  boxedval-not-indet : ∀{d} → d boxedval → d indet → ⊥
  boxedval-not-indet (BVVal VConst) ()
  boxedval-not-indet (BVVal VLam) ()
  boxedval-not-indet (BVArrCast x bv) (ICastArr x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastGroundHole x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = boxedval-not-indet bv ind

  -- boxed values and errors are disjoint
  boxedval-not-err : ∀{d} → d boxedval → d casterr → ⊥
  boxedval-not-err (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  boxedval-not-err (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  boxedval-not-err (BVArrCast x bv) (CECong FHOuter er) = boxedval-not-err bv (ce-castarr er)
  boxedval-not-err (BVArrCast x bv) (CECong (FHCast x₁) er) = boxedval-not-err bv (CECong x₁ er)
  boxedval-not-err (BVHoleCast x bv) (CECong FHOuter er) = boxedval-not-err bv (ce-castth er)
  boxedval-not-err (BVHoleCast x bv) (CECong (FHCast x₁) er) = boxedval-not-err bv (CECong x₁ er)
  boxedval-not-err (BVVal x) (CECong FHOuter er) = boxedval-not-err (BVVal x) er
  boxedval-not-err (BVVal ()) (CECong (FHAp1 x₁) er)
  boxedval-not-err (BVVal ()) (CECong (FHAp2 x₁ x₂) er)
  boxedval-not-err (BVVal ()) (CECong (FHNEHole x₁) er)
  boxedval-not-err (BVVal ()) (CECong (FHCast x₁) er)

  -- boxed values and expressions that step are disjoint
  boxedval-not-step : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  boxedval-not-step (BVVal VConst) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVVal VLam) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  boxedval-not-step (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)
  boxedval-not-step (BVHoleCast () bv) (d' , Step FHOuter (ITCastID x₁) FHOuter)
  boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
  boxedval-not-step (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround x₁ x₂) FHOuter) = x₂ refl
  boxedval-not-step (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- indeterminates and errors are disjoint
    indet-not-err : ∀{d} → d indet → d casterr → ⊥
    indet-not-err IEHole (CECong FHOuter err) = indet-not-err IEHole err
    indet-not-err (INEHole x) (CECong FHOuter err) = final-not-err x (ce-nehole err)
    indet-not-err (INEHole x) (CECong (FHNEHole x₁) err) = final-not-err x (CECong x₁ err)
    indet-not-err (IAp x indet x₁) (CECong FHOuter err)
      with ce-ap err
    ... | Inl d1err = indet-not-err indet d1err
    ... | Inr d2err = final-not-err x₁ d2err
    indet-not-err (IAp x indet x₁) (CECong (FHAp1 x₂) err) = indet-not-err indet (CECong x₂ err)
    indet-not-err (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = final-not-err x₁ (CECong x₃ err)
    indet-not-err (ICastArr x indet) (CECong FHOuter err) = indet-not-err indet (ce-castarr err)
    indet-not-err (ICastArr x indet) (CECong (FHCast x₁) err) = indet-not-err indet (CECong x₁ err)
    indet-not-err (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    indet-not-err (ICastGroundHole x indet) (CECong FHOuter err) = indet-not-err indet (ce-castth err)
    indet-not-err (ICastGroundHole x indet) (CECong (FHCast x₁) err) = indet-not-err indet (CECong x₁ err)
    indet-not-err (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    indet-not-err (ICastHoleGround x indet x₁) (CECong FHOuter err) = indet-not-err indet (ce-castht err x)
    indet-not-err (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = indet-not-err indet (CECong x₂ err)

    -- final expressions are not errors
    final-not-err : ∀{d} → d final → d casterr → ⊥
    final-not-err (FBoxed x) err = boxedval-not-err x err
    final-not-err (FIndet x) err = indet-not-err x err

  mutual
    -- indeterminates and expressions that step are disjoint
    indet-not-step : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    indet-not-step IEHole (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = final-sub-not-trans x x₁ x₂
    indet-not-step (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    indet-not-step (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄)
    indet-not-step (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = final-not-step f (_ , Step x₃ x₄ x₆)
    indet-not-step (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    indet-not-step (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    indet-not-step (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround _ y) FHOuter) = y refl
    indet-not-step (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    indet-not-step (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    indet-not-step (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)

    -- final expressions don't step
    final-not-step : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    final-not-step (FBoxed x) stp = boxedval-not-step x stp
    final-not-step (FIndet x) stp = indet-not-step x stp

  -- errors and expressions that step are disjoint
  err-not-step : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    -- cast fail cases
  err-not-step (CECastFail x x₁ () x₃) (_ , Step FHOuter (ITCastID x₄) FHOuter)
  err-not-step (CECastFail x x₁ x₂ x₃) (_ , Step FHOuter (ITCastSucceed x₄ x₅) FHOuter) = x₃ refl
  err-not-step (CECastFail x x₁ GHole x₃) (_ , Step FHOuter (ITExpand x₄ x₅) FHOuter) = x₅ refl
  err-not-step (CECastFail x () x₂ x₃) (_ , Step (FHCast FHOuter) (ITCastID x₄) (FHCast FHOuter))
  err-not-step (CECastFail x () x₂ x₃) (_ , Step (FHCast FHOuter) (ITCastSucceed x₄ x₅) (FHCast FHOuter))
  err-not-step (CECastFail x GHole x₂ x₃) (_ , Step (FHCast FHOuter) (ITGround x₄ x₅) (FHCast FHOuter)) = x₅ refl
  err-not-step (CECastFail x x₁ x₂ x₃) (_ , Step (FHCast (FHCast x₄)) x₅ (FHCast (FHCast x₆))) = final-not-step x (_ , Step x₄ x₅ x₆)

    -- congruence cases
  err-not-step (CECong FHOuter ce) (π1 , Step FHOuter x₂ FHOuter) = err-not-step ce (π1 , Step FHOuter x₂ FHOuter)
  err-not-step (CECong (FHAp1 FHOuter) (CECong FHOuter ce)) (_ , Step FHOuter (ITLam x₂) FHOuter) = boxedval-not-err (BVVal VLam) ce
  err-not-step (CECong (FHAp1 x) ce) (_ , Step FHOuter (ITApCast x₁ x₂) FHOuter) = {!!}  -- fe x₁ (CECong {!ce-out-cast ce!} ce)
  err-not-step (CECong (FHAp2 x x₁) ce) (π1 , Step FHOuter x₂ FHOuter) = {!ce-out-cast ce x₁!}
  err-not-step (CECong (FHNEHole x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!}
  err-not-step (CECong (FHCast x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!}

  err-not-step (CECong FHOuter ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃))
    with ce-ap ce
  ... | Inl d1err = err-not-step d1err (_ , Step x₁ x₂ x₃)
  ... | Inr d2err = {!Step x₁ x₂ x₃!} -- cyrus this is a counter example: d2 is a casterror but d1 isn't yet a value so the whole thing steps
  err-not-step (CECong (FHAp1 x) ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = final-not-step x (_ , Step x₂ x₃ x₄)

  err-not-step (CECong FHOuter ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅))
    with ce-ap ce
  ... | Inl d1err = final-not-err x₄ d1err
  ... | Inr d2err = err-not-step d2err (_ , Step x₂ x₃ x₅)
  err-not-step (CECong (FHAp1 x) ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  err-not-step (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = {!!}

  err-not-step (CECong FHOuter ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = err-not-step (ce-nehole ce) (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHNEHole x) ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)

  err-not-step (CECong FHOuter ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!} -- err-not-step {!!} (_ , Step x₁ x₂ x₃) -- this might not work
  err-not-step (CECong (FHCast x) ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)


Typo.

Typo.

Ignore-this: 59c6c0863d6e6aaabad15e16de6dd83

darcs-hash:20120223161854-3bd4e-069e05e6ab9b3c8e18f2242c558fee7bc0105f2b.gz

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Standard.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe.
-- We chose the symbol M because there are non-standard models of
-- Peano Arithmetic, where the domain is not the set of natural
-- numbers.
open import FOL.Universe public renaming ( D to M )

-- FOL with equality.
open import FOL.FOL-Eq public

-- Non-logical constants
postulate
  zero    : M
  succ    : M → M
  _+_ _*_ : M → M → M

-- Proper axioms
-- From [Machover, 1977, p. 263] and [Hájeck and Pudlák, 1998, p. 28]
--
-- * Moshé Machover. Set theory, logic and their
--   limitations. Cambridge University Press, 1996.
--
-- * Petr Hájeck and Pavel Pudlák. Metamathematics of First-Order
--   Arithmetic. Springer, 1998. 2nd printing.
-- )

-- A₁. 0 ≠ succ n
-- A₂. succ m = succ n → m = n
-- A₃. 0 + n = n
-- A₄. succ m + n = succ (m + n)
-- A₅. 0 * n = 0
-- A₆. succ m * n = (m * n) + n
-- A₇. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  A₁ : ∀ {n} → ¬ (zero ≡ succ n)
  A₂ : ∀ {m n} → succ m ≡ succ n → m ≡ n
  A₃ : ∀ n → zero + n ≡ n
  A₄ : ∀ m n → succ m + n ≡ succ (m + n)
  A₅ : ∀ n → zero * n ≡ zero
  A₆ : ∀ m n → succ m * n ≡ n + m * n
{-# ATP axiom A₁ A₂ A₃ A₄ A₅ A₆ #-}

-- A₇ is an axiom schema, therefore we do not translate it to TPTP.
postulate A₇ : (P : M → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Standard.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe.
-- We chose the symbol M because there are non-standard models of
-- Peano Arithmetic, where the domain is not the set of natural
-- numbers.
open import FOL.Universe public renaming ( D to M )

-- FOL with equality.
open import FOL.FOL-Eq public

-- Non-logical constants
postulate
  zero    : M
  succ    : M → M
  _+_ _*_ : M → M → M

-- Proper axioms (see [Machover, 1977, p. 263], [Hájeck and Pudlák,
  1998, p. 28])
--
-- * Moshé Machover. Set theory, logic and their
--   limitations. Cambridge University Press, 1996.
--
-- * Petr Hájeck and Pavel Pudlák. Metamathematics of First-Order
--   Arithmetic. Springer, 1998. 2nd printing.

-- A₁. 0 ≠ succ n
-- A₂. succ m = succ n → m = n
-- A₃. 0 + n = n
-- A₄. succ m + n = succ (m + n)
-- A₅. 0 * n = 0
-- A₆. succ m * n = (m * n) + n
-- A₇. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  A₁ : ∀ {n} → ¬ (zero ≡ succ n)
  A₂ : ∀ {m n} → succ m ≡ succ n → m ≡ n
  A₃ : ∀ n → zero + n ≡ n
  A₄ : ∀ m n → succ m + n ≡ succ (m + n)
  A₅ : ∀ n → zero * n ≡ zero
  A₆ : ∀ m n → succ m * n ≡ n + m * n
{-# ATP axiom A₁ A₂ A₃ A₄ A₅ A₆ #-}

-- A₇ is an axiom schema, therefore we do not translate it to TPTP.
postulate A₇ : (P : M → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n


Made a module private.

Made a module private.

Ignore-this: c8dd74d9a93a0ee413fd3a59fffc49f4

darcs-hash:20120305232020-3bd4e-b6b668cdb5a1c4ff19d99a001ea15a451288921a.gz

------------------------------------------------------------------------------
-- Equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infix 7 _≈_

------------------------------------------------------------------------------
-- The equality on streams.
postulate
  _≈_ : D → D → Set

-- The relation _≈_ is the greatest post-fixed point (by ≈-gfp₁ and
-- ≈-gfp₂) of the bisimulation functional (see below).

-- The relation _≈_ is a post-fixed point of the bisimulation functional
-- (see below).
postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-gfp₂ : (_R_ : D → D → Set) →
           -- R is a post-fixed point of the bisimulation functional.
           (∀ {xs ys} → xs R ys →
            ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
            xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
           -- _≈_ is greater than R.
           ∀ {xs ys} → xs R ys → xs ≈ ys

-- Because a greatest post-fixed point is a fixed point, the relation
-- _≈_ is also a pre-fixed point of the bisimulation functional (see
-- below).
≈-gfp₃ : ∀ {xs ys} →
         (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
          xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
         xs ≈ ys
≈-gfp₃ h = ≈-gfp₂ _R_ helper h
  where
  _R_ : D → D → Set
  _R_ xs ys = ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  helper : ∀ {xs ys} → xs R ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper (_ , _ , _ , xs'≈ys' , prf) = _ , _ , _ , ≈-gfp₁ xs'≈ys' , prf

private
  module Bisimulation where
  -- In FOTC we won't use the bisimulation functional. This module is
  -- only for illustrative purposes.

  -- Adapted from [1]. In this paper the authors use the name

  -- as (R :: R') bs' (p. 310)

  -- for the bisimulation functional.

  -- [1] Peter Dybjer and Herbert Sander. A functional programming
  -- approach to the specification and verification of concurrent
  -- systems. Formal Aspects of Computing, 1:303–319, 1989.

  -- The bisimulation functional (Bart Jacobs and Jan
  -- Rutten. (Co)algebras and (co)induction. EATCS Bulletin,
  -- 62:222–259, 1997).
  Bisimulation : (D → D → Set) → D → D → Set
  Bisimulation _R_ xs ys =
    ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  -- The relation _≈_ is the greatest post-fixed point of
  -- Bisimulation (by post-fp and gpfp).

  -- The relation _≈_ is a post-fixed point of Bisimulation.
  post-fp : ∀ {xs ys} → xs ≈ ys → Bisimulation _≈_ xs ys
  post-fp = ≈-gfp₁

  gpfp : (_R_ : D → D → Set) →
         -- R is a post-fixed point of Bisimulation.
         (∀ {xs ys} → xs R ys → Bisimulation _R_ xs ys) →
         -- _≈_ is greater than R.
         ∀ {xs ys} → xs R ys → xs ≈ ys
  gpfp = ≈-gfp₂

  -- The relation _≈_ is a pre-fixed point of Bisimulation.
  pre-fp : ∀ {xs ys} → Bisimulation _≈_ xs ys → xs ≈ ys
  pre-fp = ≈-gfp₃

------------------------------------------------------------------------------
-- Equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infix 7 _≈_

------------------------------------------------------------------------------
-- The equality on streams.
postulate
  _≈_ : D → D → Set

-- The relation _≈_ is the greatest post-fixed point (by ≈-gfp₁ and
-- ≈-gfp₂) of the bisimulation functional (see below).

-- The relation _≈_ is a post-fixed point of the bisimulation functional
-- (see below).
postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-gfp₂ : (_R_ : D → D → Set) →
           -- R is a post-fixed point of the bisimulation functional.
           (∀ {xs ys} → xs R ys →
            ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
            xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
           -- _≈_ is greater than R.
           ∀ {xs ys} → xs R ys → xs ≈ ys

-- Because a greatest post-fixed point is a fixed point, the relation
-- _≈_ is also a pre-fixed point of the bisimulation functional (see
-- below).
≈-gfp₃ : ∀ {xs ys} →
         (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
          xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
         xs ≈ ys
≈-gfp₃ h = ≈-gfp₂ _R_ helper h
  where
  _R_ : D → D → Set
  _R_ xs ys = ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  helper : ∀ {xs ys} → xs R ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper (_ , _ , _ , xs'≈ys' , prf) = _ , _ , _ , ≈-gfp₁ xs'≈ys' , prf

module Bisimulation where
  -- In FOTC we won't use the bisimulation functional. This module is
  -- only for illustrative purposes.

  -- Adapted from [1]. In this paper the authors use the name

  -- as (R :: R') bs' (p. 310)

  -- for the bisimulation functional.

  -- [1] Peter Dybjer and Herbert Sander. A functional programming
  -- approach to the specification and verification of concurrent
  -- systems. Formal Aspects of Computing, 1:303–319, 1989.

  -- The bisimulation functional (Bart Jacobs and Jan
  -- Rutten. (Co)algebras and (co)induction. EATCS Bulletin,
  -- 62:222–259, 1997).
  Bisimulation : (D → D → Set) → D → D → Set
  Bisimulation _R_ xs ys =
    ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  -- The relation _≈_ is the greatest post-fixed point of
  -- Bisimulation (by post-fp and gpfp).

  -- The relation _≈_ is a post-fixed point of Bisimulation.
  post-fp : ∀ {xs ys} → xs ≈ ys → Bisimulation _≈_ xs ys
  post-fp = ≈-gfp₁

  gpfp : (_R_ : D → D → Set) →
         -- R is a post-fixed point of Bisimulation.
         (∀ {xs ys} → xs R ys → Bisimulation _R_ xs ys) →
         -- _≈_ is greater than R.
         ∀ {xs ys} → xs R ys → xs ≈ ys
  gpfp = ≈-gfp₂

  -- The relation _≈_ is a pre-fixed point of Bisimulation.
  pre-fp : ∀ {xs ys} → Bisimulation _≈_ xs ys → xs ≈ ys
  pre-fp = ≈-gfp₃


-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level.NP
open import Data.Product
open import Data.One

open import Relation.Binary.PropositionalEquality.NP

module Control.Protocol.Choreography where

Π· : ∀ {a b}(A : ★_ a) → (B : ..(_ : A) → ★_ b) → ★_ (a ⊔ b)
Π· A B = ..(x : A) → B x

data ☐ {a}(A : ★_ a) : ★_ a where
  [_] : ..(x : A) → ☐ A

un☐ : ∀ {a b}{A : ★_ a}{B : ☐ A → ★_ b} → (..(x : A) → B [ x ]) → Π (☐ A) B
un☐ f [ x ] = f x

map☐ : ∀ {a b}{A : ★_ a}{B : ★_ b} → (..(x : A) → B) → ☐ A → ☐ B
map☐ f [ x ] = [ f x ]

data InOut : ★ where
  In Out : InOut

dualInOut : InOut → InOut
dualInOut In  = Out
dualInOut Out = In

data Proto : ★₁ where
  end : Proto
  com  : (q : InOut)(M : ★)(P : M → Proto) → Proto

infix 0 _≡ᴾ_
data _≡ᴾ_ : Proto → Proto → ★₁ where
  end : end ≡ᴾ end
  com : ∀ q M {P Q} → (∀ m → P m ≡ᴾ Q m) → com q M P ≡ᴾ com q M Q

pattern Π' M P = com In  M P
pattern Σ' M P = com Out M P
{-
Π' : (M : ★)(P : M → Proto) → Proto
Π' M P = com In  M P

Σ' : (M : ★)(P : M → Proto) → Proto
Σ' M P = com Out M P
-}

ΠS' : (M : ★)(P : ..(_ : M) → Proto) → Proto
ΠS' M P = Π' (☐ M) (λ { [ m ] → P m })

ΣS' : (M : ★)(P : ..(_ : M) → Proto) → Proto
ΣS' M P = Σ' (☐ M) (λ { [ m ] → P m })

⟦_⟧ΠΣ : InOut → (M : ★) (P : M → ★) → ★
⟦_⟧ΠΣ In  = Π
⟦_⟧ΠΣ Out = Σ

⟦_⟧ : Proto → ★
⟦ end       ⟧ = 𝟙
⟦ com q M P ⟧ = ⟦ q ⟧ΠΣ M λ x → ⟦ P x ⟧

data Choreo (I : ★) : ★₁ where
  _-[_]→_⁏_ : (A : I) (M : ★) (B : I) (ℂ : ..(m : M) → Choreo I) → Choreo I
  _-[_]→★⁏_ : (A : I) (M : ★)         (ℂ :   (m : M) → Choreo I) → Choreo I
  end       : Choreo I

_-[_]→ø⁏_ : ∀ {I}(A : I) (M : ★)         (ℂ : ..(m : M) → Choreo I) → Choreo I
A -[ M ]→ø⁏ ℂ = A -[ ☐ M ]→★⁏ λ { [ m ] → ℂ m }

data [_/_≡_] {I} : Choreo I → I → Proto → ★₁ where
  IΣD : ∀ {A B   M ℂ ℂA} → (∀   m → [ ℂ m / A ≡ ℂA m ]) → [ (A -[ M ]→ B ⁏ ℂ) / A ≡ Σ' M ℂA ]
  IΠD : ∀ {A B   M ℂ ℂB} → (∀   m → [ ℂ m / B ≡ ℂB m ]) → [ (A -[ M ]→ B ⁏ ℂ) / B ≡ Π' M ℂB ]
--  IΠS : ∀ {A B C M ℂ ℂC} → (∀ ..m → [ ℂ m / C ≡ ℂC m ]) → [ (A -[ M ]→ B ⁏ ℂ) / C ≡ Π' (☐ M) ℂC ]
  ★ΣD : ∀ {A     M ℂ ℂA} → (∀   m → [ ℂ m / A ≡ ℂA m ]) → [ (A -[ M ]→★⁏   ℂ) / A ≡ Σ' M ℂA ]
  ★ΠD : ∀ {A B   M ℂ ℂB} → (∀   m → [ ℂ m / B ≡ ℂB m ]) → [ (A -[ M ]→★⁏   ℂ) / B ≡ Π' M ℂB ]
  --øΣD : ∀ {A     M ℂ ℂA} → (∀ ..m → [ ℂ m / A ≡ ℂA m ]) → [ (A -[ M ]→ø⁏   ℂ) / A ≡ Σ' S M ℂA ]
  --øΠD : ∀ {A B   M ℂ ℂB} → (∀ ..m → [ ℂ m / B ≡ ℂB m ]) → [ (A -[ M ]→ø⁏   ℂ) / B ≡ Π' S M ℂB ]
  end : ∀ {A} → [ end / A ≡ end ]

Trace : Proto → Proto
Trace end          = end
Trace (com _ A B) = Σ' A λ m → Trace (B m)

dual : Proto → Proto
dual end = end
dual (com q A B) = com (dualInOut q) A (λ x → dual (B x))

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
    ≡ᴾ-sound : ∀ {P Q} → P ≡ᴾ Q → P ≡ Q
    ≡ᴾ-sound end           = refl
    ≡ᴾ-sound (com q M P≡Q) = cong (com q M) (funExt λ m → ≡ᴾ-sound (P≡Q m))

≡ᴾ-refl : ∀ P → P ≡ᴾ P
≡ᴾ-refl end         = end
≡ᴾ-refl (com q M P) = com q M (λ m → ≡ᴾ-refl (P m))

Trace-idempotent : ∀ P → Trace (Trace P) ≡ᴾ Trace P
Trace-idempotent end = end
Trace-idempotent (com q M P) = Σ' M λ m → Trace-idempotent (P m)

Trace-dual-oblivious : ∀ P → Trace (dual P) ≡ᴾ Trace P
Trace-dual-oblivious end = end
Trace-dual-oblivious (com q M P) = Σ' M λ m → Trace-dual-oblivious (P m)

Tele : Proto → ★
Tele P = ⟦ Trace P ⟧

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
com π A B >>≡ Q = com π A (λ x → B x >>≡ (λ xs → Q (x , xs)))

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q

++Tele : ∀ (P : Proto){Q : Tele P → Proto} (xs : Tele P) → Tele (Q xs) → Tele (P >>≡ Q)
++Tele end         _        ys = ys
++Tele (com q M P) (x , xs) ys = x , ++Tele (P x) xs ys

right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ᴾ P
right-unit end = end
right-unit (com q M P) = com q M λ m → right-unit (P m)

assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P x y))) ≡ᴾ ((P >>≡ Q) >>≡ R)
assoc end         Q R = ≡ᴾ-refl (Q _ >>≡ R)
assoc (com q M P) Q R = com q M λ m → assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

data DualInOut : InOut → InOut → ★ where
  DInOut : DualInOut In  Out
  DOutIn : DualInOut Out In

data Dual : Proto → Proto → ★₁ where
  end : Dual end end
  Π·Σ : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Π' A B) (Σ' A B')
  Σ·Π : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Σ' A B) (Π' A B')

data Sing {a} {A : ★_ a} : ..(x : A) → ★_ a where
  sing : ∀ x → Sing x

-- Commit = λ M R → Σ' D (☐ M) λ { [ m ] → Π' D R λ r → Σ' D (Sing m) (λ _ → end) }
Commit = λ M R → ΣS' M λ m → Π' R λ r → Σ' (Sing m) (λ _ → end)

commit : ∀ M R (m : M)  → ⟦ Commit M R ⟧
commit M R m = [ m ] , (λ x → (sing m) , _)

decommit : ∀ M R (r : R) → ⟦ dual (Commit M R) ⟧
decommit M R r = λ { [ m ] → r , (λ x → 0₁) }

data [_&_≡_]InOut : InOut → InOut → InOut → ★₁ where
  ΠXX : ∀ {X} → [ In & X  ≡ X ]InOut
  XΠX : ∀ {X} → [ X  & In ≡ X ]InOut

&InOut-comm : ∀ {P Q R} → [ P & Q ≡ R ]InOut → [ Q & P ≡ R ]InOut
&InOut-comm ΠXX = XΠX
&InOut-comm XΠX = ΠXX

data [_&_≡_] : Proto → Proto → Proto → ★₁ where
  end& : ∀ {P} → [ end & P ≡ P ]
  &end : ∀ {P} → [ P & end ≡ P ]
  D&D  : ∀ {qP qQ qR M P Q R}(q : [ qP & qQ ≡ qR ]InOut)(P& : ∀   m → [ P m     & Q m     ≡ R m ]) → [ com qP    M  P & com qQ    M  Q ≡ com qR M R ]
  S&D  : ∀ {qP qQ qR M P Q R}(q : [ qP & qQ ≡ qR ]InOut)(P& : ∀   m → [ P [ m ] & Q m     ≡ R m ]) → [ com qP (☐ M) P & com qQ    M  Q ≡ com qR M R ]
  D&S  : ∀ {qP qQ qR M P Q R}(q : [ qP & qQ ≡ qR ]InOut)(P& : ∀   m → [ P m     & Q [ m ] ≡ R m ]) → [ com qP    M  P & com qQ (☐ M) Q ≡ com qR M R ]

&-comm : ∀ {P Q R} → [ P & Q ≡ R ] → [ Q & P ≡ R ]
&-comm end& = &end
&-comm &end = end&
&-comm (D&D q P&) = D&D (&InOut-comm q) (λ m → &-comm (P& m))
&-comm (S&D q P&) = D&S (&InOut-comm q) (λ m → &-comm (P& m))
&-comm (D&S q P&) = S&D (&InOut-comm q) (λ m → &-comm (P& m))

DualInOut-sym : ∀ {P Q} → DualInOut P Q → DualInOut Q P
DualInOut-sym DInOut = DOutIn
DualInOut-sym DOutIn = DInOut

Dual-sym : ∀ {P Q} → Dual P Q → Dual Q P
Dual-sym end = end
Dual-sym (Π·Σ f) = Σ·Π (λ x → Dual-sym (f x))
Dual-sym (Σ·Π f) = Π·Σ (λ x → Dual-sym (f x))

DualInOut-spec : ∀ P → DualInOut P (dualInOut P)
DualInOut-spec In  = DInOut
DualInOut-spec Out = DOutIn

Dual-spec : ∀ P → Dual P (dual P)
Dual-spec end = end
Dual-spec (com In M P) = Π·Σ (λ x → Dual-spec (P x))
Dual-spec (com Out M P) = Σ·Π (λ x → Dual-spec (P x))

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele (dual P) ≡ Tele P
  dual-Tele P = cong ⟦_⟧ (≡ᴾ-sound funExt (Trace-dual-oblivious P))

El : (P : Proto) → (Tele P → ★) → ★
El end         X = X _
El (com q M P) X = ⟦ q ⟧ΠΣ M λ x → El (P x) (λ y → X (x , y))

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto){Q : Tele P → Proto}{X : Tele (P >>≡ Q) → ★} → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P x y)))
  bind-spec end         = refl
  bind-spec (com q M P) = cong (⟦ q ⟧ΠΣ M) (funExt λ m → bind-spec (P m))

module _ {A B} where
  run-com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  run-com end      a       b       = a , b
  run-com (Π' M P) p       (m , q) = run-com (P m) (p m) q
  run-com (Σ' M P) (m , p) q       = run-com (P m) p (q m)

com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
com-cont end p q = (_ , p)  , (_ , q)
com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  recv : ∀ {M P} → ((m : M) → this (P m)) → ProcessF this (Π' M P)
  send : ∀ {M P} (m : M) → this (P m) → ProcessF this (Σ' M P)

recvS : ∀ {this : Proto → ★₁}{M}{P : ☐ M → Proto} → (..(m : M) → this (P [ m ])) → ProcessF this (Π' (☐ M) P)
recvS = recv ∘ un☐

sendS : ∀ {this : Proto → ★₁}{M}{P : ☐ M → Proto} ..(m : M) → this (P [ m ]) → ProcessF this (Σ' (☐ M) P)
sendS m = send [ m ]

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

mutual
  SimL : Proto → Proto → ★₁
  SimL P Q = ProcessF (flip Sim Q) P

  SimR : Proto → Proto → ★₁
  SimR P Q = ProcessF (Sim P) Q

  data Sim : Proto → Proto → ★₁ where
    left  : ∀ {q M P Q} → SimL (com q M P) Q → Sim (com q M P) Q
    right : ∀ {P q M Q} → SimR P (com q M Q) → Sim P (com q M Q)
    end   : Sim end end

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

{-
sim& : ∀ {PA PB PAB} → [ PA & PB ≡ PAB ] → Sim end PA → Sim end PB → Sim end PAB
sim&R : ∀ {PA PB PAB} → [ PA & PB ≡ PAB ] → SimR end PA → SimR end PB → SimR end PAB

sim& P& (right ·PA) (right ·PB) = {! (sim&R P& ·PA ·PB)!}
sim& end& PA PB = PB
sim& &end PA PB = PA

sim&R (ΠDΣDΣS P&) (recv PQA)   (send m PQB) = sendS m (sim& (P& m) (PQA m) PQB)
sim&R (ΠDΠDΠD P&) (recv PQA)   (recv PQB)   = recv λ m → sim& (P& m) (PQA m) (PQB m)
sim&R (ΠS-S-S P&) (recvS PQA)   (recvS PQB)   = recvS λ m → sim& (P& m) (PQA m) (PQB m)
sim&R (ΠS-S-S P&) (recvS PQA)   (sendS m PQB) = sendS m (sim& (P& m) (PQA m) PQB)
sim&R (ΠS-D-D P&) (recvS PQA)   (recv PQB)   = recv λ m → sim& (P& m) (PQA m) (PQB m)
sim&R (ΠS-D-D P&) (recvS PQA)   (send m PQB) = send m (sim& (P& m) (PQA m) PQB)
sim&R (ΣDΠDΣS P&) (send m PQA) (recv PQB)   = sendS m (sim& (P& m) PQA (PQB m))
sim&R &end _ ()
-}

{-
sim&R (ΣDΠDΣS x) (send x₁ x₂) (recv x₃) = {!!}
-}

{-
sim& : ∀ {PA PB PAB QA QB QAB} → [ PA & PB ≡ PAB ] → [ QA & QB ≡ QAB ] → Sim PA QA → Sim PB QB → Sim PAB QAB
sim&L : ∀ {PA PB PAB QA QB QAB} → [ PA & PB ≡ PAB ] → [ QA & QB ≡ QAB ] → SimL PA QA → SimL PB QB → SimL PAB QAB
sim&R : ∀ {PA PB PAB QA QB QAB} → [ PA & PB ≡ PAB ] → [ QA & QB ≡ QAB ] → SimR PA QA → SimR PB QB → SimR PAB QAB

sim& P& Q& (left PQA) (left PQB) = left (sim&L P& Q& PQA PQB)
sim& P& Q& (left PQA) (right PQB) = {!!}
sim& P& Q& (left PQA) end = {!!}
sim& P& Q& (right x) PQB = {!!}
sim& P& Q& end PQB = {!!}

sim&L (ΠDΣDΣS P&) Q& (recv PQA)   (send m PQB) = sendS m (sim& (P& m) Q& (PQA m) PQB)
sim&L (ΠDΠDΠD P&) Q& (recv PQA)   (recv PQB)   = recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&L (ΠS-S-S P&) Q& (recvS PQA)   (recvS PQB)   = recvS λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&L (ΠS-S-S P&) Q& (recvS PQA)   (sendS m PQB) = sendS m (sim& (P& m) Q& (PQA m) PQB)
sim&L (ΠS-D-D P&) Q& (recvS PQA)   (recv PQB)   = recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&L (ΠS-D-D P&) Q& (recvS PQA)   (send m PQB) = send m (sim& (P& m) Q& (PQA m) PQB)
sim&L (ΣDΠDΣS P&) Q& (send m PQA) (recv PQB)   = sendS m (sim& (P& m) Q& PQA (PQB m))
sim&L &end Q& PQA ()

{-
sim&R (ΠDΣDΣS P&) Q& (recv PQA)   (send m PQB) = ?
sim&R (ΠDΠDΠD P&) Q& (recv PQA)   (recv PQB)   = ? -- recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&R (ΠS-S-S P&) Q& (recvS PQA)   (recvS PQB)   = ? -- recvS λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&R (ΠS-S-S P&) Q& (recvS PQA)   (sendS m PQB) = ? -- sendS m (sim& (P& m) Q& (PQA m) PQB)
sim&R (ΠS-D-D P&) Q& (recvS PQA)   (recv PQB)   = ? -- recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&R (ΠS-D-D P&) Q& (recvS PQA)   (send m PQB) = ? -- send m (sim& (P& m) Q& (PQA m) PQB)
sim&R (ΣDΠDΣS P&) Q& (send m PQA) (recv PQB)   = ? -- sendS m (sim& (P& m) Q& PQA (PQB m))
sim&R end& Q& PQA PQB = ?
-}
-}

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' A B) = right (recv (λ x → left (send x (sim-id (B x)))))
sim-id (Σ' A B) = left (recv (λ x → right (send x (sim-id (B x)))))

sim-comp : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → Sim Q' R → Sim P R
sim-compRL : ∀ {P Q Q' R} → Dual Q Q' → SimR P Q → SimL Q' R → Sim P R
sim-compL : ∀ {P Q Q' R} → Dual Q Q' → SimL P Q → Sim Q' R → SimL P R
sim-compR : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → SimR Q' R → SimR P R

sim-comp Q-Q' (left x) QR = left (sim-compL Q-Q' x QR)
sim-comp Q-Q' (right x) (left x₁) = sim-compRL Q-Q' x x₁
sim-comp Q-Q' (right x) (right x₁) = right (sim-compR Q-Q' (right x) x₁)
sim-comp ()   (right x) end
sim-comp end end QR = QR

sim-compRL end () QR
sim-compRL (Π·Σ x₁) (recv x) (send x₂ x₃) = sim-comp (x₁ x₂) (x x₂) x₃
sim-compRL (Σ·Π x)  (send x₁ x₂) (recv x₃) = sim-comp (x x₁) x₂ (x₃ x₁)

sim-compL Q-Q' (recv PQ) QR = recv (λ m → sim-comp Q-Q' (PQ m) QR)
sim-compL Q-Q' (send m PQ) QR = send m (sim-comp Q-Q' PQ QR)

sim-compR Q-Q' PQ (recv QR)   = recv (λ m → sim-comp Q-Q' PQ (QR m))
sim-compR Q-Q' PQ (send m QR) = send m (sim-comp Q-Q' PQ QR)

_♦_ : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
_♦_ = sim-comp (Dual-spec _)

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = _♦_

!ˢ : ∀ {P Q} → Sim P Q → Sim Q P
sim-symL : ∀ {P Q} → SimL P Q → SimR Q P
sim-symR : ∀ {P Q} → SimR P Q → SimL Q P

!ˢ (left x) = right (sim-symL x)
!ˢ (right x) = left (sim-symR x)
!ˢ end = end

sim-symL (recv PQ)   = recv (λ m → !ˢ (PQ m))
sim-symL (send m PQ) = send m (!ˢ PQ)

sim-symR (recv PQ)   = recv (λ m → !ˢ (PQ m))
sim-symR (send m PQ) = send m (!ˢ PQ)

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (right (recv P)) = do (recv (λ m → sim-unit (P m)))
sim-unit (right (send m P)) = do (send m (sim-unit P))
sim-unit end = end 0₁

module _ where

  mod₁ : ∀ {A A' B : ★} → (A → A') → A × B → A' × B
  mod₁ = λ f → Data.Product.map f id

  mod₂ : ∀ {A B B' : ★} → (B → B') → A × B → A × B'
  mod₂ = λ f → Data.Product.map id f

  trace : ∀ {P P' Q Q'} → Dual P P' → Dual Q Q' →  Sim end P' → Sim P Q → Sim Q' end
        → Tele P × Tele Q
  trace (Π·Σ x₁) Q-Q' (right (send x x₂)) (left (recv x₃)) Q· = mod₁ (_,_ x) (trace (x₁ x) Q-Q' x₂ (x₃ x) Q·)
  trace (Σ·Π x₁) Q-Q' (right (recv x)) (left (send x₂ x₃)) Q· = mod₁ (_,_ x₂) (trace (x₁ x₂) Q-Q' (x x₂) x₃ Q·)
  trace P-P' (Π·Σ x₁) ·P (right (recv x)) (left (send x₂ x₃)) = mod₂ (_,_ x₂) (trace P-P' (x₁ x₂) ·P (x x₂) x₃)
  trace P-P' (Σ·Π x₁) ·P (right (send x x₂)) (left (recv x₃)) = mod₂ (_,_ x) (trace P-P' (x₁ x) ·P x₂ (x₃ x))
  trace P-P' Q-Q' ·P end Q· = _

  module _ {P Q : Proto} where
    _≈_ : (PQ PQ' : Sim P Q) → ★₁
    PQ ≈ PQ' = ∀ {P' Q'}(P-P' : Dual P P')(Q-Q' : Dual Q Q') → (·P : Sim end P')(Q· : Sim Q' end)
       → trace P-P' Q-Q' ·P PQ Q· ≡ trace P-P' Q-Q' ·P PQ' Q·

module _ {P Q : Proto} where
  infix 2 _∼_
  _∼_ : (PQ PQ' : Sim P Q) → ★₁
  PQ ∼ PQ' = ∀ {P'} → (P'-P : Dual P' P) → (øP : Sim end P')
           → sim-comp P'-P øP PQ ≡ sim-comp P'-P øP PQ'

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where

  Dual-sym-sym : ∀ {P Q} (P-Q : Dual P Q) → P-Q ≡ Dual-sym (Dual-sym P-Q)
  Dual-sym-sym end = refl
  Dual-sym-sym (Π·Σ x) = cong Π·Σ (funExt (λ y → Dual-sym-sym (x y)))
  Dual-sym-sym (Σ·Π x) = cong Σ·Π (funExt (λ y → Dual-sym-sym (x y)))

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
  sim-comp-assoc-end : ∀ {P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (øP : Sim end P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' øP PQ) QR
    ≡ sim-comp P-P' øP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc-end (Π·Σ x₁) Q-Q' (right (recv x)) (left (send x₂ x₃)) QR
    = sim-comp-assoc-end (x₁ x₂) Q-Q' (x x₂) x₃ QR
  sim-comp-assoc-end (Σ·Π x) Q-Q' (right (send x₁ x₂)) (left (recv x₃)) QR
    = sim-comp-assoc-end (x x₁) Q-Q' x₂ (x₃ x₁) QR
  sim-comp-assoc-end P-P' (Π·Σ x₁) (right øP) (right (recv x)) (left (send x₂ x₃))
    = sim-comp-assoc-end P-P' (x₁ x₂) (right øP) (x x₂) x₃
  sim-comp-assoc-end P-P' (Σ·Π x) (right øP) (right (send x₁ x₂)) (left (recv x₃))
    = sim-comp-assoc-end P-P' (x x₁) (right øP) x₂ (x₃ x₁)
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (recv x₁))
    = cong (right ∘ recv) (funExt (λ m → sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (x₁ m)))
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (send x₁ x₂))
    = cong (right ∘ send x₁) (sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) x₂)
  sim-comp-assoc-end end Q-Q' end PQ QR = refl

  ♦-assoc-end : ∀ {P Q R}(øP : Sim end P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (øP ♦ PQ) ♦ QR ≡ øP ♦ (PQ ♦ QR)
  ♦-assoc-end = sim-comp-assoc-end (Dual-spec _) (Dual-spec _)

  open ≡-Reasoning
  sim-comp-assoc : ∀ {W P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (WP : Sim W P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' WP PQ) QR
    ∼ sim-comp P-P' WP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc P-P' Q-Q' WP PQ QR {W'} W'-W øW'
    = sim-comp W'-W øW' (sim-comp Q-Q' (sim-comp P-P' WP PQ) QR)
    ≡⟨ sym (sim-comp-assoc-end W'-W Q-Q' øW' (sim-comp P-P' WP PQ) QR) ⟩
      sim-comp Q-Q' (sim-comp W'-W øW' (sim-comp P-P' WP PQ)) QR
    ≡⟨ cong (λ X → sim-comp Q-Q' X QR) (sym (sim-comp-assoc-end W'-W P-P' øW' WP PQ)) ⟩
      sim-comp Q-Q' (sim-comp P-P' (sim-comp W'-W øW' WP) PQ) QR
    ≡⟨ sim-comp-assoc-end P-P' Q-Q' (sim-comp W'-W øW' WP) PQ QR ⟩
      sim-comp P-P' (sim-comp W'-W øW' WP) (sim-comp Q-Q' PQ QR)
    ≡⟨ sim-comp-assoc-end W'-W P-P' øW' WP (sim-comp Q-Q' PQ QR) ⟩
      sim-comp W'-W øW' (sim-comp P-P' WP (sim-comp Q-Q' PQ QR))
    ∎

  ♦-assoc : ∀ {W P Q R}(WP : Sim W P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (WP ♦ PQ) ♦ QR ∼ WP ♦ (PQ ♦ QR)
  ♦-assoc = sim-comp-assoc (Dual-spec _) (Dual-spec _)

∼-ø : ∀ {P}{s s' : Sim end P} → s ∼ s' → s ≡ s'
∼-ø s∼s' = s∼s' end end

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where

  sim-!! : ∀ {P Q}(PQ : Sim P Q) → PQ ≡ !ˢ (!ˢ PQ)
  sim-!! (left (recv x))    = cong (left ∘ recv) (funExt λ m → sim-!! (x m))
  sim-!! (left (send x x₁)) = cong (left ∘ send x) (sim-!! x₁)
  sim-!! (right (recv x))    = cong (right ∘ recv) (funExt λ m → sim-!! (x m))
  sim-!! (right (send x x₁)) = cong (right ∘ send x) (sim-!! x₁)
  sim-!! end = refl

  sim-comp-!-end : ∀ {Q Q' R}(Q-Q' : Dual Q Q')(·Q : Sim end Q)(Q'R : Sim Q' R)
    → sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ ·Q) ≡ !ˢ (sim-comp Q-Q' ·Q Q'R)
  sim-comp-!-end (Π·Σ x₁) (right (recv x)) (left (send x₂ x₃)) = sim-comp-!-end (x₁ x₂) (x x₂) x₃
  sim-comp-!-end (Σ·Π x) (right (send x₁ x₂)) (left (recv x₃)) = sim-comp-!-end (x x₁) x₂ (x₃ x₁)
  sim-comp-!-end Q-Q' (right x) (right (recv x₁))
    = cong (left ∘ recv) (funExt (λ x₂ → sim-comp-!-end Q-Q' (right x) (x₁ x₂)))
  sim-comp-!-end Q-Q' (right x) (right (send x₁ x₂))
    = cong (left ∘ send x₁) (sim-comp-!-end Q-Q' (right x) x₂)
  sim-comp-!-end end end QR = {!!}

  open ≡-Reasoning
  module _ {P Q}{s s' : Sim P Q} where
    !ˢ-cong : s ∼ s' → !ˢ s ∼ !ˢ s'
    !ˢ-cong s∼s' Q'-Q øQ'
      = sim-comp Q'-Q øQ' (!ˢ s)
      ≡⟨ {!!} ⟩
        sim-comp Q'-Q øQ' (!ˢ (sim-comp (Dual-spec Q) s (sim-id _)))
      ≡⟨ {!!} ⟩
        sim-comp Q'-Q øQ' (!ˢ s')
      ∎

  postulate
    sim-comp-assoc-end' : ∀ {P Q Q' R R'}(Q-Q' : Dual Q Q')(R-R' : Dual R R')
      (PQ : Sim P Q)(QR : Sim Q' R )(Rø : Sim R' end)
      → sim-comp R-R' (sim-comp Q-Q' PQ QR) Rø
      ≡ sim-comp Q-Q' PQ (sim-comp R-R' QR Rø)

  sim-comp-! : ∀ {P Q Q' R}(Q-Q' : Dual Q Q')(PQ : Sim P Q)(Q'R : Sim Q' R)
    → sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ) ∼ !ˢ (sim-comp Q-Q' PQ Q'R)
  sim-comp-! Q-Q' PQ Q'R {R'} R'-R øR'
    = sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ))
    ≡⟨ sim-!! (sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ))) ⟩
      !ˢ( !ˢ ((sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ)))))
    ≡⟨ cong (!ˢ ∘ !ˢ) (sym (sim-comp-assoc-end funExt R'-R (Dual-sym Q-Q') øR' (!ˢ Q'R) (!ˢ PQ))) ⟩
      !ˢ
        (!ˢ
         (sim-comp (Dual-sym Q-Q') (sim-comp R'-R øR' (!ˢ Q'R)) (!ˢ PQ)))
    ≡⟨ cong !ˢ (sym (sim-comp-!-end (Dual-sym Q-Q') (sim-comp R'-R øR' (!ˢ Q'R)) (!ˢ PQ))) ⟩
      !ˢ
        (sim-comp (Dual-sym (Dual-sym Q-Q')) (!ˢ (!ˢ PQ))
         (!ˢ (sim-comp R'-R øR' (!ˢ Q'R))))
    ≡⟨ cong₂ (λ X Y → !ˢ (sim-comp X Y (!ˢ (sim-comp R'-R øR' (!ˢ Q'R)))))
         (sym (Dual-sym-sym funExt Q-Q')) (sym (sim-!! PQ)) ⟩
     !ˢ (sim-comp Q-Q' PQ (!ˢ (sim-comp R'-R øR' (!ˢ Q'R))))
    ≡⟨ cong (!ˢ ∘ sim-comp Q-Q' PQ) (sym (sim-comp-!-end R'-R øR' (!ˢ Q'R))) ⟩
      !ˢ
        (sim-comp Q-Q' PQ
         (sim-comp (Dual-sym R'-R) (!ˢ (!ˢ Q'R)) (!ˢ øR')))
    ≡⟨ cong
         (λ X → !ˢ (sim-comp Q-Q' PQ (sim-comp (Dual-sym R'-R) X (!ˢ øR'))))
         (sym (sim-!! Q'R)) ⟩
      !ˢ (sim-comp Q-Q' PQ (sim-comp (Dual-sym R'-R) Q'R (!ˢ øR')))
    -- ≡⟨ cong !ˢ (sym (sim-comp-assoc-end' Q-Q' (Dual-sym R'-R) PQ Q'R (!ˢ øR'))) ⟩
    ≡⟨ ∼-ø {!!}⟩
      !ˢ (sim-comp (Dual-sym R'-R) (sim-comp Q-Q' PQ Q'R) (!ˢ øR'))
    ≡⟨ cong (λ X → !ˢ (sim-comp (Dual-sym R'-R) X (!ˢ øR'))) (sim-!! (sim-comp Q-Q' PQ Q'R)) ⟩
      !ˢ (sim-comp (Dual-sym R'-R) (!ˢ (!ˢ (sim-comp Q-Q' PQ Q'R)))
                                   (!ˢ øR'))
    ≡⟨ cong !ˢ (sim-comp-!-end R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))) ⟩
      !ˢ (!ˢ (sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))))
    ≡⟨ sym (sim-!! (sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R)))) ⟩
      sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))
    ∎

  ♦-! : ∀ {P Q R}(PQ : Sim P Q)(QR : Sim (dual Q) R)
    → !ˢ (PQ ♦ QR) ∼ (!ˢ QR) ♦ (!ˢ {!PQ!})
  ♦-! = {!!}
{-

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (sim-sym PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = refl
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}

-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level.NP
open import Data.Product
open import Data.One

open import Relation.Binary.PropositionalEquality.NP

module Control.Protocol.Choreography where

Π· : ∀ {a b}(A : ★_ a) → (B : ..(_ : A) → ★_ b) → ★_ (a ⊔ b)
Π· A B = ..(x : A) → B x

data ☐ {a}(A : ★_ a) : ★_ a where
  [_] : ..(x : A) → ☐ A
map☐ : ∀ {a b}{A : ★_ a}{B : ★_ b} → (..(x : A) → B) → ☐ A → ☐ B
map☐ f [ x ] = [ f x ]

data InOut : ★ where
  -- Π' Σ' : InOut
  In Out : InOut

data Proto : ★₁ where
  end : Proto
  com  : (q : InOut)(M : ★)(P : M → Proto) → Proto

pattern Π' M P = com In  M P
pattern Σ' M P = com Out M P
{-
Π' : (M : ★)(P : M → Proto) → Proto
Π' M P = com In  M P

Σ' : (M : ★)(P : M → Proto) → Proto
Σ' M P = com Out M P
-}

ΠS' : (M : ★)(P : ..(_ : M) → Proto) → Proto
ΠS' M P = Π' (☐ M) (λ { [ m ] → P m })

ΣS' : (M : ★)(P : ..(_ : M) → Proto) → Proto
ΣS' M P = Σ' (☐ M) (λ { [ m ] → P m })

⟦_⟧ : Proto → ★
⟦ end         ⟧ = 𝟙
⟦ Π' M P ⟧ = Π  M λ x → ⟦ P x ⟧
⟦ Σ' M P ⟧ = Σ  M λ x → ⟦ P x ⟧

data Choreo (I : ★) : ★₁ where
  _-[_]→_⁏_ : (A : I) (M : ★) (B : I) (ℂ : ..(m : M) → Choreo I) → Choreo I
  _-[_]→★⁏_ : (A : I) (M : ★)         (ℂ :   (m : M) → Choreo I) → Choreo I
  end       : Choreo I

_-[_]→ø⁏_ : ∀ {I}(A : I) (M : ★)         (ℂ : ..(m : M) → Choreo I) → Choreo I
A -[ M ]→ø⁏ ℂ = A -[ ☐ M ]→★⁏ λ { [ m ] → ℂ m }

data [_/_≡_] {I} : Choreo I → I → Proto → ★₁ where
  IΣD : ∀ {A B   M ℂ ℂA} → (∀   m → [ ℂ m / A ≡ ℂA m ]) → [ (A -[ M ]→ B ⁏ ℂ) / A ≡ Σ' M ℂA ]
  IΠD : ∀ {A B   M ℂ ℂB} → (∀   m → [ ℂ m / B ≡ ℂB m ]) → [ (A -[ M ]→ B ⁏ ℂ) / B ≡ Π' M ℂB ]
--  IΠS : ∀ {A B C M ℂ ℂC} → (∀ ..m → [ ℂ m / C ≡ ℂC m ]) → [ (A -[ M ]→ B ⁏ ℂ) / C ≡ Π' (☐ M) ℂC ]
  ★ΣD : ∀ {A     M ℂ ℂA} → (∀   m → [ ℂ m / A ≡ ℂA m ]) → [ (A -[ M ]→★⁏   ℂ) / A ≡ Σ' M ℂA ]
  ★ΠD : ∀ {A B   M ℂ ℂB} → (∀   m → [ ℂ m / B ≡ ℂB m ]) → [ (A -[ M ]→★⁏   ℂ) / B ≡ Π' M ℂB ]
  --øΣD : ∀ {A     M ℂ ℂA} → (∀ ..m → [ ℂ m / A ≡ ℂA m ]) → [ (A -[ M ]→ø⁏   ℂ) / A ≡ Σ' S M ℂA ]
  --øΠD : ∀ {A B   M ℂ ℂB} → (∀ ..m → [ ℂ m / B ≡ ℂB m ]) → [ (A -[ M ]→ø⁏   ℂ) / B ≡ Π' S M ℂB ]
  end : ∀ {A} → [ end / A ≡ end ]

Trace : Proto → Proto
Trace end          = end
Trace (com _ A B) = Σ' A λ m → Trace (B m)

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
    Trace-idempotent : ∀ P → Trace (Trace P) ≡ Trace P
    Trace-idempotent end = refl
    Trace-idempotent (com q M P) = cong (Σ' M) (funExt λ m → Trace-idempotent (P m))

Tele : Proto → ★
Tele P = ⟦ Trace P ⟧

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
com π A B >>≡ Q = com π A (λ x → B x >>≡ (λ xs → Q (x , xs)))

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q

++Tele : ∀ (P : Proto)(Q : Tele P → Proto) → (x : Tele P) → Tele (Q x) → Tele (P >>≡ Q)
++Tele end Q x y = y
++Tele (Π' M C) Q (m , x) y = m , ++Tele (C m) (λ x₁ → Q (m , x₁)) x y
++Tele (Σ' M C) Q (m , x) y = m , ++Tele (C m) _ x y

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
  right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ P
  right-unit end = refl
  right-unit (Π' M C) = let p = funExt (λ x → right-unit (C x)) in cong (Π' M) p
  right-unit (Σ' M C) = cong (Σ' M) (funExt (λ x → right-unit (C x)))

  assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P Q x y))) ≡ ((P >>≡ Q) >>≡ R)
  assoc end Q R = refl
  assoc (Π' M C₁) Q R = cong (Π' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (Σ' M C₁) Q R = cong (Σ' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))

_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

dualInOut : InOut → InOut
dualInOut In  = Out
dualInOut Out = In

dual : Proto → Proto
dual end = end
dual (com q A B) = com (dualInOut q) A (λ x → dual (B x))

data DualInOut : InOut → InOut → ★ where
  DInOut : DualInOut In  Out
  DOutIn : DualInOut Out In

data Dual : Proto → Proto → ★₁ where
  end : Dual end end
  Π·Σ : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Π' A B) (Σ' A B')
  Σ·Π : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Σ' A B) (Π' A B')

data Sing {a} {A : ★_ a} : ..(x : A) → ★_ a where
  sing : ∀ x → Sing x

-- Commit = λ M R → Σ' D (☐ M) λ { [ m ] → Π' D R λ r → Σ' D (Sing m) (λ _ → end) }
Commit = λ M R → ΣS' M λ m → Π' R λ r → Σ' (Sing m) (λ _ → end)

commit : ∀ M R (m : M)  → ⟦ Commit M R ⟧
commit M R m = [ m ] , (λ x → (sing m) , _)

decommit : ∀ M R (r : R) → ⟦ dual (Commit M R) ⟧
decommit M R r = λ { [ m ] → r , (λ x → {!!}) }

data [_&_≡_]InOut : InOut → InOut → InOut → ★₁ where
  ΠXX : ∀ {X} → [ In & X  ≡ X ]InOut
  XΠX : ∀ {X} → [ X  & In ≡ X ]InOut

&InOut-comm : ∀ {P Q R} → [ P & Q ≡ R ]InOut → [ Q & P ≡ R ]InOut
&InOut-comm ΠXX = XΠX
&InOut-comm XΠX = ΠXX

  {-
data [_&_≡_] : Proto → Proto → Proto → ★₁ where
  end& : ∀ {P} → [ end & P ≡ P ]
  &end : ∀ {P} → [ P & end ≡ P ]
  XXX  : ∀ {qP qQ qR M P Q R}(q : [ qP & qQ ≡ qR ]InOut)(P& : ∀   m → [ P m & Q m ≡ R m ]) → [ com qP    M  P & com qQ    M  Q ≡ com qR M R ]
  -- SDD  : ∀ {qP qQ qR M P Q R}(q : [ qP & qQ ≡ qR ]InOut)(P& : ∀   m → [ P m & Q m ≡ R m ]) → [ com qP (☐ M) P & com qQ    M  Q ≡ com qR M R ]
  DSD  : ∀ {qP qQ qR M P Q R}(q : [ qP & qQ ≡ qR ]InOut)(P& : ∀   m → [ P m & Q m ≡ R m ]) → [ com qP    M  P & com qQ (☐ M) Q ≡ com qR M R ]

&-comm : ∀ {P Q R} → [ P & Q ≡ R ] → [ Q & P ≡ R ]
&-comm end& = &end
&-comm &end = end&
&-comm (XXX q P&) = XXX (&InOut-comm q) (λ m → &-comm (P& m))
&-comm (SDD q P&) = DSD (&InOut-comm q) (λ m → &-comm (P& m))
&-comm (DSD q P&) = SDD (&InOut-comm q) (λ m → &-comm (P& m))
-}

DualInOut-sym : ∀ {P Q} → DualInOut P Q → DualInOut Q P
DualInOut-sym DInOut = DOutIn
DualInOut-sym DOutIn = DInOut

Dual-sym : ∀ {P Q} → Dual P Q → Dual Q P
Dual-sym end = end
Dual-sym (Π·Σ f) = Σ·Π (λ x → Dual-sym (f x))
Dual-sym (Σ·Π f) = Π·Σ (λ x → Dual-sym (f x))

DualInOut-spec : ∀ P → DualInOut P (dualInOut P)
DualInOut-spec In  = DInOut
DualInOut-spec Out = DOutIn

Dual-spec : ∀ P → Dual P (dual P)
Dual-spec end = end
Dual-spec (com In M P) = Π·Σ (λ x → Dual-spec (P x))
Dual-spec (com Out M P) = Σ·Π (λ x → Dual-spec (P x))

{-
module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele P ≡ Tele (dual P)
  dual-Tele end = refl
  dual-Tele (Π' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (Σ' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (later i P) = ?
-}{-
module _ where
  El : (P : Proto) → (Tele P → ★) → ★
  El end X = X _
  El (Π' A B) X = Π A λ x → El (B x) (λ y → X (x , y))
  El (Σ' A B) X = Σ A λ x → El (B x) (λ y → X (x , y))
  El (later i P) = ?

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto)(Q : Tele P → Proto)(X : Tele (P >>≡ Q) → ★) → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P Q x y)))
  bind-spec end Q X = refl
  bind-spec (Π' A B) Q X = cong (Π A) (funExt (λ x → bind-spec (B x) (λ xs → Q (x , xs)) (λ y → X (x , y))))
  bind-spec (Σ' A B) Q X = cong (Σ A) (funExt (λ x → bind-spec (B x) _ _))
  bind-spec (later i p) Q X = ?

module _ {A B} where
  com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (later i P) x y = ?

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
  com-cont end p q = (_ , p)  , (_ , q)
  com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (later i P) p q = ?
-}

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  recv : ∀ {M P} → ((m : M) → this (P m)) → ProcessF this (Π' M P)
  send : ∀ {M P} (m : M) → this (P m) → ProcessF this (Σ' M P)

{-
recvS : ∀ {this : Proto → ★₁}{M P} → (..(m : M) → this (P m)) → ProcessF this (Π' (☐ M) P)
recvS = ?
sendS : ∀ {M P} → ΠM S M (λ m → this (P m) → ProcessF this (Σ' S M P))
sendS = ?
-}

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

mutual
  SimL : Proto → Proto → ★₁
  SimL P Q = ProcessF (flip Sim Q) P

  SimR : Proto → Proto → ★₁
  SimR P Q = ProcessF (Sim P) Q

  data Sim : Proto → Proto → ★₁ where
    left  : ∀ {q M P Q} → SimL (com q M P) Q → Sim (com q M P) Q
    right : ∀ {P q M Q} → SimR P (com q M Q) → Sim P (com q M Q)
    end   : Sim end end

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

{-
sim& : ∀ {PA PB PAB} → [ PA & PB ≡ PAB ] → Sim end PA → Sim end PB → Sim end PAB
sim&R : ∀ {PA PB PAB} → [ PA & PB ≡ PAB ] → SimR end PA → SimR end PB → SimR end PAB

sim& P& (right ·PA) (right ·PB) = {! (sim&R P& ·PA ·PB)!}
sim& end& PA PB = PB
sim& &end PA PB = PA

sim&R (ΠDΣDΣS P&) (recv PQA)   (send m PQB) = sendS m (sim& (P& m) (PQA m) PQB)
sim&R (ΠDΠDΠD P&) (recv PQA)   (recv PQB)   = recv λ m → sim& (P& m) (PQA m) (PQB m)
sim&R (ΠS-S-S P&) (recvS PQA)   (recvS PQB)   = recvS λ m → sim& (P& m) (PQA m) (PQB m)
sim&R (ΠS-S-S P&) (recvS PQA)   (sendS m PQB) = sendS m (sim& (P& m) (PQA m) PQB)
sim&R (ΠS-D-D P&) (recvS PQA)   (recv PQB)   = recv λ m → sim& (P& m) (PQA m) (PQB m)
sim&R (ΠS-D-D P&) (recvS PQA)   (send m PQB) = send m (sim& (P& m) (PQA m) PQB)
sim&R (ΣDΠDΣS P&) (send m PQA) (recv PQB)   = sendS m (sim& (P& m) PQA (PQB m))
sim&R &end _ ()
-}

{-
sim&R (ΣDΠDΣS x) (send x₁ x₂) (recv x₃) = {!!}
-}

{-
sim& : ∀ {PA PB PAB QA QB QAB} → [ PA & PB ≡ PAB ] → [ QA & QB ≡ QAB ] → Sim PA QA → Sim PB QB → Sim PAB QAB
sim&L : ∀ {PA PB PAB QA QB QAB} → [ PA & PB ≡ PAB ] → [ QA & QB ≡ QAB ] → SimL PA QA → SimL PB QB → SimL PAB QAB
sim&R : ∀ {PA PB PAB QA QB QAB} → [ PA & PB ≡ PAB ] → [ QA & QB ≡ QAB ] → SimR PA QA → SimR PB QB → SimR PAB QAB

sim& P& Q& (left PQA) (left PQB) = left (sim&L P& Q& PQA PQB)
sim& P& Q& (left PQA) (right PQB) = {!!}
sim& P& Q& (left PQA) end = {!!}
sim& P& Q& (right x) PQB = {!!}
sim& P& Q& end PQB = {!!}

sim&L (ΠDΣDΣS P&) Q& (recv PQA)   (send m PQB) = sendS m (sim& (P& m) Q& (PQA m) PQB)
sim&L (ΠDΠDΠD P&) Q& (recv PQA)   (recv PQB)   = recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&L (ΠS-S-S P&) Q& (recvS PQA)   (recvS PQB)   = recvS λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&L (ΠS-S-S P&) Q& (recvS PQA)   (sendS m PQB) = sendS m (sim& (P& m) Q& (PQA m) PQB)
sim&L (ΠS-D-D P&) Q& (recvS PQA)   (recv PQB)   = recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&L (ΠS-D-D P&) Q& (recvS PQA)   (send m PQB) = send m (sim& (P& m) Q& (PQA m) PQB)
sim&L (ΣDΠDΣS P&) Q& (send m PQA) (recv PQB)   = sendS m (sim& (P& m) Q& PQA (PQB m))
sim&L &end Q& PQA ()

{-
sim&R (ΠDΣDΣS P&) Q& (recv PQA)   (send m PQB) = ?
sim&R (ΠDΠDΠD P&) Q& (recv PQA)   (recv PQB)   = ? -- recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&R (ΠS-S-S P&) Q& (recvS PQA)   (recvS PQB)   = ? -- recvS λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&R (ΠS-S-S P&) Q& (recvS PQA)   (sendS m PQB) = ? -- sendS m (sim& (P& m) Q& (PQA m) PQB)
sim&R (ΠS-D-D P&) Q& (recvS PQA)   (recv PQB)   = ? -- recv λ m → sim& (P& m) Q& (PQA m) (PQB m)
sim&R (ΠS-D-D P&) Q& (recvS PQA)   (send m PQB) = ? -- send m (sim& (P& m) Q& (PQA m) PQB)
sim&R (ΣDΠDΣS P&) Q& (send m PQA) (recv PQB)   = ? -- sendS m (sim& (P& m) Q& PQA (PQB m))
sim&R end& Q& PQA PQB = ?
-}
-}

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' A B) = right (recv (λ x → left (send x (sim-id (B x)))))
sim-id (Σ' A B) = left (recv (λ x → right (send x (sim-id (B x)))))

sim-comp : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → Sim Q' R → Sim P R
sim-compRL : ∀ {P Q Q' R} → Dual Q Q' → SimR P Q → SimL Q' R → Sim P R
sim-compL : ∀ {P Q Q' R} → Dual Q Q' → SimL P Q → Sim Q' R → SimL P R
sim-compR : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → SimR Q' R → SimR P R

sim-comp Q-Q' (left x) QR = left (sim-compL Q-Q' x QR)
sim-comp Q-Q' (right x) (left x₁) = sim-compRL Q-Q' x x₁
sim-comp Q-Q' (right x) (right x₁) = right (sim-compR Q-Q' (right x) x₁)
sim-comp ()   (right x) end
sim-comp end end QR = QR

sim-compRL end () QR
sim-compRL (Π·Σ x₁) (recv x) (send x₂ x₃) = sim-comp (x₁ x₂) (x x₂) x₃
sim-compRL (Σ·Π x)  (send x₁ x₂) (recv x₃) = sim-comp (x x₁) x₂ (x₃ x₁)

sim-compL Q-Q' (recv PQ) QR = recv (λ m → sim-comp Q-Q' (PQ m) QR)
sim-compL Q-Q' (send m PQ) QR = send m (sim-comp Q-Q' PQ QR)

sim-compR Q-Q' PQ (recv QR)   = recv (λ m → sim-comp Q-Q' PQ (QR m))
sim-compR Q-Q' PQ (send m QR) = send m (sim-comp Q-Q' PQ QR)

_♦_ : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
_♦_ = sim-comp (Dual-spec _)

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = _♦_

!ˢ : ∀ {P Q} → Sim P Q → Sim Q P
sim-symL : ∀ {P Q} → SimL P Q → SimR Q P
sim-symR : ∀ {P Q} → SimR P Q → SimL Q P

!ˢ (left x) = right (sim-symL x)
!ˢ (right x) = left (sim-symR x)
!ˢ end = end

sim-symL (recv PQ)   = recv (λ m → !ˢ (PQ m))
sim-symL (send m PQ) = send m (!ˢ PQ)

sim-symR (recv PQ)   = recv (λ m → !ˢ (PQ m))
sim-symR (send m PQ) = send m (!ˢ PQ)

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (right (recv P)) = do (recv (λ m → sim-unit (P m)))
sim-unit (right (send m P)) = do (send m (sim-unit P))
sim-unit end = end 0₁

module _ where

  mod₁ : ∀ {A A' B : ★} → (A → A') → A × B → A' × B
  mod₁ = λ f → Data.Product.map f id

  mod₂ : ∀ {A B B' : ★} → (B → B') → A × B → A × B'
  mod₂ = λ f → Data.Product.map id f

  trace : ∀ {P P' Q Q'} → Dual P P' → Dual Q Q' →  Sim end P' → Sim P Q → Sim Q' end
        → Tele P × Tele Q
  trace (Π·Σ x₁) Q-Q' (right (send x x₂)) (left (recv x₃)) Q· = mod₁ (_,_ x) (trace (x₁ x) Q-Q' x₂ (x₃ x) Q·)
  trace (Σ·Π x₁) Q-Q' (right (recv x)) (left (send x₂ x₃)) Q· = mod₁ (_,_ x₂) (trace (x₁ x₂) Q-Q' (x x₂) x₃ Q·)
  trace P-P' (Π·Σ x₁) ·P (right (recv x)) (left (send x₂ x₃)) = mod₂ (_,_ x₂) (trace P-P' (x₁ x₂) ·P (x x₂) x₃)
  trace P-P' (Σ·Π x₁) ·P (right (send x x₂)) (left (recv x₃)) = mod₂ (_,_ x) (trace P-P' (x₁ x) ·P x₂ (x₃ x))
  trace P-P' Q-Q' ·P end Q· = _

  module _ {P Q : Proto} where
    _≈_ : (PQ PQ' : Sim P Q) → ★₁
    PQ ≈ PQ' = ∀ {P' Q'}(P-P' : Dual P P')(Q-Q' : Dual Q Q') → (·P : Sim end P')(Q· : Sim Q' end)
       → trace P-P' Q-Q' ·P PQ Q· ≡ trace P-P' Q-Q' ·P PQ' Q·

module _ {P Q : Proto} where
  infix 2 _∼_
  _∼_ : (PQ PQ' : Sim P Q) → ★₁
  PQ ∼ PQ' = ∀ {P'} → (P'-P : Dual P' P) → (øP : Sim end P')
           → sim-comp P'-P øP PQ ≡ sim-comp P'-P øP PQ'

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where

  Dual-sym-sym : ∀ {P Q} (P-Q : Dual P Q) → P-Q ≡ Dual-sym (Dual-sym P-Q)
  Dual-sym-sym end = refl
  Dual-sym-sym (Π·Σ x) = cong Π·Σ (funExt (λ y → Dual-sym-sym (x y)))
  Dual-sym-sym (Σ·Π x) = cong Σ·Π (funExt (λ y → Dual-sym-sym (x y)))

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
  sim-comp-assoc-end : ∀ {P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (øP : Sim end P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' øP PQ) QR
    ≡ sim-comp P-P' øP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc-end (Π·Σ x₁) Q-Q' (right (recv x)) (left (send x₂ x₃)) QR
    = sim-comp-assoc-end (x₁ x₂) Q-Q' (x x₂) x₃ QR
  sim-comp-assoc-end (Σ·Π x) Q-Q' (right (send x₁ x₂)) (left (recv x₃)) QR
    = sim-comp-assoc-end (x x₁) Q-Q' x₂ (x₃ x₁) QR
  sim-comp-assoc-end P-P' (Π·Σ x₁) (right øP) (right (recv x)) (left (send x₂ x₃))
    = sim-comp-assoc-end P-P' (x₁ x₂) (right øP) (x x₂) x₃
  sim-comp-assoc-end P-P' (Σ·Π x) (right øP) (right (send x₁ x₂)) (left (recv x₃))
    = sim-comp-assoc-end P-P' (x x₁) (right øP) x₂ (x₃ x₁)
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (recv x₁))
    = cong (right ∘ recv) (funExt (λ m → sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (x₁ m)))
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (send x₁ x₂))
    = cong (right ∘ send x₁) (sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) x₂)
  sim-comp-assoc-end end Q-Q' end PQ QR = refl

  ♦-assoc-end : ∀ {P Q R}(øP : Sim end P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (øP ♦ PQ) ♦ QR ≡ øP ♦ (PQ ♦ QR)
  ♦-assoc-end = sim-comp-assoc-end (Dual-spec _) (Dual-spec _)

  open ≡-Reasoning
  sim-comp-assoc : ∀ {W P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (WP : Sim W P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' WP PQ) QR
    ∼ sim-comp P-P' WP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc P-P' Q-Q' WP PQ QR {W'} W'-W øW'
    = sim-comp W'-W øW' (sim-comp Q-Q' (sim-comp P-P' WP PQ) QR)
    ≡⟨ sym (sim-comp-assoc-end W'-W Q-Q' øW' (sim-comp P-P' WP PQ) QR) ⟩
      sim-comp Q-Q' (sim-comp W'-W øW' (sim-comp P-P' WP PQ)) QR
    ≡⟨ cong (λ X → sim-comp Q-Q' X QR) (sym (sim-comp-assoc-end W'-W P-P' øW' WP PQ)) ⟩
      sim-comp Q-Q' (sim-comp P-P' (sim-comp W'-W øW' WP) PQ) QR
    ≡⟨ sim-comp-assoc-end P-P' Q-Q' (sim-comp W'-W øW' WP) PQ QR ⟩
      sim-comp P-P' (sim-comp W'-W øW' WP) (sim-comp Q-Q' PQ QR)
    ≡⟨ sim-comp-assoc-end W'-W P-P' øW' WP (sim-comp Q-Q' PQ QR) ⟩
      sim-comp W'-W øW' (sim-comp P-P' WP (sim-comp Q-Q' PQ QR))
    ∎

  ♦-assoc : ∀ {W P Q R}(WP : Sim W P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (WP ♦ PQ) ♦ QR ∼ WP ♦ (PQ ♦ QR)
  ♦-assoc = sim-comp-assoc (Dual-spec _) (Dual-spec _)

∼-ø : ∀ {P}{s s' : Sim end P} → s ∼ s' → s ≡ s'
∼-ø s∼s' = s∼s' end end

module _
  (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where

  sim-!! : ∀ {P Q}(PQ : Sim P Q) → PQ ≡ !ˢ (!ˢ PQ)
  sim-!! (left (recv x))    = cong (left ∘ recv) (funExt λ m → sim-!! (x m))
  sim-!! (left (send x x₁)) = cong (left ∘ send x) (sim-!! x₁)
  sim-!! (right (recv x))    = cong (right ∘ recv) (funExt λ m → sim-!! (x m))
  sim-!! (right (send x x₁)) = cong (right ∘ send x) (sim-!! x₁)
  sim-!! end = refl

  sim-comp-!-end : ∀ {Q Q' R}(Q-Q' : Dual Q Q')(·Q : Sim end Q)(Q'R : Sim Q' R)
    → sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ ·Q) ≡ !ˢ (sim-comp Q-Q' ·Q Q'R)
  sim-comp-!-end (Π·Σ x₁) (right (recv x)) (left (send x₂ x₃)) = sim-comp-!-end (x₁ x₂) (x x₂) x₃
  sim-comp-!-end (Σ·Π x) (right (send x₁ x₂)) (left (recv x₃)) = sim-comp-!-end (x x₁) x₂ (x₃ x₁)
  sim-comp-!-end Q-Q' (right x) (right (recv x₁))
    = cong (left ∘ recv) (funExt (λ x₂ → sim-comp-!-end Q-Q' (right x) (x₁ x₂)))
  sim-comp-!-end Q-Q' (right x) (right (send x₁ x₂))
    = cong (left ∘ send x₁) (sim-comp-!-end Q-Q' (right x) x₂)
  sim-comp-!-end end end QR = {!!}

  open ≡-Reasoning
  module _ {P Q}{s s' : Sim P Q} where
    !ˢ-cong : s ∼ s' → !ˢ s ∼ !ˢ s'
    !ˢ-cong s∼s' Q'-Q øQ'
      = sim-comp Q'-Q øQ' (!ˢ s)
      ≡⟨ {!!} ⟩
        sim-comp Q'-Q øQ' (!ˢ (sim-comp (Dual-spec Q) s (sim-id _)))
      ≡⟨ {!!} ⟩
        sim-comp Q'-Q øQ' (!ˢ s')
      ∎

  postulate
    sim-comp-assoc-end' : ∀ {P Q Q' R R'}(Q-Q' : Dual Q Q')(R-R' : Dual R R')
      (PQ : Sim P Q)(QR : Sim Q' R )(Rø : Sim R' end)
      → sim-comp R-R' (sim-comp Q-Q' PQ QR) Rø
      ≡ sim-comp Q-Q' PQ (sim-comp R-R' QR Rø)

  sim-comp-! : ∀ {P Q Q' R}(Q-Q' : Dual Q Q')(PQ : Sim P Q)(Q'R : Sim Q' R)
    → sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ) ∼ !ˢ (sim-comp Q-Q' PQ Q'R)
  sim-comp-! Q-Q' PQ Q'R {R'} R'-R øR'
    = sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ))
    ≡⟨ sim-!! (sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ))) ⟩
      !ˢ( !ˢ ((sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ)))))
    ≡⟨ cong (!ˢ ∘ !ˢ) (sym (sim-comp-assoc-end funExt R'-R (Dual-sym Q-Q') øR' (!ˢ Q'R) (!ˢ PQ))) ⟩
      !ˢ
        (!ˢ
         (sim-comp (Dual-sym Q-Q') (sim-comp R'-R øR' (!ˢ Q'R)) (!ˢ PQ)))
    ≡⟨ cong !ˢ (sym (sim-comp-!-end (Dual-sym Q-Q') (sim-comp R'-R øR' (!ˢ Q'R)) (!ˢ PQ))) ⟩
      !ˢ
        (sim-comp (Dual-sym (Dual-sym Q-Q')) (!ˢ (!ˢ PQ))
         (!ˢ (sim-comp R'-R øR' (!ˢ Q'R))))
    ≡⟨ cong₂ (λ X Y → !ˢ (sim-comp X Y (!ˢ (sim-comp R'-R øR' (!ˢ Q'R)))))
         (sym (Dual-sym-sym funExt Q-Q')) (sym (sim-!! PQ)) ⟩
     !ˢ (sim-comp Q-Q' PQ (!ˢ (sim-comp R'-R øR' (!ˢ Q'R))))
    ≡⟨ cong (!ˢ ∘ sim-comp Q-Q' PQ) (sym (sim-comp-!-end R'-R øR' (!ˢ Q'R))) ⟩
      !ˢ
        (sim-comp Q-Q' PQ
         (sim-comp (Dual-sym R'-R) (!ˢ (!ˢ Q'R)) (!ˢ øR')))
    ≡⟨ cong
         (λ X → !ˢ (sim-comp Q-Q' PQ (sim-comp (Dual-sym R'-R) X (!ˢ øR'))))
         (sym (sim-!! Q'R)) ⟩
      !ˢ (sim-comp Q-Q' PQ (sim-comp (Dual-sym R'-R) Q'R (!ˢ øR')))
    -- ≡⟨ cong !ˢ (sym (sim-comp-assoc-end' Q-Q' (Dual-sym R'-R) PQ Q'R (!ˢ øR'))) ⟩
    ≡⟨ ∼-ø {!!}⟩
      !ˢ (sim-comp (Dual-sym R'-R) (sim-comp Q-Q' PQ Q'R) (!ˢ øR'))
    ≡⟨ cong (λ X → !ˢ (sim-comp (Dual-sym R'-R) X (!ˢ øR'))) (sim-!! (sim-comp Q-Q' PQ Q'R)) ⟩
      !ˢ (sim-comp (Dual-sym R'-R) (!ˢ (!ˢ (sim-comp Q-Q' PQ Q'R)))
                                   (!ˢ øR'))
    ≡⟨ cong !ˢ (sim-comp-!-end R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))) ⟩
      !ˢ (!ˢ (sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))))
    ≡⟨ sym (sim-!! (sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R)))) ⟩
      sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))
    ∎

  ♦-! : ∀ {P Q R}(PQ : Sim P Q)(QR : Sim (dual Q) R)
    → !ˢ (PQ ♦ QR) ∼ (!ˢ QR) ♦ (!ˢ {!PQ!})
  ♦-! = {!!}
{-

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (sim-sym PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = refl
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}


Cosmetic changes.

Cosmetic changes.

Ignore-this: b556b22f21ca044a6c7ddf7e1b7f84c5

darcs-hash:20120105125316-3bd4e-49c60ec209442b07dc5649ba80697225c37662ac.gz

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

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

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.Properties.MainATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.MCR
open import FOTC.Program.McCarthy91.MCR.LT2MCR-ATP
open import FOTC.Program.McCarthy91.MCR.Induction.Acc.WellFoundedInductionATP
open import FOTC.Program.McCarthy91.Properties.AuxiliaryATP

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

mc91-N-ineq : ∀ {n} → N n → N (mc91 n) ∧ LT n (mc91 n + eleven)
mc91-N-ineq = wfInd-MCR P mc91-N-ineq-aux
  where
  P : D → Set
  P d = N (mc91 d) ∧ LT d (mc91 d + eleven)

  mc91-N-ineq-aux : ∀ {m} → N m → (∀ {k} → N k → MCR k m → P k) → P m
  mc91-N-ineq-aux {m} Nm f with x>y∨x≤y Nm 100-N
  ... | inj₁ m>100 = ( Nmc91>100 Nm m>100 , x<mc91x+11>100 Nm m>100 )
  ... | inj₂ m≤100 =
    let Nm+11 : N (m + eleven)
        Nm+11 = x+11-N Nm

        ih1 : P (m + eleven)
        ih1 = f Nm+11 (LT2MCR (x+11-N Nm) Nm m≤100 (x<x+11 Nm))

        Nih1 : N (mc91 (m + eleven))
        Nih1 = ∧-proj₁ ih1

        LTih1 : LT (m + eleven) (mc91 (m + eleven) + eleven)
        LTih1 = ∧-proj₂ ih1

        m<mc91m+11 : LT m (mc91 (m + eleven))
        m<mc91m+11 = x+k<y+k→x<y Nm Nih1 11-N LTih1

        ih2 : P (mc91 (m + eleven))
        ih2 = f Nih1 (LT2MCR Nih1 Nm m≤100 m<mc91m+11)

        m≯100 : NGT m one-hundred
        m≯100 = x≤y→x≯y Nm 100-N m≤100

        Nmc91≤100 : N (mc91 m)
        Nmc91≤100 = Nmc91≯100 m m≯100 (∧-proj₁ ih2)

    in ( Nmc91≤100 ,
         <-trans Nm Nih1 (x+11-N Nmc91≤100)
                 m<mc91m+11
                 (mc91x+11<mc91x+11 m m≯100 (∧-proj₂ ih2)))

mc91-res : ∀ {n} → N n → (GT n one-hundred ∧ mc91 n ≡ n ∸ ten) ∨
                         (NGT n one-hundred ∧ mc91 n ≡ ninety-one)
mc91-res = wfInd-MCR P mc91-res-aux
  where
  P : D → Set
  P d = (GT d one-hundred ∧ mc91 d ≡ d ∸ ten) ∨
        (NGT d one-hundred ∧ mc91 d ≡ ninety-one)

  mc91-res-aux : ∀ {m} → N m → (∀ {k} → N k → MCR k m → P k) → P m
  mc91-res-aux {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = inj₁ ( m>100 , mc91-eq-aux m m>100 )
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = inj₂ ( m≯100 , mc91-res-100' m≡100 )
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = inj₂ ( m≯100 , mc91-res-99' m≡99 )
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = inj₂ ( m≯100 , mc91-res-98' m≡98 )
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = inj₂ ( m≯100 , mc91-res-97' m≡97 )
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = inj₂ ( m≯100 , mc91-res-96' m≡96 )
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = inj₂ ( m≯100 , mc91-res-95' m≡95 )
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = inj₂ ( m≯100 , mc91-res-94' m≡94 )
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = inj₂ ( m≯100 , mc91-res-93' m≡93 )
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = inj₂ ( m≯100 , mc91-res-92' m≡92 )
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = inj₂ ( m≯100 , mc91-res-91' m≡91 )
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = inj₂ ( m≯100 , mc91-res-90' m≡90 )
  ... | inj₁ m≯89 = inj₂ ( m≯100 , mc91-res-m≯89 )
    where
    m≤100 : LE m one-hundred
    m≤100 = x≯y→x≤y Nm 100-N m≯100

    m≤89 : LE m eighty-nine
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    mc91-res-m+11 : mc91 (m + eleven) ≡ ninety-one
    mc91-res-m+11 with f (x+11-N Nm) (LT2MCR (x+11-N Nm) Nm m≤100 (x<x+11 Nm))
    ... | inj₁ ( m+11>100 , _ ) = ⊥-elim (x≤89→x+11>100→⊥ Nm m≤89 m+11>100)
    ... | inj₂ ( _ , res ) = res

    mc91-res-m≯89 : mc91 m ≡ ninety-one
    mc91-res-m≯89 = mc91x-res≯100 m ninety-one m≯100 mc91-res-m+11 mc91-res-91

------------------------------------------------------------------------------
-- Main properties

-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N Nn = ∧-proj₁ (mc91-N-ineq Nn)

-- For all n, n < mc91 n + 11.
mc91-ineq : ∀ {n} → N n → LT n (mc91 n + eleven)
mc91-ineq Nn = ∧-proj₂ (mc91-N-ineq Nn)

-- For all n > 100, then mc91 n = n - 10.
mc91-res>100 : ∀ {n} → N n → GT n one-hundred → mc91 n ≡ n ∸ ten
mc91-res>100 Nn n>100 with mc91-res Nn
... | inj₁ ( _     , res ) = res
... | inj₂ ( n≯100 , _ )   = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100
                                               (x≯y→x≤y Nn 100-N n≯100))
-- For all n <= 100, then mc91 n = 91.
mc91-res≯100 : ∀ {n} → N n → NGT n one-hundred → mc91 n ≡ ninety-one
mc91-res≯100 Nn n≯100 with mc91-res Nn
... | inj₁ ( n>100 , _   ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100
                                               (x≯y→x≤y Nn 100-N n≯100))
... | inj₂ ( _     , res ) = res


Only white space.

Only white space.

Ignore-this: e576b6173e37484c807272422296be50

darcs-hash:20100505225855-3bd4e-3eb9725e590920b79243fbc6d8a973b84fcfe044.gz

------------------------------------------------------------------------------
-- Properties of the inequalities (using equational reasoning)
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties using ( +-comm )
open import LTC.Function.Arithmetic.PropertiesER
open import LTC.Relation.Inequalities
open import LTC.Data.N

open import MyStdLib.Data.Sum
open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module IPER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = true≠false $ trans (sym 0>n ) $ x≥0 Nn

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 {d} Sx≤0 = true≠false $ trans (sym $ lt-0S d ) Sx≤0

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  subst (λ a → a ≡ true ∨ a ≡ false)
        (sym $ lt-SS n m)
        (x>y∨x≤y Nm Nn )

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN          0<0   = ⊥-elim (true≠false (trans (sym 0<0) lt-00))
¬x<x (sN {m} Nm) Sm<Sm = ⊥-elim (¬x<x Nm (trans (sym (lt-SS m m)) Sm<Sm))

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn =
  begin
    lt (succ m + n) (succ m)   ≡⟨ subst (λ t → lt (succ m + n) (succ m) ≡
                                               lt t (succ m))
                                        (+-Sx m n)
                                        refl
                               ⟩
    lt (succ (m + n)) (succ m) ≡⟨ lt-SS (m + n) m ⟩
    lt (m + n) m               ≡⟨ x≤x+y Nm Nn ⟩
    false
  ∎

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN          Nn 0>n  = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = trans (+-rightIdentity (minus-N (sN Nm) zN))
                                        (minus-x0 (succ m))
x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  begin
    (succ m - succ n) + succ n ≡⟨ subst (λ t → (succ m - succ n) + succ n ≡
                                               t + succ n)
                                        (minus-SS m n)
                                        refl
                               ⟩
    (m - n) + succ n           ≡⟨ +-comm (minus-N Nm Nn) (sN Nn) ⟩
    succ n + (m - n)           ≡⟨ +-Sx n (m - n) ⟩
    succ (n + (m - n))         ≡⟨ subst (λ t → succ (n + (m - n)) ≡ succ t )
                                        (+-comm Nn (minus-N Nm Nn))
                                        refl
                               ⟩
    succ ((m - n) + n)         ≡⟨ subst (λ t → succ ((m - n) + n) ≡ succ t )
                                        (x>y→x-y+y≡x Nm Nn
                                             (trans (sym (lt-SS n m)) Sm>Sn) )
                                        refl
                               ⟩
    succ m
  ∎


[ Agda ] Agda's issue 1342 was fixed

[ Agda ] Agda's issue 1342 was fixed

------------------------------------------------------------------------------
-- Co-inductive natural numbers
------------------------------------------------------------------------------

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

module GFPs.Conat where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Conat is a greatest fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The co-natural numbers are the greatest fixed-point of NatF.
postulate
  Conat : D → Set

  -- Conat is a post-fixed point of NatF, i.e.
  --
  -- Conat ≤ NatF Conat.
  Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  -- The higher-order version.
  Conat-out-ho : ∀ {n} → Conat n → NatF Conat n

  -- Conat is the greatest post-fixed point of NatF, i.e.
  --
  -- ∀ A. A ≤ NatF A ⇒ A ≤ Conat.
  Conat-coind :
    (A : D → Set) →
    -- A is post-fixed point of ConatF.
    (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    -- Conat is greater than A.
    ∀ {n} → A n → Conat n

  -- The higher-order version.
  Conat-coind-ho :
    (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n

  -- 22 December 2013. This is a stronger induction principle. If we
  -- use it, we can use the trivial predicate A = λ x → x ≡ x in the
  -- proofs. Unfortunately, we don't have a justification/proof for
  -- this principle.
  Conat-stronger-coind₁ :
    ∀ (A : D → Set) {n} →
    (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    A n → Conat n

  -- Other stronger co-induction principle
  --
  -- Adapted from (Paulson, 1997. p. 16).
  Conat-stronger-coind₂ :
    (A : D → Set) →
    (∀ {n} → A n → (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) ∨ Conat n) →
    ∀ {n} → A n → Conat n

------------------------------------------------------------------------------
-- Conat-out and Conat-out-ho are equivalents

Conat-out-fo : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out-fo = Conat-out-ho

Conat-out-ho' : ∀ {n} → Conat n → NatF Conat n
Conat-out-ho' = Conat-out

------------------------------------------------------------------------------
-- Conat-coind and Conat-coind-ho are equivalents

Conat-coind-fo :
  (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind-fo = Conat-coind-ho

Conat-coind-ho' :
  (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n
Conat-coind-ho' = Conat-coind

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Conat predicate is also a pre-fixed point of the functional NatF,
-- i.e.
--
-- NatF Conat ≤ Conat.
Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in h = Conat-coind A h' h
  where
  A : D → Set
  A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  h' : ∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')
  h' (inj₁ n≡0)              = inj₁ n≡0
  h' (inj₂ (n' , prf , Cn')) = inj₂ (n' , prf , Conat-out Cn')

-- The higher-order version.
Conat-in-ho : ∀ {n} → NatF Conat n → Conat n
Conat-in-ho = Conat-in

-- A different definition.
Conat-in' : (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')) →
            ∀ {n} → Conat n
Conat-in' h = Conat-coind (λ m → m ≡ m) (h' h) refl
  where
  h' : (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')) →
       ∀ {m} → m ≡ m → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ m' ≡ m')
  h' h'' {m} _ with (h'' {m})
  ... | inj₁ m≡0            = inj₁ m≡0
  ... | inj₂ (m' , prf , _) = inj₂ (m' , prf , refl)

Conat-in-ho' : (∀ {n} → NatF Conat n) → ∀ {n} → Conat n
Conat-in-ho' = Conat-in'

------------------------------------------------------------------------------
-- From Conat-coind/Conat-stronger-coind₁ to Conat-stronger-coind₁/Conat-coind

Conat-coind'' :
  (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind'' A h An = Conat-stronger-coind₁ A h An

-- 22 December 2013: We couln't prove Conat-stronger-coind₁ using
-- Conat-coind.
Conat-stronger-coind₁' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind₁' A {n} h An = Conat-in (case prf₁ prf₂ (h An))
  where
  prf₁ : n ≡ zero → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₁ n≡0 = inj₁ n≡0

  prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ A n' →
         n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₂ (n' , prf , An') = inj₂ (n' , prf , {!!})

------------------------------------------------------------------------------
-- From Conat-stronger-coind₂ to Conat-stronger-coind₁

-- 13 January 2014: We couln't prove Conat-stronger-coind₁ using
-- Conat-stronger-coind₂.
Conat-stronger-coind₁'' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind₁'' A h An = Conat-stronger-coind₂ A {!!} An

------------------------------------------------------------------------------
-- References
--
-- Paulson, L. C. (1997). Mechanizing Coinduction and Corecursion in
-- Higher-order Logic. Journal of Logic and Computation 7.2,
-- pp. 175–204.

------------------------------------------------------------------------------
-- Co-inductive natural numbers
------------------------------------------------------------------------------

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

module GFPs.Conat where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Conat is a greatest fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The co-natural numbers are the greatest fixed-point of NatF.
postulate
  Conat : D → Set

  -- Conat is a post-fixed point of NatF, i.e.
  --
  -- Conat ≤ NatF Conat.
  Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  -- The higher-order version.
  Conat-out-ho : ∀ {n} → Conat n → NatF Conat n

  -- Conat is the greatest post-fixed point of NatF, i.e.
  --
  -- ∀ A. A ≤ NatF A ⇒ A ≤ Conat.
  Conat-coind :
    (A : D → Set) →
    -- A is post-fixed point of ConatF.
    (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    -- Conat is greater than A.
    ∀ {n} → A n → Conat n

  -- The higher-order version.
  Conat-coind-ho :
    (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n

  -- 22 December 2013. This is a stronger induction principle. If we
  -- use it, we can use the trivial predicate A = λ x → x ≡ x in the
  -- proofs. Unfortunately, we don't have a justification/proof for
  -- this principle.
  Conat-stronger-coind₁ :
    ∀ (A : D → Set) {n} →
    (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    A n → Conat n

  -- Other stronger co-induction principle
  --
  -- Adapted from (Paulson, 1997. p. 16).
  Conat-stronger-coind₂ :
    (A : D → Set) →
    (∀ {n} → A n → (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) ∨ Conat n) →
    ∀ {n} → A n → Conat n

------------------------------------------------------------------------------
-- Conat-out and Conat-out-ho are equivalents

Conat-out-fo : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out-fo = Conat-out-ho

Conat-out-ho' : ∀ {n} → Conat n → NatF Conat n
Conat-out-ho' = Conat-out

------------------------------------------------------------------------------
-- Conat-coind and Conat-coind-ho are equivalents

Conat-coind-fo :
  (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind-fo = Conat-coind-ho

Conat-coind-ho' :
  (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n
Conat-coind-ho' = Conat-coind

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Conat predicate is also a pre-fixed point of the functional NatF,
-- i.e.
--
-- NatF Conat ≤ Conat.
Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in h = Conat-coind A h' h
  where
  A : D → Set
  A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  h' : ∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')
  h' (inj₁ n≡0)              = inj₁ n≡0
  h' (inj₂ (n' , prf , Cn')) = inj₂ (n' , prf , Conat-out Cn')

-- The higher-order version.
Conat-in-ho : ∀ {n} → NatF Conat n → Conat n
Conat-in-ho = Conat-in

-- A different definition.
Conat-in' : (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')) →
            ∀ {n} → Conat n
Conat-in' h = Conat-coind (λ m → m ≡ m) h' refl
  where
  h' : ∀ {m} → m ≡ m → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ m' ≡ m')
  h' _ with h
  ... | inj₁ m≡0            = inj₁ m≡0
  ... | inj₂ (m' , prf , _) = inj₂ (m' , prf , refl)

Conat-in-ho' : (∀ {n} → NatF Conat n) → ∀ {n} → Conat n
Conat-in-ho' = Conat-in'

------------------------------------------------------------------------------
-- From Conat-coind/Conat-stronger-coind₁ to Conat-stronger-coind₁/Conat-coind

Conat-coind'' :
  (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind'' A h An = Conat-stronger-coind₁ A h An

-- 22 December 2013: We couln't prove Conat-stronger-coind₁ using
-- Conat-coind.
Conat-stronger-coind₁' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind₁' A {n} h An = Conat-in (case prf₁ prf₂ (h An))
  where
  prf₁ : n ≡ zero → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₁ n≡0 = inj₁ n≡0

  prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ A n' →
         n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₂ (n' , prf , An') = inj₂ (n' , prf , {!!})

------------------------------------------------------------------------------
-- From Conat-stronger-coind₂ to Conat-stronger-coind₁

-- 13 January 2014: We couln't prove Conat-stronger-coind₁ using
-- Conat-stronger-coind₂.
Conat-stronger-coind₁'' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind₁'' A h An = Conat-stronger-coind₂ A {!!} An

------------------------------------------------------------------------------
-- References
--
-- Paulson, L. C. (1997). Mechanizing Coinduction and Corecursion in
-- Higher-order Logic. Journal of Logic and Computation 7.2,
-- pp. 175–204.