Solver.Linear: fixity

Solver.Linear: fixity

module Solver.Linear where

open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as F using (Fin)
import Data.Fin.Props as FP

module Syntax {a} (A : Set a)(_x_ : A → A → A)(T : A)
  (R' : A → A → Set)
  (id' : ∀ {A} → R' A A)
  (_∻'_ : ∀ {A B C} → R' A B → R' B C → R' A C)
  (<id,tt>' : ∀ {A} → R' (A x T) A)
  (<id,tt>⁻¹' : ∀ {A} → R' A (A x T))
  (<tt,id>' : ∀ {A} → R' (T x A) A)
  (<tt,id>⁻¹' : ∀ {A} → R' A (T x A))
  (⟨_×'_⟩   : ∀ {A B C D} → R' A C → R' B D → R' (A x B) (C x D))
  (first'   : ∀ {A B C} → R' A B → R' (A x C) (B x C))
  (second'  : ∀ {A B C} → R' B C → R' (A x B) (A x C))
  (assoc'   : ∀ {A B C} → R' (A x (B x C)) ((A x B) x C))
  (assoc⁻¹' : ∀ {A B C} → R' ((A x B) x C) (A x (B x C)))
  (swap'    : ∀ {A B}   → R' (A x B) (B x A))
  nrVars (!_ : Fin nrVars → A) where

  Var = Fin nrVars

  open import Relation.Nullary using (yes ; no)
  open import Relation.Nullary.Decidable

  infixr 5 _,_
  data Syn : Set where
   var : Var → Syn
   tt  : Syn
   _,_ : Syn → Syn → Syn

  #_ : ∀ m {m<n : True (ℕ.suc m ℕ.≤? nrVars)} → Syn
  #_ m {p} = var (F.#_ m {nrVars} {p})

  eval : Syn → A
  eval (var x) = ! x
  eval tt = T
  eval (s , s₁) = eval s x eval s₁

  data R : Syn → Syn → Set where
    _∻''_ : ∀ {A B C} → R A B → R B C → R A C
    <id,tt> : ∀ {A} → R (A , tt) A
    <tt,id> : ∀ {A} → R (tt , A) A
    <tt,id>⁻¹ : ∀ {A} → R A (tt , A)
    <id,tt>⁻¹ : ∀ {A} → R A (A , tt)
    ⟨_×''_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    id : ∀ {A} → R A A
    swap : ∀ {A B} → R (A , B) (B , A)

  ⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  ⟨ id × id ⟩ = id
  ⟨ r₁ × r₂ ⟩ = ⟨ r₁ ×'' r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  id ∻ r₂ = r₂
  r₁ ∻ id = r₁
  <tt,id>⁻¹ ∻ <tt,id> = id
  <id,tt>⁻¹ ∻ <id,tt> = id
  <tt,id> ∻ <tt,id>⁻¹ = id
  <id,tt> ∻ <id,tt>⁻¹ = id
  swap ∻ <id,tt> = <tt,id>
  swap ∻ <tt,id> = <id,tt>
  <id,tt>⁻¹ ∻ swap = <tt,id>⁻¹
  <tt,id>⁻¹ ∻ swap = <id,tt>⁻¹
  assoc ∻ assoc⁻¹ = id
  assoc ∻ (assoc⁻¹ ∻'' r) = r
  assoc⁻¹ ∻ assoc = id
  assoc⁻¹ ∻ (assoc ∻'' r) = r
  swap ∻ swap = id
  swap ∻ (swap ∻'' r) = r
  (r₁ ∻'' r₂) ∻ r₃ = r₁ ∻ (r₂ ∻ r₃)
  ⟨ r₁ ×'' r₂ ⟩ ∻ ⟨ r₃ ×'' r₄ ⟩ = ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ⟨ r₁ ×'' r₂ ⟩ ∻ (⟨ r₃ ×'' r₄ ⟩ ∻'' r₅) with ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ... | id = r₅
  ... | r₆ = r₆ ∻'' r₅
  r₁ ∻ r₂ = r₁ ∻'' r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ∻'' r₁) = sym r₁ ∻ sym r
  sym <id,tt> = <id,tt>⁻¹
  sym <tt,id> = <tt,id>⁻¹
  sym <id,tt>⁻¹ = <id,tt>
  sym <tt,id>⁻¹ = <tt,id>
  sym ⟨ r ×'' r₁ ⟩ = ⟨ sym r × sym r₁ ⟩
  sym assoc = assoc⁻¹
  sym assoc⁻¹ = assoc
  sym id = id
  sym swap = swap

  proof₁ : ∀ {S S'} → R S S' → R' (eval S) (eval S')
  proof₁ (r ∻'' r₁) = proof₁ r ∻' proof₁ r₁
  proof₁ <id,tt> = <id,tt>'
  proof₁ <tt,id> = <tt,id>'
  proof₁ <id,tt>⁻¹ = <id,tt>⁻¹'
  proof₁ <tt,id>⁻¹ = <tt,id>⁻¹'
  proof₁ ⟨ id ×'' r ⟩ = second' (proof₁ r)
  proof₁ ⟨ r ×'' id ⟩ = first'  (proof₁ r)
  proof₁ ⟨ r ×'' r₁ ⟩ = ⟨ proof₁ r ×' proof₁ r₁ ⟩
  proof₁ assoc = assoc'
  proof₁ assoc⁻¹ = assoc⁻¹'
  proof₁ id = id'
  proof₁ swap = swap'

  proof₂ : ∀ {S S'} → R S S' → R' (eval S') (eval S)
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set where
    tt : NF tt
    var : (x : Var) → NF (var x)
    var_::_ : ∀ {S}(i : Var) → NF S → NF (var i , S)

  record NFP S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ <tt,id>⁻¹
  merge (var i) n2 = (var i :: n2) ⊢ id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ id
  norm tt = tt ⊢ id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 × p2 ⟩)

  insert : ∀ {S} → (x : Var) → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ <id,tt>⁻¹
  insert y (var i) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: var i) ⊢ id
  ... | no  _ = (var i :: var y) ⊢ swap
  insert y (var i :: n1) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: (var i :: n1)) ⊢ id
  ... | no  _ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ (assoc ∻ (⟨ swap × id ⟩ ∻ assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ id
  sort (var i) = var i ⊢ id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ id × p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
  open import Relation.Nullary

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = id

  _≢_ : ∀ {A : Set} → A → A → Set
  x ≢ y = x ≡ y → Data.Empty.⊥

  ≢-cong : ∀ {A B}{x y : A}(f : A → B) → f x ≢ f y → x ≢ y
  ≢-cong f fr refl = fr refl

  var-inj : ∀ {i j : Fin nrVars} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x FP.≟ x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = Data.Empty.⊥

  rewire : (S₁ S₂ : Syn) → CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire s₁ s₂ eq with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire _ _ () | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

  infix 4 _⇛_

  record Eq : Set where
    constructor _⇛_
    field
      LHS RHS : Syn

  open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
  open import Data.Vec using (allFin) renaming (map to vmap)

  rewire' : (f : N-ary nrVars Syn Eq) → let (S₁ ⇛ S₂) = f $ⁿ (vmap Syn.var (allFin nrVars))
          in CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire' f eq = let S ⇛ S' = f $ⁿ vmap Syn.var (allFin  nrVars)
         in rewire S S' eq

         {- move them to sub modules
module example where

  open import Data.Vec

  open import Data.Product
  open import Data.Unit

  open import Function

  -- need to etaexpand this because otherwise we get an error
  module STest n M = Syntax Set _×_ ⊤ (λ x x₁ → x → x₁) (λ x → x)
         (λ x x₁ x₂ → x₁ (x x₂)) (λ x → proj₁ x) (λ x → x , tt)
         (λ x → proj₂ x) (λ x → tt , x) (λ x x₁ x₂ → (x (proj₁ x₂)) , (x₁ (proj₂ x₂)))
         (λ x x₁ → (x (proj₁ x₁)) , (proj₂ x₁)) (λ x x₁ → (proj₁ x₁) , (x (proj₂ x₁)))
         (λ x → ((proj₁ x) , (proj₁ (proj₂ x))) , (proj₂ (proj₂ x)))
         (λ x → (proj₁ (proj₁ x)) , ((proj₂ (proj₁ x)) , (proj₂ x)))
         (λ x → (proj₂ x) , (proj₁ x)) n M

  test : (A B C : Set) → (A × B) × C → (B × A) × C
  test A B C = rewire LHS RHS _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

    LHS = (# 0 , # 1) , # 2
    RHS = (# 1 , # 0) , # 2

  test2 : (A B C : Set) → (A × B) × C → (B × A) × C
  test2 A B C = rewire' (λ a b c → (a , b) , c ⇛ (b , a) , c) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₂ where

  open import Data.Vec

  data Ty : Set where
    _×_ : Ty → Ty → Ty
    ⊤ : Ty

  infix 4 _⟶_

  data _⟶_ : Ty → Ty → Set where
    id' : ∀ {A} → A ⟶ A
    _∻'_ : ∀ {A B C} → A ⟶ B → B ⟶ C → A ⟶ C
    <id,tt>' : ∀ {A} → (A × ⊤) ⟶ A
    <id,tt>⁻¹' : ∀ {A} → A ⟶ (A × ⊤)
    <tt,id>' : ∀ {A} → (⊤ × A) ⟶ A
    <tt,id>⁻¹' : ∀ {A} → A ⟶ (⊤ × A)
    ⟨_×'_⟩   : ∀ {A B C D} → A ⟶ C → B ⟶ D → (A × B) ⟶ (C × D)
    first    : ∀ {A B C} → A ⟶ B → A × C ⟶ B × C
    second   : ∀ {A B C} → B ⟶ C → A × B ⟶ A × C
    assoc'   : ∀ {A B C} → (A × (B × C)) ⟶ ((A × B) × C)
    assoc⁻¹' : ∀ {A B C} → ((A × B) × C) ⟶ (A × (B × C))
    swap'    : ∀ {A B}   → (A × B) ⟶ (B × A)

  module STest n M = Syntax Ty _×_ ⊤ _⟶_ id' _∻'_ <id,tt>' <id,tt>⁻¹' <tt,id>' <tt,id>⁻¹' ⟨_×'_⟩ first second assoc' assoc⁻¹' swap' n M

  test2 : (A B C : Ty) → (A × B) × C ⟶  (B × A) × C
  test2 A B C = rewire ((# 0 , # 1) , # 2) ((# 1 , # 0) , # 2) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₃ where

  open import Data.Unit
  open import Data.Product
  open import Data.Vec

  open import Function using (flip ; const)

  open import Function.Inverse
  open import Function.Related.TypeIsomorphisms.NP

  open ×-CMon using () renaming (∙-cong to ×-cong ; assoc to ×-assoc)

  module STest n M = Syntax Set _×_ ⊤ _↔_ id (flip _∘_) A×⊤↔A (sym A×⊤↔A) (A×⊤↔A ∘ swap-iso) (swap-iso ∘ sym A×⊤↔A)
                            ×-cong first-iso (λ x → second-iso (const x))
                            (sym (×-assoc _ _ _)) (×-assoc _ _ _) swap-iso n M

  test : ∀ A B C → ((A × B) × C) ↔ (C × (B × A))
  test A B C = rewire ((# 0 , # 1) , # 2) (# 2 , (# 1 , # 0)) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

-}

module Solver.Linear where

open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as F using (Fin)
import Data.Fin.Props as FP

module Syntax {a} (A : Set a)(_x_ : A → A → A)(T : A)
  (R' : A → A → Set)
  (id' : ∀ {A} → R' A A)
  (_∻'_ : ∀ {A B C} → R' A B → R' B C → R' A C)
  (<id,tt>' : ∀ {A} → R' (A x T) A)
  (<id,tt>⁻¹' : ∀ {A} → R' A (A x T))
  (<tt,id>' : ∀ {A} → R' (T x A) A)
  (<tt,id>⁻¹' : ∀ {A} → R' A (T x A))
  (⟨_×'_⟩   : ∀ {A B C D} → R' A C → R' B D → R' (A x B) (C x D))
  (first'   : ∀ {A B C} → R' A B → R' (A x C) (B x C))
  (second'  : ∀ {A B C} → R' B C → R' (A x B) (A x C))
  (assoc'   : ∀ {A B C} → R' (A x (B x C)) ((A x B) x C))
  (assoc⁻¹' : ∀ {A B C} → R' ((A x B) x C) (A x (B x C)))
  (swap'    : ∀ {A B}   → R' (A x B) (B x A))
  nrVars (!_ : Fin nrVars → A) where

  Var = Fin nrVars

  open import Relation.Nullary using (yes ; no)
  open import Relation.Nullary.Decidable

  data Syn : Set where
   var : Var → Syn
   tt  : Syn
   _,_ : Syn → Syn → Syn

  #_ : ∀ m {m<n : True (ℕ.suc m ℕ.≤? nrVars)} → Syn
  #_ m {p} = var (F.#_ m {nrVars} {p})

  eval : Syn → A
  eval (var x) = ! x
  eval tt = T
  eval (s , s₁) = eval s x eval s₁

  data R : Syn → Syn → Set where
    _∻''_ : ∀ {A B C} → R A B → R B C → R A C
    <id,tt> : ∀ {A} → R (A , tt) A
    <tt,id> : ∀ {A} → R (tt , A) A
    <tt,id>⁻¹ : ∀ {A} → R A (tt , A)
    <id,tt>⁻¹ : ∀ {A} → R A (A , tt)
    ⟨_×''_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    id : ∀ {A} → R A A
    swap : ∀ {A B} → R (A , B) (B , A)

  ⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  ⟨ id × id ⟩ = id
  ⟨ r₁ × r₂ ⟩ = ⟨ r₁ ×'' r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  id ∻ r₂ = r₂
  r₁ ∻ id = r₁
  <tt,id>⁻¹ ∻ <tt,id> = id
  <id,tt>⁻¹ ∻ <id,tt> = id
  <tt,id> ∻ <tt,id>⁻¹ = id
  <id,tt> ∻ <id,tt>⁻¹ = id
  swap ∻ <id,tt> = <tt,id>
  swap ∻ <tt,id> = <id,tt>
  <id,tt>⁻¹ ∻ swap = <tt,id>⁻¹
  <tt,id>⁻¹ ∻ swap = <id,tt>⁻¹
  assoc ∻ assoc⁻¹ = id
  assoc ∻ (assoc⁻¹ ∻'' r) = r
  assoc⁻¹ ∻ assoc = id
  assoc⁻¹ ∻ (assoc ∻'' r) = r
  swap ∻ swap = id
  swap ∻ (swap ∻'' r) = r
  (r₁ ∻'' r₂) ∻ r₃ = r₁ ∻ (r₂ ∻ r₃)
  ⟨ r₁ ×'' r₂ ⟩ ∻ ⟨ r₃ ×'' r₄ ⟩ = ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ⟨ r₁ ×'' r₂ ⟩ ∻ (⟨ r₃ ×'' r₄ ⟩ ∻'' r₅) with ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ... | id = r₅
  ... | r₆ = r₆ ∻'' r₅
  r₁ ∻ r₂ = r₁ ∻'' r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ∻'' r₁) = sym r₁ ∻ sym r
  sym <id,tt> = <id,tt>⁻¹
  sym <tt,id> = <tt,id>⁻¹
  sym <id,tt>⁻¹ = <id,tt>
  sym <tt,id>⁻¹ = <tt,id>
  sym ⟨ r ×'' r₁ ⟩ = ⟨ sym r × sym r₁ ⟩
  sym assoc = assoc⁻¹
  sym assoc⁻¹ = assoc
  sym id = id
  sym swap = swap

  proof₁ : ∀ {S S'} → R S S' → R' (eval S) (eval S')
  proof₁ (r ∻'' r₁) = proof₁ r ∻' proof₁ r₁
  proof₁ <id,tt> = <id,tt>'
  proof₁ <tt,id> = <tt,id>'
  proof₁ <id,tt>⁻¹ = <id,tt>⁻¹'
  proof₁ <tt,id>⁻¹ = <tt,id>⁻¹'
  proof₁ ⟨ id ×'' r ⟩ = second' (proof₁ r)
  proof₁ ⟨ r ×'' id ⟩ = first'  (proof₁ r)
  proof₁ ⟨ r ×'' r₁ ⟩ = ⟨ proof₁ r ×' proof₁ r₁ ⟩
  proof₁ assoc = assoc'
  proof₁ assoc⁻¹ = assoc⁻¹'
  proof₁ id = id'
  proof₁ swap = swap'

  proof₂ : ∀ {S S'} → R S S' → R' (eval S') (eval S)
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set where
    tt : NF tt
    var : (x : Var) → NF (var x)
    var_::_ : ∀ {S}(i : Var) → NF S → NF (var i , S)

  record NFP S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ <tt,id>⁻¹
  merge (var i) n2 = (var i :: n2) ⊢ id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ id
  norm tt = tt ⊢ id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 × p2 ⟩)

  insert : ∀ {S} → (x : Var) → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ <id,tt>⁻¹
  insert y (var i) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: var i) ⊢ id
  ... | no  _ = (var i :: var y) ⊢ swap
  insert y (var i :: n1) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: (var i :: n1)) ⊢ id
  ... | no  _ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ (assoc ∻ (⟨ swap × id ⟩ ∻ assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ id
  sort (var i) = var i ⊢ id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ id × p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
  open import Relation.Nullary

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = id

  _≢_ : ∀ {A : Set} → A → A → Set
  x ≢ y = x ≡ y → Data.Empty.⊥

  ≢-cong : ∀ {A B}{x y : A}(f : A → B) → f x ≢ f y → x ≢ y
  ≢-cong f fr refl = fr refl

  var-inj : ∀ {i j : Fin nrVars} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x FP.≟ x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = Data.Empty.⊥

  rewire : (S₁ S₂ : Syn) → CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire s₁ s₂ eq with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire _ _ () | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

  infix 4 _⇛_

  record Eq : Set where
    constructor _⇛_
    field
      LHS RHS : Syn

  open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
  open import Data.Vec using (allFin) renaming (map to vmap)

  rewire' : (f : N-ary nrVars Syn Eq) → let (S₁ ⇛ S₂) = f $ⁿ (vmap Syn.var (allFin nrVars))
          in CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire' f eq = let S ⇛ S' = f $ⁿ vmap Syn.var (allFin  nrVars)
         in rewire S S' eq

module example where

  open import Data.Vec

  open import Data.Product
  open import Data.Unit

  open import Function

  -- need to etaexpand this because otherwise we get an error
  module STest n M = Syntax Set _×_ ⊤ (λ x x₁ → x → x₁) (λ x → x)
         (λ x x₁ x₂ → x₁ (x x₂)) (λ x → proj₁ x) (λ x → x , tt)
         (λ x → proj₂ x) (λ x → tt , x) (λ x x₁ x₂ → (x (proj₁ x₂)) , (x₁ (proj₂ x₂)))
         (λ x x₁ → (x (proj₁ x₁)) , (proj₂ x₁)) (λ x x₁ → (proj₁ x₁) , (x (proj₂ x₁)))
         (λ x → ((proj₁ x) , (proj₁ (proj₂ x))) , (proj₂ (proj₂ x)))
         (λ x → (proj₁ (proj₁ x)) , ((proj₂ (proj₁ x)) , (proj₂ x)))
         (λ x → (proj₂ x) , (proj₁ x)) n M

  test : (A B C : Set) → (A × B) × C → (B × A) × C
  test A B C = rewire LHS RHS _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

    LHS = (# 0 , # 1) , # 2
    RHS = (# 1 , # 0) , # 2

  test2 : (A B C : Set) → (A × B) × C → (B × A) × C
  test2 A B C = rewire' (λ a b c → (a , b) , c ⇛ (b , a) , c) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₂ where

  open import Data.Vec

  data Ty : Set where
    _×_ : Ty → Ty → Ty
    ⊤ : Ty

  infix 4 _⟶_

  data _⟶_ : Ty → Ty → Set where
    id' : ∀ {A} → A ⟶ A
    _∻'_ : ∀ {A B C} → A ⟶ B → B ⟶ C → A ⟶ C
    <id,tt>' : ∀ {A} → (A × ⊤) ⟶ A
    <id,tt>⁻¹' : ∀ {A} → A ⟶ (A × ⊤)
    <tt,id>' : ∀ {A} → (⊤ × A) ⟶ A
    <tt,id>⁻¹' : ∀ {A} → A ⟶ (⊤ × A)
    ⟨_×'_⟩   : ∀ {A B C D} → A ⟶ C → B ⟶ D → (A × B) ⟶ (C × D)
    first    : ∀ {A B C} → A ⟶ B → A × C ⟶ B × C
    second   : ∀ {A B C} → B ⟶ C → A × B ⟶ A × C
    assoc'   : ∀ {A B C} → (A × (B × C)) ⟶ ((A × B) × C)
    assoc⁻¹' : ∀ {A B C} → ((A × B) × C) ⟶ (A × (B × C))
    swap'    : ∀ {A B}   → (A × B) ⟶ (B × A)

  module STest n M = Syntax Ty _×_ ⊤ _⟶_ id' _∻'_ <id,tt>' <id,tt>⁻¹' <tt,id>' <tt,id>⁻¹' ⟨_×'_⟩ first second assoc' assoc⁻¹' swap' n M

  test2 : (A B C : Ty) → (A × B) × C ⟶  (B × A) × C
  test2 A B C = rewire ((# 0 , # 1) , # 2) ((# 1 , # 0) , # 2) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₃ where

  open import Data.Unit
  open import Data.Product
  open import Data.Vec

  open import Function using (flip ; const)

  open import Function.Inverse
  open import Function.Related.TypeIsomorphisms.NP

  open ×-CMon using () renaming (∙-cong to ×-cong ; assoc to ×-assoc)

  module STest n M = Syntax Set _×_ ⊤ _↔_ id (flip _∘_) A×⊤↔A (sym A×⊤↔A) (A×⊤↔A ∘ swap-iso) (swap-iso ∘ sym A×⊤↔A)
                            ×-cong first-iso (λ x → second-iso (const x))
                            (sym (×-assoc _ _ _)) (×-assoc _ _ _) swap-iso n M

  test : ∀ A B C → ((A × B) × C) ↔ (C × (B × A))
  test A B C = rewire ((# 0 , # 1) , # 2) (# 2 , (# 1 , # 0)) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))


Updated doc.

Updated doc.

Ignore-this: 2b06fbd1abe6a6e7f68c1fd718655c6a

darcs-hash:20100921153238-3bd4e-a05cc8fbd5079de38e29928fc6b7f7f296f33f4b.gz

module Test.Fail.Add where

infix  4 _≡_
infixl 6 _+_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set
  _+_    : D → D → D
  +-0x   : (d : D) → zero + d     ≡ d
  +-Sx   : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

-- The ATPs should not prove this postulate.
postulate
  +-comm : (d e : D) → d + e ≡ e + d
-- E 1.2 success (SZS status CounterSatisfiable).
-- Equinox 5.0alpha (2010-03-29) no-success due to timeout.
-- Metis 2.3 (release 20100920) success (SZS status CounterSatisfiable).
{-# ATP prove +-comm #-}

module Test.Fail.Add where

infix  4 _≡_
infixl 6 _+_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set
  _+_    : D → D → D
  +-0x   : (d : D) → zero + d     ≡ d
  +-Sx   : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

-- The ATPs should not prove this postulate.
postulate
  +-comm : (d e : D) → d + e ≡ e + d
-- Equinox 5.0alpha (2010-03-29) no-success due to timeout.
-- E 1.2 no-success due to timeout.
-- TODO: Metis 2.2 (release 20100825) success (SZS status CounterSatisfiable).
{-# ATP prove +-comm #-}


GroupHom: split the verifier function

GroupHom: split the verifier function

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq using (Eq?; _==_; ≡⇒==; ==⇒≡)
open import Function using (case_of_)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Binary.PropositionalEquality.Base using (_≡_; _≢_; idp; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Homomorphism
import ZK.SigmaProtocol.KnownStatement

module ZK.GroupHom
    {G+ G* : Type} (grp-G+ : Group G+) (grp-G* : Group G*)
    {{eq?-G* : Eq? G*}}

    (open Additive-Group grp-G+ hiding (_⊗_))
    (open Multiplicative-Group grp-G* hiding (_^_))

    {C : Type} -- e.g. C ⊆ ℕ
    (_>_ : C → C → Type)
    (swap? : {c₀ c₁ : C} → c₀ ≢ c₁ → (c₀ > c₁) ⊎ (c₁ > c₀))
    (_⊗_ : G+ → C → G+)
    (_^_ : G* → C → G*)
    (_−ᶜ_ : C → C → C)
    (1/ : C → C)

    (φ : G+ → G*) -- For instance φ(x) = g^x
    (φ-hom : GroupHomomorphism grp-G+ grp-G* φ)
    (φ-hom-iterated : ∀ {x c} → φ (x ⊗ c) ≡ φ x ^ c)

    (Y : G*)

    (^-−ᶜ  : ∀ {c₀ c₁}(c> : c₀ > c₁) → Y ^(c₀ −ᶜ c₁) ≡ (Y ^ c₀) / (Y ^ c₁))
    (^-^-1/ : ∀ {c₀ c₁}(c> : c₀ > c₁) → (Y ^(c₀ −ᶜ c₁))^(1/(c₀ −ᶜ c₁)) ≡ Y)
    where

  Commitment = G*
  Challenge  = C
  Response   = G+
  Witness    = G+
  Randomness = G+
  _∈y : Witness → Type
  x ∈y = φ x ≡ Y

  open ZK.SigmaProtocol.KnownStatement Commitment Challenge Response Randomness Witness _∈y public

  prover : Prover
  prover a x = φ a , response
     where response : Challenge → Response
           response c = (x ⊗ c) + a

  verifier' : (A : Commitment)(c : Challenge)(s : Response) → _
  verifier' A c s = φ s == ((Y ^ c) * A)

  verifier : Verifier
  verifier (mk A c s) = verifier' A c s

  -- We still call it Schnorr since essentially not much changed.
  -- The scheme abstracts away g^ as an homomorphism called φ
  -- and one get to distinguish between the types C vs G+ and
  -- their operations _⊗_ vs _*_.
  Schnorr : Σ-Protocol
  Schnorr = (prover , verifier)

  -- The simulator shows why it is so important for the
  -- challenge to be picked once the commitment is known.
  -- To fake a transcript, the challenge and response can
  -- be arbitrarily chosen. However to be indistinguishable
  -- from a valid proof they need to be picked at random.
  simulator : Simulator
  simulator c s = A
      where
        -- Compute A, such that the verifier accepts!
        A = (Y ^ c)⁻¹ * φ s

  swap-t²? : Transcript²[ _≢_ ] verifier → Transcript²[ _>_ ] verifier
  swap-t²? t² = t²'
      module Swap? where
        open Transcript² t² public
          using (verify₀; verify₁; c₀≢c₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   )
        t²' = case swap? c₀≢c₁ of λ
              { (inl c₀>c₁) → mk A c₀ c₁ c₀>c₁ r₀ r₁ verify₀ verify₁
              ; (inr c₀<c₁) → mk A c₁ c₀ c₀<c₁ r₁ r₀ verify₁ verify₀
              }

  -- The extractor shows the importance of never reusing a
  -- commitment. If the prover answers to two different challenges
  -- comming from the same commitment then the knowledge of the
  -- prover (the witness) can be extracted.
  extractor : Extractor verifier
  extractor t² = x'
      module Witness-extractor where
        open Transcript² (swap-t²? t²) public
          using (verify₀; verify₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   ; c₀≢c₁ to c₀>c₁
                   )
        rd   = r₀ − r₁
        cd   = c₀ −ᶜ c₁
        1/cd = 1/ cd
        x'   = rd ⊗ 1/cd

  open ≡-Reasoning
  open GroupHomomorphism φ-hom

  correct : Correct Schnorr
  correct x a c w
    = ≡⇒== (φ((x ⊗ c) + a)  ≡⟨ hom ⟩
            φ(x ⊗ c)  * A   ≡⟨ *= φ-hom-iterated idp ⟩
            (φ x ^ c) * A   ≡⟨ ap (λ z → (z ^ c) * A) w ⟩
            (Y ^ c)   * A   ∎)
    where
      A = φ a

  shvzk : Special-Honest-Verifier-Zero-Knowledge Schnorr
  shvzk = record { simulator = simulator
                 ; correct-simulator =
                    λ _ _ → ≡⇒== (! elim-*-!assoc= (snd ⁻¹-inverse)) }

  module _ (t² : Transcript² verifier) where
    open Witness-extractor t²

    φrd≡ycd : _
    φrd≡ycd
      = φ rd                        ≡⟨by-definition⟩
        φ (r₀ − r₁)                 ≡⟨ −-/ ⟩
        φ r₀ / φ r₁                 ≡⟨ /= (==⇒≡ verify₀) (==⇒≡ verify₁) ⟩
        (Y ^ c₀ * A) / (Y ^ c₁ * A) ≡⟨ elim-*-right-/ ⟩
        Y ^ c₀ / Y ^ c₁             ≡⟨ ! ^-−ᶜ c₀>c₁ ⟩
        Y ^(c₀ −ᶜ c₁)               ≡⟨by-definition⟩
        Y ^ cd                      ∎

    -- The extracted x is correct
    extractor-ok : φ x' ≡ Y
    extractor-ok
      = φ(rd ⊗ 1/cd)    ≡⟨ φ-hom-iterated ⟩
        φ rd ^ 1/cd     ≡⟨ ap₂ _^_ φrd≡ycd idp ⟩
        (Y ^ cd)^ 1/cd  ≡⟨ ^-^-1/ c₀>c₁ ⟩
        Y               ∎

  special-soundness : Special-Soundness Schnorr
  special-soundness = record { extractor = extractor
                             ; extract-valid-witness = extractor-ok }

  special-Σ-protocol : Special-Σ-Protocol
  special-Σ-protocol = record { Σ-protocol = Schnorr ; correct = correct ; shvzk = shvzk ; ssound = special-soundness }
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq using (Eq?; _==_; ≡⇒==; ==⇒≡)
open import Function using (case_of_)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Binary.PropositionalEquality.Base using (_≡_; _≢_; idp; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Homomorphism
import ZK.SigmaProtocol.KnownStatement

module ZK.GroupHom
    {G+ G* : Type} (grp-G+ : Group G+) (grp-G* : Group G*)
    {{eq?-G* : Eq? G*}}

    (open Additive-Group grp-G+ hiding (_⊗_))
    (open Multiplicative-Group grp-G* hiding (_^_))

    {C : Type} -- e.g. C ⊆ ℕ
    (_>_ : C → C → Type)
    (swap? : {c₀ c₁ : C} → c₀ ≢ c₁ → (c₀ > c₁) ⊎ (c₁ > c₀))
    (_⊗_ : G+ → C → G+)
    (_^_ : G* → C → G*)
    (_−ᶜ_ : C → C → C)
    (1/ : C → C)

    (φ : G+ → G*) -- For instance φ(x) = g^x
    (φ-hom : GroupHomomorphism grp-G+ grp-G* φ)
    (φ-hom-iterated : ∀ {x c} → φ (x ⊗ c) ≡ φ x ^ c)

    (Y : G*)

    (^-−ᶜ  : ∀ {c₀ c₁}(c> : c₀ > c₁) → Y ^(c₀ −ᶜ c₁) ≡ (Y ^ c₀) / (Y ^ c₁))
    (^-^-1/ : ∀ {c₀ c₁}(c> : c₀ > c₁) → (Y ^(c₀ −ᶜ c₁))^(1/(c₀ −ᶜ c₁)) ≡ Y)
    where

  Commitment = G*
  Challenge  = C
  Response   = G+
  Witness    = G+
  Randomness = G+
  _∈y : Witness → Type
  x ∈y = φ x ≡ Y

  open ZK.SigmaProtocol.KnownStatement Commitment Challenge Response Randomness Witness _∈y public

  prover : Prover
  prover a x = φ a , response
     where response : Challenge → Response
           response c = (x ⊗ c) + a

  verifier : Verifier
  verifier (mk A c s) = φ s == ((Y ^ c) * A)

  -- We still call it Schnorr since essentially not much changed.
  -- The scheme abstracts away g^ as an homomorphism called φ
  -- and one get to distinguish between the types C vs G+ and
  -- their operations _⊗_ vs _*_.
  Schnorr : Σ-Protocol
  Schnorr = (prover , verifier)

  -- The simulator shows why it is so important for the
  -- challenge to be picked once the commitment is known.
  -- To fake a transcript, the challenge and response can
  -- be arbitrarily chosen. However to be indistinguishable
  -- from a valid proof they need to be picked at random.
  simulator : Simulator
  simulator c s = A
      where
        -- Compute A, such that the verifier accepts!
        A = (Y ^ c)⁻¹ * φ s

  swap-t²? : Transcript²[ _≢_ ] verifier → Transcript²[ _>_ ] verifier
  swap-t²? t² = t²'
      module Swap? where
        open Transcript² t² public
          using (verify₀; verify₁; c₀≢c₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   )
        t²' = case swap? c₀≢c₁ of λ
              { (inl c₀>c₁) → mk A c₀ c₁ c₀>c₁ r₀ r₁ verify₀ verify₁
              ; (inr c₀<c₁) → mk A c₁ c₀ c₀<c₁ r₁ r₀ verify₁ verify₀
              }

  -- The extractor shows the importance of never reusing a
  -- commitment. If the prover answers to two different challenges
  -- comming from the same commitment then the knowledge of the
  -- prover (the witness) can be extracted.
  extractor : Extractor verifier
  extractor t² = x'
      module Witness-extractor where
        open Transcript² (swap-t²? t²) public
          using (verify₀; verify₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   ; c₀≢c₁ to c₀>c₁
                   )
        rd   = r₀ − r₁
        cd   = c₀ −ᶜ c₁
        1/cd = 1/ cd
        x'   = rd ⊗ 1/cd

  open ≡-Reasoning
  open GroupHomomorphism φ-hom

  correct : Correct Schnorr
  correct x a c w
    = ≡⇒== (φ((x ⊗ c) + a)  ≡⟨ hom ⟩
            φ(x ⊗ c)  * A   ≡⟨ *= φ-hom-iterated idp ⟩
            (φ x ^ c) * A   ≡⟨ ap (λ z → (z ^ c) * A) w ⟩
            (Y ^ c)   * A   ∎)
    where
      A = φ a

  shvzk : Special-Honest-Verifier-Zero-Knowledge Schnorr
  shvzk = record { simulator = simulator
                 ; correct-simulator =
                    λ _ _ → ≡⇒== (! elim-*-!assoc= (snd ⁻¹-inverse)) }

  module _ (t² : Transcript² verifier) where
    open Witness-extractor t²

    φrd≡ycd : _
    φrd≡ycd
      = φ rd                        ≡⟨by-definition⟩
        φ (r₀ − r₁)                 ≡⟨ −-/ ⟩
        φ r₀ / φ r₁                 ≡⟨ /= (==⇒≡ verify₀) (==⇒≡ verify₁) ⟩
        (Y ^ c₀ * A) / (Y ^ c₁ * A) ≡⟨ elim-*-right-/ ⟩
        Y ^ c₀ / Y ^ c₁             ≡⟨ ! ^-−ᶜ c₀>c₁ ⟩
        Y ^(c₀ −ᶜ c₁)               ≡⟨by-definition⟩
        Y ^ cd                      ∎

    -- The extracted x is correct
    extractor-ok : φ x' ≡ Y
    extractor-ok
      = φ(rd ⊗ 1/cd)    ≡⟨ φ-hom-iterated ⟩
        φ rd ^ 1/cd     ≡⟨ ap₂ _^_ φrd≡ycd idp ⟩
        (Y ^ cd)^ 1/cd  ≡⟨ ^-^-1/ c₀>c₁ ⟩
        Y               ∎

  special-soundness : Special-Soundness Schnorr
  special-soundness = record { extractor = extractor
                             ; extract-valid-witness = extractor-ok }

  special-Σ-protocol : Special-Σ-Protocol
  special-Σ-protocol = record { Σ-protocol = Schnorr ; correct = correct ; shvzk = shvzk ; ssound = special-soundness }
-- -}
-- -}
-- -}
-- -}


spatie tussen Koopa en Troopa

spatie tussen Koopa en Troopa

{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin renaming (_+_ to _F+_; _<_ to _F<_; suc to fsuc;
    zero to fzero)
  open import Data.Vec renaming (map to vmap; lookup to vlookup;
                                     replicate to vreplicate)
  open import Data.Unit
  open import Data.Empty

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

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

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa : Color → Set where
    _KT : (c : Color) → KoopaTroopa c

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

  data Clearance : Set where
    Low  : Clearance
    High : Clearance
    God  : Clearance

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

  data _c>_ : Color → Clearance → Set where
    <red>   : ∀ {c} → c c> Low
    <green> : Green c> High

  data _follows_⟨_⟩ : Position → Position → Color → Set where
    stay  : ∀ {c x y} → pos x y gas Low follows pos x y gas Low ⟨ c ⟩
    next  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos (suc x) y gas cl follows pos x y gas Low ⟨ c ⟩
    back  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos x y gas cl follows pos (suc x) y gas Low ⟨ c ⟩
    -- jump  : ∀ {c x y} → pos x (suc y) gas High follows pos x y gas Low ⟨ c ⟩
    fall  : ∀ {c cl x y} → pos x y gas cl follows pos x (suc y) gas High ⟨ c ⟩

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

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

  matToPosVec : {n : ℕ} → Vec Material n → Vec Material n → ℕ → ℕ →
                   Vec Position n
  matToPosVec []           []        _ _ = []
  matToPosVec (mat ∷ mats) (under ∷ unders) x y =
    pos x y mat cl ∷ matToPosVec mats unders (x + 1) y
      where
        clearance : Material → Material → Clearance
        clearance gas   gas   = High
        clearance gas   solid = Low
        clearance solid _     = God
        cl = clearance mat under

  matToPosVecs : {w h : ℕ} → Vec (Vec Material w) h → Vec (Vec Position w) h
  matToPosVecs [] = []
  matToPosVecs (_∷_ {y} mats matss) =
    matToPosVec mats (unders matss gas) 0 y ∷ matToPosVecs matss
    where
      unders : ∀ {m n ℓ}{A : Set ℓ} → Vec (Vec A m) n → A → Vec A m
      unders [] fallback = vreplicate fallback
      unders (us ∷ _) _ = us

  matsToMat : {w h : ℕ} → Vec (Vec Material w) h → Matrix Position w h
  matsToMat matss = Mat (reverse (matToPosVecs matss))

  □ : Material
  □ = gas
  ■ : Material
  ■ = solid
  example_level : Matrix Position 10 7
  example_level = matsToMat (
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ []) ∷
    (■ ∷ ■ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ []) ∷ [])

  _<'_ : ℕ → ℕ → Set
  m <' zero = ⊥
  zero <' suc n = ⊤
  suc m <' suc n = m <' n

  fromNat : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  fromNat {zero} k {}
  fromNat {suc n} zero = fzero
  fromNat {suc n} (suc k) {p} = fsuc (fromNat k {p})

  f : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  f = fromNat

  p : (x : Fin 10) → (y : Fin 7) → Position
  p x y = lookup y x example_level

  red_path_one : Path (Red KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  red_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                 p (f 6) (f 6) ↠⟨ next ⟩
                 p (f 7) (f 6) ↠⟨ next ⟩
                 p (f 8) (f 6) ↠⟨ stay ⟩ []

  red_path_two : Path (Red KT) (p (f 2) (f 1)) (p (f 3) (f 1))
  red_path_two = p (f 2) (f 1) ↠⟨ back ⟩
                 p (f 1) (f 1) ↠⟨ next ⟩
                 p (f 2) (f 1) ↠⟨ next ⟩
                 p (f 3) (f 1) ↠⟨ next ⟩
                 p (f 4) (f 1) ↠⟨ back ⟩
                 p (f 3) (f 1) ↠⟨ stay ⟩
                 []

  -- -- Type error shows up 'late' because 'cons' is right associative
  -- red_nopath_one : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩
  --                  p (f 0) (f 1) ↠⟨ stay ⟩
  --                  []

  -- -- Red KoopaTroopa can't step into a wall
  -- red_nopath_two : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_two = p (f 1) (f 1) ↠⟨ back ⟩ []

  -- -- Red KoopaTroopa can't step into air
  -- red_nopath_three : Path (Red KT) (p (f 4) (f 1)) (p (f 5) (f 1))
  -- red_nopath_three = p (f 4) (f 1) ↠⟨ next ⟩ []

  -- Any path that is valid for red KoopaTroopas, is also valid for green
  -- KoopaTroopas because we did not constrain KoopaTroopas to only turn
  -- When there is an obstacle
  green_path_one : Path (Green KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  green_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ next ⟩
                   p (f 7) (f 6) ↠⟨ next ⟩
                   p (f 8) (f 6) ↠⟨ stay ⟩ []

  green_path_two : Path (Green KT) (p (f 7) (f 6)) (p (f 5) (f 0))
  green_path_two = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ back ⟩
                   p (f 5) (f 6) ↠⟨ fall ⟩
                   p (f 5) (f 5) ↠⟨ fall ⟩
                   p (f 5) (f 4) ↠⟨ back ⟩
                   p (f 4) (f 4) ↠⟨ back ⟩
                   p (f 3) (f 4) ↠⟨ back ⟩
                   p (f 2) (f 4) ↠⟨ fall ⟩
                   p (f 2) (f 3) ↠⟨ fall ⟩
                   p (f 2) (f 2) ↠⟨ fall ⟩
                   p (f 2) (f 1) ↠⟨ back ⟩
                   p (f 1) (f 1) ↠⟨ next ⟩
                   p (f 2) (f 1) ↠⟨ next ⟩
                   p (f 3) (f 1) ↠⟨ next ⟩
                   p (f 4) (f 1) ↠⟨ next ⟩
                   p (f 5) (f 1) ↠⟨ fall ⟩
                   []

  -- -- Green KoopaTroopa can't step into a wall
  -- green_nopath_one : Path (Green KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- green_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩ []

{-

    Verified KoopaTroopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin renaming (_+_ to _F+_; _<_ to _F<_; suc to fsuc;
    zero to fzero)
  open import Data.Vec renaming (map to vmap; lookup to vlookup;
                                     replicate to vreplicate)
  open import Data.Unit
  open import Data.Empty

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

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

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa : Color → Set where
    _KT : (c : Color) → KoopaTroopa c

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

  data Clearance : Set where
    Low  : Clearance
    High : Clearance
    God  : Clearance

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

  data _c>_ : Color → Clearance → Set where
    <red>   : ∀ {c} → c c> Low
    <green> : Green c> High

  data _follows_⟨_⟩ : Position → Position → Color → Set where
    stay  : ∀ {c x y} → pos x y gas Low follows pos x y gas Low ⟨ c ⟩
    next  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos (suc x) y gas cl follows pos x y gas Low ⟨ c ⟩
    back  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos x y gas cl follows pos (suc x) y gas Low ⟨ c ⟩
    -- jump  : ∀ {c x y} → pos x (suc y) gas High follows pos x y gas Low ⟨ c ⟩
    fall  : ∀ {c cl x y} → pos x y gas cl follows pos x (suc y) gas High ⟨ c ⟩

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

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

  matToPosVec : {n : ℕ} → Vec Material n → Vec Material n → ℕ → ℕ →
                   Vec Position n
  matToPosVec []           []        _ _ = []
  matToPosVec (mat ∷ mats) (under ∷ unders) x y =
    pos x y mat cl ∷ matToPosVec mats unders (x + 1) y
      where
        clearance : Material → Material → Clearance
        clearance gas   gas   = High
        clearance gas   solid = Low
        clearance solid _     = God
        cl = clearance mat under

  matToPosVecs : {w h : ℕ} → Vec (Vec Material w) h → Vec (Vec Position w) h
  matToPosVecs [] = []
  matToPosVecs (_∷_ {y} mats matss) =
    matToPosVec mats (unders matss gas) 0 y ∷ matToPosVecs matss
    where
      unders : ∀ {m n ℓ}{A : Set ℓ} → Vec (Vec A m) n → A → Vec A m
      unders [] fallback = vreplicate fallback
      unders (us ∷ _) _ = us

  matsToMat : {w h : ℕ} → Vec (Vec Material w) h → Matrix Position w h
  matsToMat matss = Mat (reverse (matToPosVecs matss))

  □ : Material
  □ = gas
  ■ : Material
  ■ = solid
  example_level : Matrix Position 10 7
  example_level = matsToMat (
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ []) ∷
    (■ ∷ ■ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ []) ∷ [])

  _<'_ : ℕ → ℕ → Set
  m <' zero = ⊥
  zero <' suc n = ⊤
  suc m <' suc n = m <' n

  fromNat : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  fromNat {zero} k {}
  fromNat {suc n} zero = fzero
  fromNat {suc n} (suc k) {p} = fsuc (fromNat k {p})

  f : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  f = fromNat

  p : (x : Fin 10) → (y : Fin 7) → Position
  p x y = lookup y x example_level

  red_path_one : Path (Red KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  red_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                 p (f 6) (f 6) ↠⟨ next ⟩
                 p (f 7) (f 6) ↠⟨ next ⟩
                 p (f 8) (f 6) ↠⟨ stay ⟩ []

  red_path_two : Path (Red KT) (p (f 2) (f 1)) (p (f 3) (f 1))
  red_path_two = p (f 2) (f 1) ↠⟨ back ⟩
                 p (f 1) (f 1) ↠⟨ next ⟩
                 p (f 2) (f 1) ↠⟨ next ⟩
                 p (f 3) (f 1) ↠⟨ next ⟩
                 p (f 4) (f 1) ↠⟨ back ⟩
                 p (f 3) (f 1) ↠⟨ stay ⟩
                 []

  -- -- Type error shows up 'late' because 'cons' is right associative
  -- red_nopath_one : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩
  --                  p (f 0) (f 1) ↠⟨ stay ⟩
  --                  []

  -- -- Red KoopaTroopa can't step into a wall
  -- red_nopath_two : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_two = p (f 1) (f 1) ↠⟨ back ⟩ []

  -- -- Red KoopaTroopa can't step into air
  -- red_nopath_three : Path (Red KT) (p (f 4) (f 1)) (p (f 5) (f 1))
  -- red_nopath_three = p (f 4) (f 1) ↠⟨ next ⟩ []

  -- Any path that is valid for red KoopaTroopas, is also valid for green
  -- KoopaTroopas because we did not constrain KoopaTroopas to only turn
  -- When there is an obstacle
  green_path_one : Path (Green KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  green_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ next ⟩
                   p (f 7) (f 6) ↠⟨ next ⟩
                   p (f 8) (f 6) ↠⟨ stay ⟩ []

  green_path_two : Path (Green KT) (p (f 7) (f 6)) (p (f 5) (f 0))
  green_path_two = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ back ⟩
                   p (f 5) (f 6) ↠⟨ fall ⟩
                   p (f 5) (f 5) ↠⟨ fall ⟩
                   p (f 5) (f 4) ↠⟨ back ⟩
                   p (f 4) (f 4) ↠⟨ back ⟩
                   p (f 3) (f 4) ↠⟨ back ⟩
                   p (f 2) (f 4) ↠⟨ fall ⟩
                   p (f 2) (f 3) ↠⟨ fall ⟩
                   p (f 2) (f 2) ↠⟨ fall ⟩
                   p (f 2) (f 1) ↠⟨ back ⟩
                   p (f 1) (f 1) ↠⟨ next ⟩
                   p (f 2) (f 1) ↠⟨ next ⟩
                   p (f 3) (f 1) ↠⟨ next ⟩
                   p (f 4) (f 1) ↠⟨ next ⟩
                   p (f 5) (f 1) ↠⟨ fall ⟩
                   []

  -- -- Green KoopaTroopa can't step into a wall
  -- green_nopath_one : Path (Green KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- green_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩ []