module Oscar.Data.Substitunction {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Data.Equality
open import Oscar.Data.Equality.properties
open import Oscar.Data.Fin
open import Oscar.Data.Nat
open import Oscar.Data.Term FunctionName
open import Oscar.Data.Vec
open import Oscar.Function
open import Oscar.Level
open import Oscar.Relation

-- Substitunction
_⊸_ : (m n : Nat) → Set 𝔣
m ⊸ n = Fin m → Term n

▸ : ∀ {m n} → m ⟨ Fin ⟩→ n → m ⊸ n
▸ r = i ∘ r

infix 19 _◂_ _◂s_

mutual

  _◂_ : ∀ {m n} → m ⊸ n → m ⟨ Term ⟩→ n
  σ̇ ◂ i 𝑥 = σ̇ 𝑥
  _ ◂ leaf = leaf
  σ̇ ◂ (τl fork τr) = (σ̇ ◂ τl) fork (σ̇ ◂ τr)
  σ̇ ◂ (function fn τs) = function fn (σ̇ ◂s τs) where

  _◂s_ : ∀ {m n} → m ⊸ n → ∀ {N} → m ⟨ Terms N ⟩→ n  -- Vec (Term m) N → Vec (Term n) N
  f ◂s [] = []
  f ◂s (t ∷ ts) = f ◂ t ∷ f ◂s ts

_∙_ : ∀ {m n} → m ⊸ n → ∀ {l} → l ⊸ m → l ⊸ n
_∙_ f g = (f ◂_) ∘ g

mutual

  ◂-extensionality : ∀ {m n} {f g : m ⊸ n} → f ≡̇ g → f ◂_ ≡̇ g ◂_
  ◂-extensionality p (i x) = p x
  ◂-extensionality p leaf = refl
  ◂-extensionality p (s fork t) = cong₂ _fork_ (◂-extensionality p s) (◂-extensionality p t)
  ◂-extensionality p (function fn ts) = cong (function fn) (◂s-extensionality p ts)

  ◂s-extensionality : ∀ {m n} {f g : m ⊸ n} → f ≡̇ g → ∀ {N} → _◂s_ f {N} ≡̇ _◂s_ g
  ◂s-extensionality p [] = refl
  ◂s-extensionality p (t ∷ ts) = cong₂ _∷_ (◂-extensionality p t) (◂s-extensionality p ts)

mutual

  ◂-associativity : ∀ {l m} (f : l ⊸ m) {n} (g : m ⊸ n) → (g ∙ f) ◂_ ≡̇ (g ◂_) ∘ (f ◂_)
  ◂-associativity _ _ (i _) = refl
  ◂-associativity _ _ leaf = refl
  ◂-associativity _ _ (τ₁ fork τ₂) = cong₂ _fork_ (◂-associativity _ _ τ₁) (◂-associativity _ _ τ₂)
  ◂-associativity f g (function fn ts) = cong (function fn) (◂s-associativity f g ts)

  ◂s-associativity : ∀ {l m n} (f : l ⊸ m) (g : m ⊸ n) → ∀ {N} → (_◂s_ (g ∙ f) {N}) ≡̇ (g ◂s_) ∘ (f ◂s_)
  ◂s-associativity _ _ [] = refl
  ◂s-associativity _ _ (τ ∷ τs) = cong₂ _∷_ (◂-associativity _ _ τ) (◂s-associativity _ _ τs)

∙-associativity : ∀ {k l} (f : k ⊸ l) {m} (g : l ⊸ m) {n} (h : m ⊸ n) → (h ∙ g) ∙ f ≡̇ h ∙ (g ∙ f)
∙-associativity f g h x rewrite ◂-associativity g h (f x) = refl

∙-extensionality : ∀ {l m} {f₁ f₂ : l ⊸ m} → f₁ ≡̇ f₂ → ∀ {n} {g₁ g₂ : m ⊸ n} → g₁ ≡̇ g₂ → g₁ ∙ f₁ ≡̇ g₂ ∙ f₂
∙-extensionality {f₂ = f₂} f₁≡̇f₂ g₁≡̇g₂ x rewrite f₁≡̇f₂ x = ◂-extensionality g₁≡̇g₂ (f₂ x)

ε : ∀ {m} → m ⊸ m
ε = i

mutual

  ◂-identity : ∀ {m} (t : Term m) → ε ◂ t ≡ t
  ◂-identity (i x) = refl
  ◂-identity leaf = refl
  ◂-identity (s fork t) = cong₂ _fork_ (◂-identity s) (◂-identity t)
  ◂-identity (function fn ts) = cong (function fn) (◂s-identity ts)

  ◂s-identity : ∀ {N m} (t : Vec (Term m) N) → ε ◂s t ≡ t
  ◂s-identity [] = refl
  ◂s-identity (t ∷ ts) = cong₂ _∷_ (◂-identity t) (◂s-identity ts)

∙-left-identity : ∀ {m n} (f : m ⊸ n) → ε ∙ f ≡̇ f
∙-left-identity f = ◂-identity ∘ f

∙-right-identity : ∀ {m n} (f : m ⊸ n) → f ∙ ε ≡̇ f
∙-right-identity _ _ = refl

open import Oscar.Category

semigroupoidSubstitunction : Semigroupoid _⊸_ (λ {m n} → ≡̇-setoid (λ _ → Term n))
Semigroupoid._∙_ semigroupoidSubstitunction = _∙_
Semigroupoid.∙-extensionality semigroupoidSubstitunction = ∙-extensionality
Semigroupoid.∙-associativity semigroupoidSubstitunction = ∙-associativity

semigroupoidExtensionTerm : Semigroupoid (_⟨ Term ⟩→_) (λ {m n} → ≡̇-setoid (λ _ → Term n))
Semigroupoid._∙_ semigroupoidExtensionTerm g = g ∘_
Semigroupoid.∙-extensionality semigroupoidExtensionTerm {f₂ = f₂} f₁≡̇f₂ g₁≡̇g₂ x rewrite f₁≡̇f₂ x = g₁≡̇g₂ (f₂ x)
Semigroupoid.∙-associativity semigroupoidExtensionTerm _ _ _ _ = refl

semigroupoidExtensionTerms : ∀ N → Semigroupoid (_⟨ Terms N ⟩→_) (λ {m n} → ≡̇-setoid (λ _ → Terms N n))
Semigroupoid._∙_ (semigroupoidExtensionTerms _) g = g ∘_
Semigroupoid.∙-extensionality (semigroupoidExtensionTerms _) {f₂ = f₂} f₁≡̇f₂ g₁≡̇g₂ x rewrite f₁≡̇f₂ x = g₁≡̇g₂ (f₂ x)
Semigroupoid.∙-associativity (semigroupoidExtensionTerms _) _ _ _ _ = refl

semifunctorSubstitute : Semifunctor semigroupoidSubstitunction semigroupoidExtensionTerm
Semifunctor.μ semifunctorSubstitute = id
Semifunctor.𝔣 semifunctorSubstitute = _◂_
Semifunctor.𝔣-extensionality semifunctorSubstitute = ◂-extensionality
Semifunctor.𝔣-commutativity semifunctorSubstitute {f = f} {g = g} = ◂-associativity f g

semifunctorSubstitutes : ∀ N → Semifunctor semigroupoidSubstitunction (semigroupoidExtensionTerms N)
Semifunctor.μ (semifunctorSubstitutes _) = id
Semifunctor.𝔣 (semifunctorSubstitutes N) f τs = f ◂s τs
Semifunctor.𝔣-extensionality (semifunctorSubstitutes _) f≡̇g = ◂s-extensionality f≡̇g
Semifunctor.𝔣-commutativity (semifunctorSubstitutes _) {f = f} {g = g} = ◂s-associativity f g

------------ subfact3 : ∀ {l m n} (f : m ⊸ n) (r : l ⟨ Fin ⟩→ m) → f ◇ (▸ r) ≡ f ∘ r
------------ subfact3 f r = refl

-- -- -- -- prop-id : ∀ {m n} {f : _ ⊸ n} {ℓ} {P : ⊸-ExtentionalProperty {ℓ} m} → proj₁ P f → proj₁ P (i ◇ f)
-- -- -- -- prop-id {_} {_} {f} {_} {P'} Pf = proj₂ P' (λ x → sym (◃-identity (f x))) Pf

-- -- -- -- ≐-cong : ∀ {m n o} {f : m ⊸ n} {g} (h : _ ⊸ o) → f ≐ g → (h ◇ f) ≐ (h ◇ g)
-- -- -- -- ≐-cong h f≐g t = cong (h ◃_) (f≐g t)

-- -- -- -- -- data AList : ℕ -> ℕ -> Set 𝔣 where
-- -- -- -- --   anil : ∀ {n} -> AList n n
-- -- -- -- --   _asnoc_/_ : ∀ {m n} (σ : AList m n) (t' : Term m) (x : Fin (suc m))
-- -- -- -- --                -> AList (suc m) n

-- -- -- -- -- sub : ∀ {m n} (σ : AList m n) -> Fin m -> Term n
-- -- -- -- -- sub anil = i
-- -- -- -- -- sub (σ asnoc t' / x) = sub σ ◇ (t' for x)

-- -- -- -- -- _++_ : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> AList l n
-- -- -- -- -- ρ ++ anil = ρ
-- -- -- -- -- ρ ++ (σ asnoc t' / x) = (ρ ++ σ) asnoc t' / x

-- -- -- -- -- ++-assoc : ∀ {l m n o} (ρ : AList l m) (σ : AList n _) (τ : AList o _) -> ρ ++ (σ ++ τ) ≡ (ρ ++ σ) ++ τ
-- -- -- -- -- ++-assoc ρ σ anil = refl
-- -- -- -- -- ++-assoc ρ σ (τ asnoc t / x) = cong (λ s -> s asnoc t / x) (++-assoc ρ σ τ)

-- -- -- -- -- module SubList where
-- -- -- -- --   anil-id-l : ∀ {m n} (σ : AList m n) -> anil ++ σ ≡ σ
-- -- -- -- --   anil-id-l anil = refl
-- -- -- -- --   anil-id-l (σ asnoc t' / x) = cong (λ σ -> σ asnoc t' / x) (anil-id-l σ)

-- -- -- -- --   fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> sub (ρ ++ σ) ≐ (sub ρ ◇ sub σ)
-- -- -- -- --   fact1 ρ anil v = refl
-- -- -- -- --   fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
-- -- -- -- --     where
-- -- -- -- --       t = (t' for x) v
-- -- -- -- --       hyp-on-terms = ◃-extentionality (fact1 r s) t
-- -- -- -- --       ◃-assoc = ◃-associativity t

-- -- -- -- -- _∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
-- -- -- -- --   -> ∃ (AList (suc m))
-- -- -- -- -- (n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

-- -- -- -- -- open import Data.Maybe using (Maybe; nothing; just)

-- -- -- -- -- flexFlex : ∀ {m} (x y : Fin m) -> ∃ (AList m)
-- -- -- -- -- flexFlex {suc m} x y with check x y
-- -- -- -- -- ...              | just y' = m , anil asnoc i y' / x
-- -- -- -- -- ...              | nothing = suc m , anil
-- -- -- -- -- flexFlex {zero} () _

-- -- -- -- -- open import Oscar.Class.ThickAndThin

-- -- -- -- -- flexRigid : ∀ {m} (x : Fin m) (t : Term m) -> Maybe (∃(AList m))
-- -- -- -- -- flexRigid {suc m} x t with check x t
-- -- -- -- -- ...                   | just t' = just (m , anil asnoc t' / x)
-- -- -- -- -- ...                   | nothing = nothing
-- -- -- -- -- flexRigid {zero} () _

-- -- -- -- -- -- open import Oscar.Data.Fin using (Fin; zero; suc; thick?; Check; check; thin; module Thick)

-- -- -- -- -- -- open import Data.Fin using (Fin; suc; zero)
-- -- -- -- -- -- open import Data.Nat hiding (_≤_)
-- -- -- -- -- -- open import Relation.Binary.PropositionalEquality renaming ([_] to [[_]])
-- -- -- -- -- -- open import Function using (_∘_; id; case_of_; _$_; flip)
-- -- -- -- -- -- open import Relation.Nullary
-- -- -- -- -- -- open import Data.Product renaming (map to _***_)
-- -- -- -- -- -- open import Data.Empty
-- -- -- -- -- -- open import Data.Maybe
-- -- -- -- -- -- open import Category.Functor
-- -- -- -- -- -- open import Category.Monad
-- -- -- -- -- -- import Level
-- -- -- -- -- -- open RawMonad (Data.Maybe.monad {Level.zero})
-- -- -- -- -- -- open import Data.Sum
-- -- -- -- -- -- open import Data.Maybe using (maybe; maybe′; nothing; just; monad; Maybe)
-- -- -- -- -- -- open import Data.List renaming (_++_ to _++L_)
-- -- -- -- -- -- open ≡-Reasoning
-- -- -- -- -- -- open import Data.Vec using (Vec; []; _∷_) renaming (_++_ to _++V_; map to mapV)

-- -- -- -- -- -- open import Data.Nat using (ℕ; suc; zero)
-- -- -- -- -- -- open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; trans)
-- -- -- -- -- -- open import Function using (_∘_; flip)
-- -- -- -- -- -- open import Relation.Nullary using (¬_; Dec; yes; no)
-- -- -- -- -- -- open import Data.Product using (∃; _,_; _×_)
-- -- -- -- -- -- open import Data.Empty using (⊥-elim)
-- -- -- -- -- -- open import Data.Vec using (Vec; []; _∷_)

-- -- -- -- -- -- Term-function-inj-FunctionName : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → fn₁ ≡ fn₂
-- -- -- -- -- -- Term-function-inj-FunctionName refl = refl

-- -- -- -- -- -- Term-function-inj-VecSize : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → N₁ ≡ N₂
-- -- -- -- -- -- Term-function-inj-VecSize refl = refl

-- -- -- -- -- -- Term-function-inj-Vector : ∀ {fn₁ fn₂} {n N} {ts₁ : Vec (Term n) N} {ts₂ : Vec (Term n) N} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → ts₁ ≡ ts₂
-- -- -- -- -- -- Term-function-inj-Vector refl = refl

-- -- -- -- -- -- Term-fork-inj-left : ∀ {n} {l₁ r₁ l₂ r₂ : Term n} → l₁ fork r₁ ≡ l₂ fork r₂ → l₁ ≡ l₂
-- -- -- -- -- -- Term-fork-inj-left refl = refl

-- -- -- -- -- -- Term-fork-inj-right : ∀ {n} {l₁ r₁ l₂ r₂ : Term n} → l₁ fork r₁ ≡ l₂ fork r₂ → r₁ ≡ r₂
-- -- -- -- -- -- Term-fork-inj-right refl = refl

-- -- -- -- -- -- open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)

-- -- -- -- -- -- Term-function-inj-HetVector : ∀ {fn₁ fn₂} {n N₁ N₂} {ts₁ : Vec (Term n) N₁} {ts₂ : Vec (Term n) N₂} → Term.function fn₁ ts₁ ≡ Term.function fn₂ ts₂ → ts₁ ≅ ts₂
-- -- -- -- -- -- Term-function-inj-HetVector refl = refl

-- -- -- -- -- -- _⊸_ : (m n : ℕ) → Set
-- -- -- -- -- -- m ⊸ n = Fin m → Term n

-- -- -- -- -- -- ▸ : ∀ {m n} → (r : Fin m → Fin n) → Fin m → Term n
-- -- -- -- -- -- ▸ r = i ∘ r

-- -- -- -- -- -- record Substitution (T : ℕ → Set) : Set where
-- -- -- -- -- --   field
-- -- -- -- -- --     _◃_ : ∀ {m n} → (f : m ⊸ n) → T m → T n

-- -- -- -- -- -- open Substitution ⦃ … ⦄ public

-- -- -- -- -- -- {-# DISPLAY Substitution._◃_ _ = _◃_ #-}

-- -- -- -- -- -- mutual

-- -- -- -- -- --   instance SubstitutionTerm : Substitution Term
-- -- -- -- -- --   Substitution._◃_ SubstitutionTerm = _◃′_ where
-- -- -- -- -- --     _◃′_ : ∀ {m n} → (f : m ⊸ n) → Term m → Term n
-- -- -- -- -- --     f ◃′ i x = f x
-- -- -- -- -- --     f ◃′ leaf = leaf
-- -- -- -- -- --     f ◃′ (s fork t) = (f ◃ s) fork (f ◃ t)
-- -- -- -- -- --     f ◃′ (function fn ts) = function fn (f ◃ ts)

-- -- -- -- -- --   instance SubstitutionVecTerm : ∀ {N} → Substitution (flip Vec N ∘ Term )
-- -- -- -- -- --   Substitution._◃_ (SubstitutionVecTerm {N}) = _◃′_ where
-- -- -- -- -- --     _◃′_ : ∀ {m n} → (f : m ⊸ n) → Vec (Term m) N → Vec (Term n) N
-- -- -- -- -- --     f ◃′ [] = []
-- -- -- -- -- --     f ◃′ (t ∷ ts) = f ◃ t ∷ f ◃ ts

-- -- -- -- -- -- _≐_ : {m n : ℕ} → (Fin m → Term n) → (Fin m → Term n) → Set
-- -- -- -- -- -- f ≐ g = ∀ x → f x ≡ g x

-- -- -- -- -- -- record SubstitutionExtensionality (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set₁ where
-- -- -- -- -- --   field
-- -- -- -- -- --     ◃ext : ∀ {m n} {f g : Fin m → Term n} → f ≐ g → (t : T m) → f ◃ t ≡ g ◃ t

-- -- -- -- -- -- open SubstitutionExtensionality ⦃ … ⦄ public

-- -- -- -- -- -- mutual

-- -- -- -- -- --   instance SubstitutionExtensionalityTerm : SubstitutionExtensionality Term
-- -- -- -- -- --   SubstitutionExtensionality.◃ext SubstitutionExtensionalityTerm = ◃ext′ where
-- -- -- -- -- --     ◃ext′ : ∀ {m n} {f g : Fin m → Term n} → f ≐ g → ∀ t → f ◃ t ≡ g ◃ t
-- -- -- -- -- --     ◃ext′ p (i x) = p x
-- -- -- -- -- --     ◃ext′ p leaf = refl
-- -- -- -- -- --     ◃ext′ p (s fork t) = cong₂ _fork_ (◃ext p s) (◃ext p t)
-- -- -- -- -- --     ◃ext′ p (function fn ts) = cong (function fn) (◃ext p ts)

-- -- -- -- -- --   instance SubstitutionExtensionalityVecTerm : ∀ {N} → SubstitutionExtensionality (flip Vec N ∘ Term)
-- -- -- -- -- --   SubstitutionExtensionality.◃ext (SubstitutionExtensionalityVecTerm {N}) = λ x → ◃ext′ x where
-- -- -- -- -- --     ◃ext′ : ∀ {m n} {f g : Fin m → Term n} → f ≐ g → ∀ {N} (t : Vec (Term m) N) → f ◃ t ≡ g ◃ t
-- -- -- -- -- --     ◃ext′ p [] = refl
-- -- -- -- -- --     ◃ext′ p (t ∷ ts) = cong₂ _∷_ (◃ext p t) (◃ext p ts)

-- -- -- -- -- -- _◇_ : ∀ {l m n : ℕ } → (f : Fin m → Term n) (g : Fin l → Term m) → Fin l → Term n
-- -- -- -- -- -- f ◇ g = (f ◃_) ∘ g

-- -- -- -- -- -- ≐-cong : ∀ {m n o} {f : m ⊸ n} {g} (h : _ ⊸ o) → f ≐ g → (h ◇ f) ≐ (h ◇ g)
-- -- -- -- -- -- ≐-cong h f≐g t = cong (h ◃_) (f≐g t)

-- -- -- -- -- -- ≐-sym : ∀ {m n} {f : m ⊸ n} {g} → f ≐ g → g ≐ f
-- -- -- -- -- -- ≐-sym f≐g = sym ∘ f≐g

-- -- -- -- -- -- module Sub where
-- -- -- -- -- --   record Fact1 (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set where
-- -- -- -- -- --     field
-- -- -- -- -- --       fact1 : ∀ {n} → (t : T n) → i ◃ t ≡ t

-- -- -- -- -- --   open Fact1 ⦃ … ⦄ public

-- -- -- -- -- --   mutual

-- -- -- -- -- --     instance Fact1Term : Fact1 Term
-- -- -- -- -- --     Fact1.fact1 Fact1Term (i x) = refl
-- -- -- -- -- --     Fact1.fact1 Fact1Term leaf = refl
-- -- -- -- -- --     Fact1.fact1 Fact1Term (s fork t) = cong₂ _fork_ (fact1 s) (fact1 t)
-- -- -- -- -- --     Fact1.fact1 Fact1Term (function fn ts) = cong (function fn) (fact1 ts)

-- -- -- -- -- --     instance Fact1TermVec : ∀ {N} → Fact1 (flip Vec N ∘ Term)
-- -- -- -- -- --     Fact1.fact1 Fact1TermVec [] = refl
-- -- -- -- -- --     Fact1.fact1 Fact1TermVec (t ∷ ts) = cong₂ _∷_ (fact1 t) (fact1 ts)

-- -- -- -- -- --   record Fact2 (T : ℕ → Set) ⦃ _ : Substitution T ⦄ : Set where
-- -- -- -- -- --     field
-- -- -- -- -- --       -- ⦃ s ⦄ : Substitution T
-- -- -- -- -- --       fact2 : ∀ {l m n} → {f : Fin m → Term n} {g : _} (t : T l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)

-- -- -- -- -- --   open Fact2 ⦃ … ⦄ public

-- -- -- -- -- --   mutual

-- -- -- -- -- --     instance Fact2Term : Fact2 Term
-- -- -- -- -- --     -- Fact2.s Fact2Term = SubstitutionTerm
-- -- -- -- -- --     Fact2.fact2 Fact2Term (i x) = refl
-- -- -- -- -- --     Fact2.fact2 Fact2Term leaf = refl
-- -- -- -- -- --     Fact2.fact2 Fact2Term (s fork t) = cong₂ _fork_ (fact2 s) (fact2 t)
-- -- -- -- -- --     Fact2.fact2 Fact2Term {f = f} {g = g} (function fn ts) = cong (function fn) (fact2 {f = f} {g = g} ts) -- fact2 ts

-- -- -- -- -- --     instance Fact2TermVec : ∀ {N} → Fact2 (flip Vec N ∘ Term)
-- -- -- -- -- --     -- Fact2.s Fact2TermVec = SubstitutionVecTerm
-- -- -- -- -- --     Fact2.fact2 Fact2TermVec [] = refl
-- -- -- -- -- --     Fact2.fact2 Fact2TermVec (t ∷ ts) = cong₂ _∷_ (fact2 t) (fact2 ts)

-- -- -- -- -- --   fact3 : ∀ {l m n} (f : Fin m → Term n) (r : Fin l → Fin m) → (f ◇ (▸ r)) ≡ (f ∘ r)
-- -- -- -- -- --   fact3 f r = refl

-- -- -- -- -- -- ◃ext' : ∀ {m n o} {f : Fin m → Term n}{g : Fin m → Term o}{h} → f ≐ (h ◇ g) → ∀ (t : Term _) → f ◃ t ≡ h ◃ (g ◃ t)
-- -- -- -- -- -- ◃ext' p t = trans (◃ext p t) (Sub.fact2 t)

-- -- -- -- -- -- open import Data.Maybe using (Maybe; nothing; just; functor; maybe′; maybe)
-- -- -- -- -- -- open import Category.Monad
-- -- -- -- -- -- import Level
-- -- -- -- -- -- --open RawMonad (Data.Maybe.monad {Level.zero})
-- -- -- -- -- -- open import Data.Nat using (ℕ)

-- -- -- -- -- -- _<*>_ = _⊛_

-- -- -- -- -- -- mutual

-- -- -- -- -- --   instance CheckTerm : Check Term
-- -- -- -- -- --   Check.check CheckTerm x (i y) = i <$> thick? x y
-- -- -- -- -- --   Check.check CheckTerm x leaf = just leaf
-- -- -- -- -- --   Check.check CheckTerm x (s fork t) = _fork_ <$> check x s ⊛ check x t
-- -- -- -- -- --   Check.check CheckTerm x (function fn ts) = ⦇ (function fn) (check x ts) ⦈

-- -- -- -- -- --   instance CheckTermVec : ∀ {N} → Check (flip Vec N ∘ Term)
-- -- -- -- -- --   Check.check CheckTermVec x [] = just []
-- -- -- -- -- --   Check.check CheckTermVec x (t ∷ ts) = ⦇ check x t ∷ check x ts ⦈

-- -- -- -- -- -- _for_ : ∀ {n} (t' : Term n) (x : Fin (suc n)) → Fin (suc n) → Term n
-- -- -- -- -- -- (t' for x) y = maybe′ i t' (thick? x y)

-- -- -- -- -- -- open import Data.Product using () renaming (Σ to Σ₁)
-- -- -- -- -- -- open Σ₁ renaming (proj₁ to π₁; proj₂ to π₂)

-- -- -- -- -- -- Property⋆ : (m : ℕ) → Set1
-- -- -- -- -- -- Property⋆ m = ∀ {n} → (Fin m → Term n) → Set

-- -- -- -- -- -- Extensional : {m : ℕ} → Property⋆ m → Set
-- -- -- -- -- -- Extensional P = ∀ {m f g} → f ≐ g → P {m} f → P g

-- -- -- -- -- -- Property : (m : ℕ) → Set1
-- -- -- -- -- -- Property m = Σ₁ (Property⋆ m) Extensional

-- -- -- -- -- -- prop-id : ∀ {m n} {f : _ ⊸ n} {P : Property m} → π₁ P f → π₁ P (i ◇ f)
-- -- -- -- -- -- prop-id {_} {_} {f} {P'} Pf = π₂ P' (λ x → sym (Sub.fact1 (f x))) Pf

-- -- -- -- -- -- Unifies⋆ : ∀ {m} (s t : Term m) → Property⋆ m
-- -- -- -- -- -- Unifies⋆ s t f = f ◃ s ≡ f ◃ t

-- -- -- -- -- -- Unifies⋆V : ∀ {m N} (ss ts : Vec (Term m) N) → Property⋆ m
-- -- -- -- -- -- Unifies⋆V ss ts f = f ◃ ss ≡ f ◃ ts

-- -- -- -- -- -- open import Relation.Binary.PropositionalEquality renaming ([_] to [[_]])
-- -- -- -- -- -- open ≡-Reasoning

-- -- -- -- -- -- Unifies : ∀ {m} (s t : Term m) → Property m
-- -- -- -- -- -- Unifies s t = (λ {_} → Unifies⋆ s t) , λ {_} {f} {g} f≐g f◃s=f◃t →
-- -- -- -- -- --   begin
-- -- -- -- -- --     g ◃ s
-- -- -- -- -- --   ≡⟨ sym (◃ext f≐g s) ⟩
-- -- -- -- -- --     f ◃ s
-- -- -- -- -- --   ≡⟨ f◃s=f◃t ⟩
-- -- -- -- -- --     f ◃ t
-- -- -- -- -- --   ≡⟨ ◃ext f≐g t ⟩
-- -- -- -- -- --     g ◃ t
-- -- -- -- -- --   ∎

-- -- -- -- -- -- UnifiesV : ∀ {m} {N} (s t : Vec (Term m) N) → Property m
-- -- -- -- -- -- UnifiesV s t = (λ {_} → Unifies⋆V s t) , λ {_} {f} {g} f≐g f◃s=f◃t →
-- -- -- -- -- --   begin
-- -- -- -- -- --     g ◃ s
-- -- -- -- -- --   ≡⟨ sym (◃ext f≐g s) ⟩
-- -- -- -- -- --     f ◃ s
-- -- -- -- -- --   ≡⟨ f◃s=f◃t ⟩
-- -- -- -- -- --     f ◃ t
-- -- -- -- -- --   ≡⟨ ◃ext f≐g t ⟩
-- -- -- -- -- --     g ◃ t
-- -- -- -- -- --   ∎

-- -- -- -- -- -- _∧⋆_ : ∀{m} → (P Q : Property⋆ m) → Property⋆ m
-- -- -- -- -- -- P ∧⋆ Q = (λ f → P f × Q f)

-- -- -- -- -- -- -- open import Data.Product renaming (map to _***_)
-- -- -- -- -- -- open import Data.Product using (Σ)
-- -- -- -- -- -- open Σ

-- -- -- -- -- -- _∧_ : ∀{m} → (P Q : Property m) → Property m
-- -- -- -- -- -- P ∧ Q = (λ {_} f → π₁ P f × π₁ Q f) , λ {_} {_} {_} f≐g Pf×Qf → π₂ P f≐g (proj₁ Pf×Qf) , π₂ Q f≐g (proj₂ Pf×Qf)

-- -- -- -- -- -- _⇔⋆_ : ∀{m} → (P Q : Property⋆ m) → Set
-- -- -- -- -- -- P ⇔⋆ Q = ∀ {n} f → (P {n} f → Q f) × (Q f → P f)

-- -- -- -- -- -- _⇔_ : ∀{m} → (P Q : Property m) → Set
-- -- -- -- -- -- P ⇔ Q = ∀ {n} f → (π₁ P {n} f → π₁ Q f) × (π₁ Q f → π₁ P f)

-- -- -- -- -- -- switch⋆ : ∀ {m} (P Q : Property⋆ m) → P ⇔⋆ Q → Q ⇔⋆ P
-- -- -- -- -- -- switch⋆ _ _ P⇔Q f = proj₂ (P⇔Q f) , proj₁ (P⇔Q f)

-- -- -- -- -- -- switch : ∀ {m} (P Q : Property m) → P ⇔ Q → Q ⇔ P
-- -- -- -- -- -- switch _ _ P⇔Q f = proj₂ (P⇔Q f) , proj₁ (P⇔Q f)

-- -- -- -- -- -- open import Data.Empty

-- -- -- -- -- -- Nothing⋆ : ∀{m} → (P : Property⋆ m) → Set
-- -- -- -- -- -- Nothing⋆ P = ∀{n} f → P {n} f → ⊥

-- -- -- -- -- -- Nothing : ∀{m} → (P : Property m) → Set
-- -- -- -- -- -- Nothing P = ∀{n} f → π₁ P {n} f → ⊥

-- -- -- -- -- -- _[-◇⋆_] : ∀{m n} (P : Property⋆ m) (f : Fin m → Term n) → Property⋆ n
-- -- -- -- -- -- (P [-◇⋆ f ]) g = P (g ◇ f)

-- -- -- -- -- -- _[-◇_] : ∀{m n} (P : Property m) (f : Fin m → Term n) → Property n
-- -- -- -- -- -- P [-◇ f ] = (λ {_} g → π₁ P (g ◇ f)) , λ {_} {f'} {g'} f'≐g' Pf'◇f → π₂ P (◃ext f'≐g' ∘ f)  Pf'◇f

-- -- -- -- -- -- open import Function using (_∘_; id; case_of_; _$_; flip)
-- -- -- -- -- -- open import Data.Product using (curry; uncurry)

-- -- -- -- -- -- module Properties where
-- -- -- -- -- --   fact1 : ∀ {m} {s t : Term m} → (Unifies s t) ⇔ (Unifies t s)
-- -- -- -- -- --   fact1 _ = sym , sym

-- -- -- -- -- --   fact1'⋆ : ∀ {m} {s1 s2 t1 t2 : Term m}
-- -- -- -- -- --          → Unifies⋆ (s1 fork s2) (t1 fork t2) ⇔⋆ (Unifies⋆ s1 t1 ∧⋆ Unifies⋆ s2 t2)
-- -- -- -- -- --   fact1'⋆ f = deconstr _ _ _ _ , uncurry (cong₂ _fork_)
-- -- -- -- -- --     where deconstr : ∀ {m} (s1 s2 t1 t2 : Term m)
-- -- -- -- -- --                    → (s1 fork s2) ≡ (t1 fork t2)
-- -- -- -- -- --                    → (s1 ≡ t1) × (s2 ≡ t2)
-- -- -- -- -- --           deconstr s1 s2 .s1 .s2 refl = refl , refl

-- -- -- -- -- --   fact1' : ∀ {m} {s1 s2 t1 t2 : Term m}
-- -- -- -- -- --          → Unifies (s1 fork s2) (t1 fork t2) ⇔ (Unifies s1 t1 ∧ Unifies s2 t2)
-- -- -- -- -- --   fact1' f = deconstr _ _ _ _ , uncurry (cong₂ _fork_)
-- -- -- -- -- --     where deconstr : ∀ {m} (s1 s2 t1 t2 : Term m)
-- -- -- -- -- --                    → (s1 fork s2) ≡ (t1 fork t2)
-- -- -- -- -- --                    → (s1 ≡ t1) × (s2 ≡ t2)
-- -- -- -- -- --           deconstr s1 s2 .s1 .s2 refl = refl , refl

-- -- -- -- -- --   fact1'V : ∀ {m} {t₁ t₂ : Term m} {N} {ts₁ ts₂ : Vec (Term m) N}
-- -- -- -- -- --          → UnifiesV (t₁ ∷ ts₁) (t₂ ∷ ts₂) ⇔ (Unifies t₁ t₂ ∧ UnifiesV ts₁ ts₂)
-- -- -- -- -- --   fact1'V f = deconstr _ _ _ _ , uncurry (cong₂ _∷_)
-- -- -- -- -- --     where deconstr : ∀ {m} (t₁ t₂ : Term m) {N} (ts₁ ts₂ : Vec (Term m) N)
-- -- -- -- -- --                    → (t₁ Vec.∷ ts₁) ≡ (t₂ ∷ ts₂)
-- -- -- -- -- --                    → (t₁ ≡ t₂) × (ts₁ ≡ ts₂)
-- -- -- -- -- --           deconstr s1 _ s2! _ refl = refl , refl -- refl , refl

-- -- -- -- -- --   fact2⋆ : ∀ {m} (P Q : Property⋆ m) → P ⇔⋆ Q → Nothing⋆ P → Nothing⋆ Q
-- -- -- -- -- --   fact2⋆ P Q iff notp f q with iff f
-- -- -- -- -- --   ...                        | (p2q , q2p) = notp f (q2p q)

-- -- -- -- -- --   fact2 : ∀ {m} (P Q : Property m) → P ⇔ Q → Nothing P → Nothing Q
-- -- -- -- -- --   fact2 P Q iff notp f q with iff f
-- -- -- -- -- --   ...                       | (p2q , q2p) = notp f (q2p q)

-- -- -- -- -- --   fact3 : ∀ {m} {P : Property m} → P ⇔ (P [-◇ i ])
-- -- -- -- -- --   fact3 f = id , id

-- -- -- -- -- --   fact4 : ∀{m n} {P : Property m} (f : _ → Term n)
-- -- -- -- -- --           → Nothing P → Nothing (P [-◇ f ])
-- -- -- -- -- --   fact4 f nop g = nop (g ◇ f)

-- -- -- -- -- --   fact5⋆ : ∀{m n} (P Q : Property⋆ _) (f : m ⊸ n) → P ⇔⋆ Q → (P [-◇⋆ f ]) ⇔⋆ (Q [-◇⋆ f ])
-- -- -- -- -- --   fact5⋆ _ _ f P⇔Q f' = P⇔Q (f' ◇ f)

-- -- -- -- -- --   fact5 : ∀{m n} (P Q : Property _) (f : m ⊸ n) → P ⇔ Q → (P [-◇ f ]) ⇔ (Q [-◇ f ])
-- -- -- -- -- --   fact5 _ _ f P⇔Q f' = P⇔Q (f' ◇ f)

-- -- -- -- -- --   fact6 : ∀{m n} P {f g : m ⊸ n} → f ≐ g → (P [-◇ f ]) ⇔ (P [-◇ g ])
-- -- -- -- -- --   fact6 P f≐g h = π₂ P (≐-cong h f≐g) , π₂ P (≐-sym (≐-cong h f≐g))

-- -- -- -- -- -- _≤_ : ∀ {m n n'} (f : Fin m → Term n) (g : Fin m → Term n') → Set
-- -- -- -- -- -- f ≤ g = ∃ λ f' → f ≐ (f' ◇ g)

-- -- -- -- -- -- module Order where

-- -- -- -- -- --   reflex : ∀ {m n} {f : Fin m → Term n} → f ≤ f
-- -- -- -- -- --   reflex = i  , λ _ → sym (Sub.fact1 _)

-- -- -- -- -- --   transitivity : ∀ {l m n o} {f : Fin l → Term m}{g : _ → Term n}
-- -- -- -- -- --                              {h : _ → Term o}
-- -- -- -- -- --                    → f ≤ g → g ≤ h → f ≤ h
-- -- -- -- -- --   transitivity {l} {_} {_} {_} {f} {g} {h} (fg , pfg) (gh , pgh) =
-- -- -- -- -- --                    fg ◇ gh , proof
-- -- -- -- -- --     where
-- -- -- -- -- --       proof : (x : Fin l) → f x ≡ (λ x' → fg ◃ (gh x')) ◃ (h x)
-- -- -- -- -- --       proof x = trans z (sym (Sub.fact2 (h x)))
-- -- -- -- -- --         where z = trans (pfg x) (cong (fg ◃_) (pgh x))

-- -- -- -- -- --   i-max : ∀ {m n} (f : Fin m → Term n) → f ≤ i
-- -- -- -- -- --   i-max f = f , λ _ → refl

-- -- -- -- -- --   dist : ∀{l m n o}{f : Fin l → Term m}{g : _ → Term n}(h : Fin o → _) → f ≤ g → (f ◇ h) ≤ (g ◇ h)
-- -- -- -- -- --   dist h (fg , pfg) = fg  , λ x → trans (◃ext pfg (h x)) (Sub.fact2 (h x))

-- -- -- -- -- -- Max⋆ : ∀ {m} (P : Property⋆ m) → Property⋆ m
-- -- -- -- -- -- Max⋆ P f = P f × (∀ {n} f' → P {n} f' → f' ≤ f)

-- -- -- -- -- -- Max : ∀ {m} (P : Property m) → Property m
-- -- -- -- -- -- Max P' = (λ {_} → Max⋆ P) , λ {_} {_} {_} → lemma1
-- -- -- -- -- --   where
-- -- -- -- -- --     open Σ₁ P' renaming (proj₁ to P; proj₂ to Peq)
-- -- -- -- -- --     lemma1 : {m : ℕ} {f : Fin _ → Term m} {g : Fin _ → Term m} →
-- -- -- -- -- --              f ≐ g →
-- -- -- -- -- --              P f × ({n : ℕ} (f' : Fin _ → Term n) → P f' → f' ≤ f) →
-- -- -- -- -- --              P g × ({n : ℕ} (f' : Fin _ → Term n) → P f' → f' ≤ g)
-- -- -- -- -- --     lemma1 {_} {f} {g} f≐g (Pf , MaxPf) = Peq f≐g Pf , λ {_} → lemma2
-- -- -- -- -- --       where
-- -- -- -- -- --         lemma2 : ∀ {n} f' → P {n} f' → ∃ λ f0 → f' ≐ (f0 ◇ g)
-- -- -- -- -- --         lemma2 f' Pf' = f0 , λ x → trans (f'≐f0◇f x) (cong (f0 ◃_) (f≐g x))
-- -- -- -- -- --               where
-- -- -- -- -- --                 f0 = proj₁ (MaxPf f' Pf')
-- -- -- -- -- --                 f'≐f0◇f = proj₂ (MaxPf f' Pf')

-- -- -- -- -- -- module Max where
-- -- -- -- -- --   fact : ∀{m}(P Q : Property m) → P ⇔ Q → Max P ⇔ Max Q
-- -- -- -- -- --   fact {m} P Q a f =
-- -- -- -- -- --    (λ maxp → pq (proj₁ maxp) , λ f' → proj₂ maxp f' ∘ qp)
-- -- -- -- -- --     , λ maxq → qp (proj₁ maxq) , λ f'  → proj₂ maxq f' ∘ pq
-- -- -- -- -- --     where
-- -- -- -- -- --       pq : {n : ℕ} {f0 : Fin m → Term n} → (π₁ P f0 → π₁ Q f0)
-- -- -- -- -- --       pq {_} {f} =  proj₁ (a f)
-- -- -- -- -- --       qp : {n : ℕ} {f0 : Fin m → Term n} → (π₁ Q f0 → π₁ P f0)
-- -- -- -- -- --       qp {_} {f} = proj₂ (a f)

-- -- -- -- -- -- DClosed : ∀{m} (P : Property m) → Set
-- -- -- -- -- -- DClosed P = ∀ {n} f {o} g → f ≤ g → π₁ P {o} g → π₁ P {n} f

-- -- -- -- -- -- module DClosed where

-- -- -- -- -- --   fact1 : ∀ {m} s t → DClosed {m} (Unifies s t)
-- -- -- -- -- --   fact1 s t f g (f≤g , p) gs=gt =
-- -- -- -- -- --          begin
-- -- -- -- -- --          f ◃ s
-- -- -- -- -- --          ≡⟨ ◃ext' p s ⟩
-- -- -- -- -- --          f≤g ◃ (g ◃ s)
-- -- -- -- -- --          ≡⟨ cong (f≤g ◃_) gs=gt ⟩
-- -- -- -- -- --          f≤g ◃ (g ◃ t)
-- -- -- -- -- --          ≡⟨ sym (◃ext' p t) ⟩
-- -- -- -- -- --          f ◃ t
-- -- -- -- -- --          ∎

-- -- -- -- -- -- optimist : ∀ {l m n o} (a : Fin _ → Term n) (p : Fin _ → Term o)
-- -- -- -- -- --                  (q : Fin _ → Term l) (P Q : Property m)
-- -- -- -- -- --            → DClosed P → π₁ (Max (P [-◇ a ])) p
-- -- -- -- -- --            → π₁ (Max (Q [-◇ (p ◇ a) ])) q
-- -- -- -- -- --            → π₁ (Max ((P ∧ Q) [-◇ a ])) (q ◇ p)
-- -- -- -- -- -- optimist a p q P' Q' DCP (Ppa , pMax) (Qqpa , qMax) =
-- -- -- -- -- --      (Peq (sym ∘ Sub.fact2 ∘ a) (DCP (q ◇ (p ◇ a)) (p ◇ a) (q , λ _ → refl) Ppa)
-- -- -- -- -- --       , Qeq (sym ∘ Sub.fact2 ∘ a) Qqpa )
-- -- -- -- -- --      , λ {_} → aux
-- -- -- -- -- --   where
-- -- -- -- -- --     open Σ₁ P' renaming (proj₁ to P; proj₂ to Peq)
-- -- -- -- -- --     open Σ₁ Q' renaming (proj₁ to Q; proj₂ to Qeq)
-- -- -- -- -- --     aux : ∀ {n} (f : _ → Term n) → P (f ◇ a) × Q (f ◇ a) → f ≤ (q ◇ p)
-- -- -- -- -- --     aux f (Pfa , Qfa) = h ,
-- -- -- -- -- --                         λ x → trans (f≐g◇p x) (◃ext' g≐h◇q (p x))
-- -- -- -- -- --       where
-- -- -- -- -- --         one = pMax f Pfa
-- -- -- -- -- --         g = proj₁ one
-- -- -- -- -- --         f≐g◇p = proj₂ one
-- -- -- -- -- --         Qgpa : Q (g ◇ (p ◇ a))
-- -- -- -- -- --         Qgpa = Qeq (λ x → ◃ext' f≐g◇p (a x)) Qfa
-- -- -- -- -- --         g≤q = qMax g Qgpa
-- -- -- -- -- --         h = proj₁ g≤q
-- -- -- -- -- --         g≐h◇q = proj₂ g≤q

-- -- -- -- -- -- module failure-propagation where

-- -- -- -- -- --   first⋆ : ∀ {m n} (a : _ ⊸ n) (P Q : Property⋆ m) →
-- -- -- -- -- --          Nothing⋆ (P [-◇⋆ a ]) → Nothing⋆ ((P ∧⋆ Q) [-◇⋆ a ])
-- -- -- -- -- --   first⋆ a P' Q' noP-a f (Pfa , Qfa) = noP-a f Pfa

-- -- -- -- -- --   first : ∀ {m n} (a : _ ⊸ n) (P Q : Property m) →
-- -- -- -- -- --          Nothing (P [-◇ a ]) → Nothing ((P ∧ Q) [-◇ a ])
-- -- -- -- -- --   first a P' Q' noP-a f (Pfa , Qfa) = noP-a f Pfa

-- -- -- -- -- --   second⋆ : ∀ {m n o} (a : _ ⊸ n) (p : _ ⊸ o)(P : Property⋆ m)(Q : Property m) →
-- -- -- -- -- --              (Max⋆ (P [-◇⋆ a ])) p → Nothing⋆ (π₁ Q [-◇⋆ (p ◇ a)])
-- -- -- -- -- --              → Nothing⋆ ((P ∧⋆ π₁ Q) [-◇⋆ a ])
-- -- -- -- -- --   second⋆ a p P' Q' (Ppa , pMax) noQ-p◇a f (Pfa , Qfa) = noQ-p◇a g Qgpa
-- -- -- -- -- --        where
-- -- -- -- -- --          f≤p = pMax f Pfa
-- -- -- -- -- --          g = proj₁ f≤p
-- -- -- -- -- --          f≐g◇p = proj₂ f≤p
-- -- -- -- -- --          Qgpa : π₁ Q' (g ◇ (p ◇ a))
-- -- -- -- -- --          Qgpa = π₂ Q' (◃ext' f≐g◇p ∘ a)  Qfa

-- -- -- -- -- --   second : ∀ {m n o} (a : _ ⊸ n) (p : _ ⊸ o)(P Q : Property m) →
-- -- -- -- -- --              π₁ (Max (P [-◇ a ])) p → Nothing (Q [-◇ (p ◇ a)])
-- -- -- -- -- --              → Nothing ((P ∧ Q) [-◇ a ])
-- -- -- -- -- --   second a p P' Q' (Ppa , pMax) noQ-p◇a f (Pfa , Qfa) = noQ-p◇a g Qgpa
-- -- -- -- -- --        where
-- -- -- -- -- --          f≤p = pMax f Pfa
-- -- -- -- -- --          g = proj₁ f≤p
-- -- -- -- -- --          f≐g◇p = proj₂ f≤p
-- -- -- -- -- --          Qgpa : π₁ Q' (g ◇ (p ◇ a))
-- -- -- -- -- --          Qgpa = π₂ Q' (◃ext' f≐g◇p ∘ a)  Qfa

-- -- -- -- -- -- trivial-problem : ∀ {m n t} {f : m ⊸ n} → (Max⋆ ((Unifies⋆ t t) [-◇⋆ f ])) i
-- -- -- -- -- -- trivial-problem = refl , λ f' _ → f' , λ _ → refl

-- -- -- -- -- -- trivial-problemV : ∀ {m n N} {t : Vec (Term _) N} {f : m ⊸ n} → (Max⋆ ((Unifies⋆V t t) [-◇⋆ f ])) i
-- -- -- -- -- -- trivial-problemV = refl , λ f' _ → f' , λ _ → refl

-- -- -- -- -- -- open import Data.Sum

-- -- -- -- -- -- var-elim : ∀ {m} (x : Fin (suc m)) (t' : Term _)
-- -- -- -- -- --               → π₁ (Max ((Unifies (i x) ((▸ (thin x) ◃_) t')))) (t' for x)
-- -- -- -- -- -- var-elim x t' = first , \{_} → second
-- -- -- -- -- --   where
-- -- -- -- -- --     lemma : ∀{m}(x : Fin (suc m)) t → i ≐ ((t for x) ◇ (▸ (thin x)))
-- -- -- -- -- --     lemma x t x' = sym (cong (maybe i t) (Thick.half2 x _ x' refl))
-- -- -- -- -- --     first = begin
-- -- -- -- -- --              (t' for x) ◃ (i x) ≡⟨ cong (maybe i t') (Thick.half1 x) ⟩
-- -- -- -- -- --              t'                 ≡⟨ sym (Sub.fact1 t') ⟩
-- -- -- -- -- --              i ◃ t'             ≡⟨ ◃ext' (lemma x t') t' ⟩
-- -- -- -- -- --              (t' for x) ◃ ((▸ (thin x) ◃_) t') ∎

-- -- -- -- -- --     second : ∀ {n} (f : _ ⊸ n) → f x ≡ f ◃ ((▸ (thin x) ◃_) t') → f ≤ (t' for x)
-- -- -- -- -- --     second f Unifiesf = (f ∘ thin x) , third
-- -- -- -- -- --         where
-- -- -- -- -- --           third : ((x' : Fin _) →  f x' ≡ (f ∘ thin x) ◃ (maybe′ i t' (thick? x x')))
-- -- -- -- -- --           third x' with thick? x x' | Thick.fact1 x x' (thick? x x') refl
-- -- -- -- -- --           third .x | .nothing | inj₁ (refl , refl)  =
-- -- -- -- -- --                                        sym (begin
-- -- -- -- -- --                                            (f ∘ thin x) ◃ t'  ≡⟨ cong (λ g → (g ◃_) t') (sym (Sub.fact3 f (thin x))) ⟩
-- -- -- -- -- --                                            (f ◇ (▸ (thin x))) ◃ t' ≡⟨ Sub.fact2 {-f (▸ (thin x))-} t' ⟩
-- -- -- -- -- --                                            f ◃ ((▸ (thin x) ◃_) t') ≡⟨ sym Unifiesf ⟩
-- -- -- -- -- --                                            f x ∎)
-- -- -- -- -- --           third x' | .(just y) | inj₂ (y , ( thinxy≡x' , refl))  = sym (cong f thinxy≡x')

-- -- -- -- -- -- var-elim-i : ∀ {m} (x : Fin (suc m)) (t' : Term _)
-- -- -- -- -- --               → π₁ (Max ((Unifies (i x) ((▸ (thin x) ◃_) t')))) (i ◇ (t' for x))
-- -- -- -- -- -- var-elim-i {m} x t = prop-id {_} {_} {t for x} {Max (Unifies (i x) ((▸ (thin x) ◃_) t))} (var-elim {m} x t)

-- -- -- -- -- -- var-elim-i-≡ : ∀ {m} {t'} (x : Fin (suc m)) t1  → t1 ≡ (i ∘ thin x) ◃ t' → π₁ (Max (Unifies (i x) t1)) (i ◇ (t' for x))
-- -- -- -- -- -- var-elim-i-≡ {_} {t'} x .((i ∘ thin x) ◃ t') refl = var-elim-i x t'

-- -- -- -- -- -- ◇-assoc : ∀ {l m n o} (f : l ⊸ m) (g : n ⊸ _) (h : o ⊸ _) →
-- -- -- -- -- --                (f ◇ (g ◇ h)) ≐ ((f ◇ g) ◇ h)
-- -- -- -- -- -- ◇-assoc f g h x = sym (Sub.fact2 (h x))

-- -- -- -- -- -- bind-assoc : ∀ {l m n o} (f : l ⊸ m) (g : n ⊸ _) (h : o ⊸ _) t → (f ◇ g) ◃ (h ◃ t) ≡ (f ◇ (g ◇ h)) ◃ t
-- -- -- -- -- -- bind-assoc f g h t = sym (begin
-- -- -- -- -- --            (f ◇ (g ◇ h)) ◃ t  ≡⟨ ◃ext (◇-assoc f g h) t ⟩
-- -- -- -- -- --            ((f ◇ g) ◇ h) ◃ t  ≡⟨ Sub.fact2 ⦃ SubstitutionTerm ⦄ ⦃ Sub.Fact2Term ⦄ {f = (f ◇ g)} {g = h} {-(f ◇ g) h-} t ⟩
-- -- -- -- -- --            (f ◇ g) ◃ (h  ◃ t)
-- -- -- -- -- --                               ∎)


{-# OPTIONS --prop --type-in-type #-}

record × (A B : Prop) : Prop where
  field
    fst : A
    snd : B


{-
  Day 2 task of https://adventofcode.com/
-}
module a2 where

open import Agda.Builtin.IO using (IO)
open import Agda.Builtin.Unit using (⊤)
open import Agda.Builtin.String using (String; primShowNat; primStringAppend)
open import Agda.Builtin.Equality

open import Data.Nat
open import Data.Bool using (if_then_else_)
open import Data.List
open import Data.Maybe renaming (map to maybeMap)

postulate putStrLn : String → IO ⊤
{-# FOREIGN GHC import qualified Data.Text as T #-}
{-# COMPILE GHC putStrLn = putStrLn . T.unpack #-}

-- helper
shopMaybeNat : Maybe ℕ → String
shopMaybeNat (just n) = primShowNat n
shopMaybeNat nothing = "nothing"

data Command : Set where
  forward : ℕ → Command
  up      : ℕ → Command
  down    : ℕ → Command

record Position : Set where
  constructor pos
  field
    h : ℕ
    d : ℕ

open Position

apply : Command → Position → Maybe Position

apply (forward x) (pos h d) = just (pos (h + x) d)

apply (up x)      (pos h d) = if d <ᵇ x
                              then nothing
                              else just (pos h ∣ d - x ∣)

apply (down x)    (pos h d) = just (pos h (d + x))

iterate : List Command → Position → Maybe Position
iterate [] p = just p
iterate (command ∷ list) p with apply command p
...                           | just q  = iterate list q
...                           | nothing = nothing

doTask : List Command → Maybe ℕ
doTask list = let maybeResult = iterate list (pos 0 0)
              in maybeMap multiplyComponents maybeResult
  where multiplyComponents : Position → ℕ
        multiplyComponents (pos h d) = h * d

input : List Command
input =
  forward 2 ∷
  forward 3 ∷
  forward 5 ∷
  forward 6 ∷
  down 7 ∷
  forward 8 ∷
  forward 4 ∷
  forward 7 ∷
  forward 5 ∷
  forward 5 ∷
  down 4 ∷
  down 9 ∷
  forward 8 ∷
  forward 5 ∷
  up 5 ∷
  down 5 ∷
  forward 3 ∷
  down 4 ∷
  down 8 ∷
  forward 9 ∷
  down 1 ∷
  up 9 ∷
  down 7 ∷
  up 7 ∷
  up 1 ∷
  forward 1 ∷
  down 1 ∷
  down 4 ∷
  down 4 ∷
  down 8 ∷
  down 4 ∷
  up 3 ∷
  down 1 ∷
  down 3 ∷
  forward 7 ∷
  down 6 ∷
  forward 3 ∷
  forward 5 ∷
  forward 2 ∷
  up 9 ∷
  forward 7 ∷
  up 5 ∷
  down 3 ∷
  forward 1 ∷
  forward 2 ∷
  down 3 ∷
  down 8 ∷
  down 3 ∷
  forward 8 ∷
  up 5 ∷
  down 5 ∷
  forward 3 ∷
  down 5 ∷
  forward 9 ∷
  down 3 ∷
  down 4 ∷
  down 9 ∷
  down 7 ∷
  up 3 ∷
  down 9 ∷
  up 9 ∷
  up 1 ∷
  forward 3 ∷
  up 4 ∷
  down 3 ∷
  forward 7 ∷
  forward 7 ∷
  up 7 ∷
  forward 6 ∷
  down 7 ∷
  down 6 ∷
  forward 2 ∷
  forward 9 ∷
  down 5 ∷
  forward 4 ∷
  up 6 ∷
  down 1 ∷
  down 9 ∷
  down 9 ∷
  forward 4 ∷
  down 1 ∷
  forward 6 ∷
  down 1 ∷
  down 5 ∷
  down 4 ∷
  down 4 ∷
  forward 4 ∷
  forward 9 ∷
  up 1 ∷
  down 2 ∷
  down 8 ∷
  down 5 ∷
  down 8 ∷
  down 8 ∷
  up 2 ∷
  forward 8 ∷
  up 1 ∷
  forward 4 ∷
  down 5 ∷
  down 1 ∷
  up 2 ∷
  forward 6 ∷
  forward 9 ∷
  forward 2 ∷
  forward 6 ∷
  forward 9 ∷
  up 6 ∷
  forward 9 ∷
  up 4 ∷
  down 7 ∷
  up 6 ∷
  forward 2 ∷
  down 1 ∷
  up 3 ∷
  forward 1 ∷
  forward 8 ∷
  down 6 ∷
  down 8 ∷
  down 8 ∷
  forward 8 ∷
  forward 2 ∷
  forward 2 ∷
  down 2 ∷
  up 1 ∷
  down 9 ∷
  up 9 ∷
  down 9 ∷
  up 3 ∷
  forward 9 ∷
  up 4 ∷
  up 7 ∷
  up 6 ∷
  down 9 ∷
  forward 1 ∷
  down 3 ∷
  down 4 ∷
  forward 8 ∷
  down 3 ∷
  down 9 ∷
  up 3 ∷
  forward 2 ∷
  up 5 ∷
  down 3 ∷
  forward 8 ∷
  up 3 ∷
  down 3 ∷
  forward 2 ∷
  forward 9 ∷
  down 1 ∷
  down 9 ∷
  down 4 ∷
  up 7 ∷
  down 4 ∷
  up 6 ∷
  forward 5 ∷
  down 6 ∷
  forward 3 ∷
  down 2 ∷
  forward 1 ∷
  forward 8 ∷
  down 4 ∷
  forward 1 ∷
  up 7 ∷
  forward 6 ∷
  up 9 ∷
  forward 6 ∷
  down 3 ∷
  forward 2 ∷
  down 4 ∷
  forward 6 ∷
  down 3 ∷
  down 6 ∷
  down 1 ∷
  down 1 ∷
  down 5 ∷
  forward 3 ∷
  forward 9 ∷
  forward 8 ∷
  down 3 ∷
  forward 7 ∷
  up 9 ∷
  forward 9 ∷
  up 2 ∷
  forward 4 ∷
  up 3 ∷
  forward 1 ∷
  up 6 ∷
  up 8 ∷
  down 5 ∷
  down 6 ∷
  up 9 ∷
  down 6 ∷
  down 9 ∷
  up 9 ∷
  down 4 ∷
  forward 5 ∷
  up 2 ∷
  down 3 ∷
  up 3 ∷
  down 1 ∷
  forward 3 ∷
  down 5 ∷
  forward 7 ∷
  down 6 ∷
  down 7 ∷
  down 5 ∷
  forward 2 ∷
  up 6 ∷
  down 9 ∷
  down 4 ∷
  down 3 ∷
  forward 9 ∷
  up 8 ∷
  forward 2 ∷
  down 2 ∷
  forward 4 ∷
  up 6 ∷
  down 4 ∷
  up 8 ∷
  down 7 ∷
  down 2 ∷
  up 6 ∷
  up 4 ∷
  down 2 ∷
  forward 5 ∷
  up 4 ∷
  down 8 ∷
  forward 3 ∷
  forward 1 ∷
  down 7 ∷
  forward 8 ∷
  forward 7 ∷
  down 7 ∷
  up 4 ∷
  forward 8 ∷
  down 5 ∷
  up 9 ∷
  forward 1 ∷
  forward 4 ∷
  forward 9 ∷
  forward 7 ∷
  down 9 ∷
  up 9 ∷
  down 1 ∷
  down 7 ∷
  forward 7 ∷
  down 7 ∷
  down 7 ∷
  down 3 ∷
  down 5 ∷
  forward 3 ∷
  down 2 ∷
  forward 6 ∷
  down 9 ∷
  up 5 ∷
  up 3 ∷
  forward 5 ∷
  down 6 ∷
  down 1 ∷
  forward 4 ∷
  down 3 ∷
  forward 8 ∷
  down 7 ∷
  forward 7 ∷
  forward 7 ∷
  up 7 ∷
  up 2 ∷
  up 3 ∷
  forward 9 ∷
  down 5 ∷
  up 2 ∷
  forward 5 ∷
  up 5 ∷
  forward 2 ∷
  forward 2 ∷
  down 8 ∷
  forward 2 ∷
  up 4 ∷
  forward 1 ∷
  forward 3 ∷
  up 8 ∷
  up 9 ∷
  forward 5 ∷
  down 1 ∷
  up 8 ∷
  down 4 ∷
  down 8 ∷
  up 4 ∷
  forward 9 ∷
  down 6 ∷
  down 8 ∷
  up 2 ∷
  up 3 ∷
  down 7 ∷
  down 4 ∷
  forward 5 ∷
  down 6 ∷
  forward 3 ∷
  forward 3 ∷
  forward 8 ∷
  down 1 ∷
  down 7 ∷
  down 9 ∷
  down 2 ∷
  down 7 ∷
  forward 7 ∷
  down 7 ∷
  down 6 ∷
  up 6 ∷
  forward 8 ∷
  forward 5 ∷
  up 5 ∷
  down 2 ∷
  up 8 ∷
  up 4 ∷
  down 9 ∷
  up 2 ∷
  forward 5 ∷
  up 2 ∷
  down 4 ∷
  up 4 ∷
  forward 2 ∷
  forward 4 ∷
  forward 9 ∷
  forward 9 ∷
  up 4 ∷
  up 5 ∷
  down 1 ∷
  down 6 ∷
  down 1 ∷
  down 4 ∷
  down 5 ∷
  down 3 ∷
  forward 3 ∷
  down 9 ∷
  forward 6 ∷
  down 3 ∷
  down 9 ∷
  down 2 ∷
  up 2 ∷
  down 2 ∷
  down 7 ∷
  forward 9 ∷
  down 3 ∷
  down 3 ∷
  down 2 ∷
  down 3 ∷
  forward 2 ∷
  down 9 ∷
  down 9 ∷
  up 5 ∷
  up 3 ∷
  forward 4 ∷
  up 7 ∷
  forward 8 ∷
  up 6 ∷
  forward 7 ∷
  down 7 ∷
  down 1 ∷
  forward 5 ∷
  down 2 ∷
  up 1 ∷
  down 8 ∷
  up 3 ∷
  forward 2 ∷
  up 9 ∷
  down 1 ∷
  down 3 ∷
  down 6 ∷
  down 2 ∷
  down 7 ∷
  up 2 ∷
  forward 5 ∷
  forward 7 ∷
  down 2 ∷
  forward 5 ∷
  forward 4 ∷
  forward 5 ∷
  down 3 ∷
  forward 7 ∷
  down 7 ∷
  forward 8 ∷
  down 3 ∷
  down 2 ∷
  up 1 ∷
  forward 6 ∷
  down 4 ∷
  down 2 ∷
  forward 7 ∷
  up 3 ∷
  down 4 ∷
  forward 2 ∷
  up 6 ∷
  down 3 ∷
  up 6 ∷
  up 8 ∷
  down 9 ∷
  up 6 ∷
  forward 8 ∷
  forward 9 ∷
  forward 4 ∷
  forward 7 ∷
  down 2 ∷
  forward 9 ∷
  down 7 ∷
  up 9 ∷
  down 5 ∷
  down 6 ∷
  up 5 ∷
  down 4 ∷
  forward 8 ∷
  forward 4 ∷
  forward 4 ∷
  down 6 ∷
  forward 3 ∷
  forward 6 ∷
  down 9 ∷
  down 9 ∷
  up 2 ∷
  forward 7 ∷
  down 8 ∷
  down 9 ∷
  down 9 ∷
  forward 7 ∷
  forward 3 ∷
  down 7 ∷
  down 8 ∷
  forward 8 ∷
  down 6 ∷
  down 5 ∷
  down 9 ∷
  down 3 ∷
  forward 1 ∷
  down 5 ∷
  forward 2 ∷
  forward 8 ∷
  down 2 ∷
  forward 6 ∷
  forward 3 ∷
  down 7 ∷
  down 4 ∷
  forward 8 ∷
  forward 1 ∷
  down 6 ∷
  forward 9 ∷
  forward 6 ∷
  up 1 ∷
  up 3 ∷
  down 8 ∷
  forward 1 ∷
  up 5 ∷
  down 4 ∷
  forward 7 ∷
  up 3 ∷
  down 2 ∷
  forward 1 ∷
  forward 9 ∷
  down 9 ∷
  down 7 ∷
  forward 8 ∷
  down 4 ∷
  up 3 ∷
  down 4 ∷
  forward 2 ∷
  forward 6 ∷
  down 7 ∷
  forward 6 ∷
  down 6 ∷
  down 4 ∷
  down 1 ∷
  up 9 ∷
  down 4 ∷
  down 7 ∷
  up 4 ∷
  down 9 ∷
  forward 6 ∷
  down 3 ∷
  forward 2 ∷
  down 4 ∷
  forward 3 ∷
  down 5 ∷
  up 9 ∷
  forward 8 ∷
  up 7 ∷
  up 6 ∷
  up 4 ∷
  forward 1 ∷
  down 1 ∷
  forward 4 ∷
  up 6 ∷
  forward 5 ∷
  forward 4 ∷
  forward 5 ∷
  up 6 ∷
  down 1 ∷
  forward 3 ∷
  up 7 ∷
  down 9 ∷
  up 9 ∷
  down 5 ∷
  forward 6 ∷
  forward 4 ∷
  up 1 ∷
  down 4 ∷
  up 1 ∷
  forward 3 ∷
  forward 1 ∷
  down 3 ∷
  forward 7 ∷
  down 2 ∷
  forward 3 ∷
  up 2 ∷
  forward 8 ∷
  down 3 ∷
  up 9 ∷
  down 5 ∷
  forward 6 ∷
  down 1 ∷
  down 8 ∷
  down 5 ∷
  forward 1 ∷
  down 6 ∷
  up 2 ∷
  forward 6 ∷
  down 2 ∷
  down 1 ∷
  up 6 ∷
  up 7 ∷
  down 5 ∷
  forward 7 ∷
  forward 6 ∷
  forward 6 ∷
  down 7 ∷
  forward 4 ∷
  down 5 ∷
  up 5 ∷
  down 1 ∷
  up 8 ∷
  down 8 ∷
  down 2 ∷
  down 2 ∷
  down 9 ∷
  up 9 ∷
  forward 2 ∷
  forward 7 ∷
  down 7 ∷
  down 4 ∷
  down 4 ∷
  down 8 ∷
  forward 5 ∷
  forward 2 ∷
  up 9 ∷
  down 9 ∷
  forward 7 ∷
  up 9 ∷
  down 2 ∷
  down 7 ∷
  up 2 ∷
  up 8 ∷
  forward 8 ∷
  down 4 ∷
  forward 3 ∷
  forward 4 ∷
  forward 6 ∷
  forward 2 ∷
  down 1 ∷
  down 2 ∷
  forward 2 ∷
  up 1 ∷
  down 1 ∷
  forward 5 ∷
  up 3 ∷
  up 3 ∷
  down 3 ∷
  down 1 ∷
  down 4 ∷
  up 5 ∷
  up 6 ∷
  forward 5 ∷
  up 7 ∷
  forward 6 ∷
  down 4 ∷
  down 7 ∷
  up 8 ∷
  forward 1 ∷
  down 5 ∷
  up 4 ∷
  up 3 ∷
  up 5 ∷
  down 1 ∷
  up 5 ∷
  forward 3 ∷
  up 5 ∷
  forward 2 ∷
  forward 2 ∷
  forward 5 ∷
  forward 2 ∷
  up 9 ∷
  forward 4 ∷
  down 1 ∷
  down 3 ∷
  down 5 ∷
  up 2 ∷
  down 8 ∷
  forward 8 ∷
  forward 9 ∷
  down 1 ∷
  down 3 ∷
  forward 8 ∷
  forward 2 ∷
  down 2 ∷
  down 1 ∷
  up 7 ∷
  forward 2 ∷
  forward 8 ∷
  down 9 ∷
  forward 1 ∷
  forward 4 ∷
  down 7 ∷
  down 4 ∷
  up 7 ∷
  down 3 ∷
  down 1 ∷
  down 4 ∷
  up 7 ∷
  down 6 ∷
  forward 7 ∷
  down 8 ∷
  up 2 ∷
  up 4 ∷
  up 6 ∷
  down 9 ∷
  down 9 ∷
  down 8 ∷
  forward 6 ∷
  up 3 ∷
  up 1 ∷
  forward 9 ∷
  forward 6 ∷
  up 4 ∷
  up 2 ∷
  up 7 ∷
  forward 5 ∷
  up 9 ∷
  up 9 ∷
  forward 9 ∷
  up 6 ∷
  down 1 ∷
  down 3 ∷
  forward 3 ∷
  down 2 ∷
  down 2 ∷
  down 6 ∷
  down 9 ∷
  forward 3 ∷
  forward 7 ∷
  up 3 ∷
  forward 3 ∷
  down 5 ∷
  forward 9 ∷
  up 6 ∷
  down 2 ∷
  forward 8 ∷
  down 3 ∷
  up 5 ∷
  down 6 ∷
  forward 9 ∷
  down 5 ∷
  down 2 ∷
  down 6 ∷
  forward 8 ∷
  forward 6 ∷
  down 1 ∷
  forward 6 ∷
  up 1 ∷
  up 7 ∷
  down 4 ∷
  down 7 ∷
  forward 4 ∷
  forward 7 ∷
  down 4 ∷
  forward 8 ∷
  down 8 ∷
  down 7 ∷
  forward 9 ∷
  down 1 ∷
  down 3 ∷
  down 6 ∷
  forward 7 ∷
  forward 6 ∷
  forward 3 ∷
  forward 8 ∷
  down 5 ∷
  down 3 ∷
  up 1 ∷
  down 9 ∷
  down 8 ∷
  forward 3 ∷
  down 6 ∷
  down 1 ∷
  forward 5 ∷
  forward 5 ∷
  forward 9 ∷
  up 5 ∷
  down 6 ∷
  up 9 ∷
  down 7 ∷
  down 6 ∷
  up 1 ∷
  forward 5 ∷
  forward 7 ∷
  forward 8 ∷
  forward 7 ∷
  forward 6 ∷
  forward 3 ∷
  forward 1 ∷
  forward 2 ∷
  up 4 ∷
  forward 3 ∷
  forward 4 ∷
  forward 5 ∷
  up 2 ∷
  up 3 ∷
  forward 4 ∷
  down 9 ∷
  up 4 ∷
  forward 7 ∷
  down 6 ∷
  down 6 ∷
  down 1 ∷
  forward 2 ∷
  down 2 ∷
  forward 2 ∷
  down 3 ∷
  forward 7 ∷
  forward 8 ∷
  down 4 ∷
  up 7 ∷
  forward 7 ∷
  down 7 ∷
  forward 7 ∷
  forward 9 ∷
  down 7 ∷
  up 2 ∷
  down 3 ∷
  forward 7 ∷
  down 1 ∷
  forward 8 ∷
  forward 2 ∷
  up 9 ∷
  down 3 ∷
  forward 2 ∷
  up 4 ∷
  forward 9 ∷
  down 4 ∷
  down 4 ∷
  forward 4 ∷
  down 2 ∷
  down 9 ∷
  forward 4 ∷
  down 2 ∷
  down 6 ∷
  forward 9 ∷
  forward 2 ∷
  up 1 ∷
  forward 2 ∷
  forward 3 ∷
  down 5 ∷
  up 8 ∷
  down 4 ∷
  down 4 ∷
  forward 7 ∷
  down 2 ∷
  up 6 ∷
  down 9 ∷
  forward 9 ∷
  up 1 ∷
  forward 3 ∷
  down 5 ∷
  forward 3 ∷
  down 3 ∷
  forward 4 ∷
  up 3 ∷
  down 6 ∷
  down 7 ∷
  down 4 ∷
  down 8 ∷
  down 4 ∷
  down 5 ∷
  up 9 ∷
  up 1 ∷
  down 7 ∷
  up 3 ∷
  up 3 ∷
  down 3 ∷
  up 4 ∷
  up 6 ∷
  forward 8 ∷
  down 1 ∷
  forward 7 ∷
  forward 4 ∷
  down 9 ∷
  down 1 ∷
  forward 7 ∷
  forward 9 ∷
  forward 1 ∷
  down 3 ∷
  down 2 ∷
  forward 3 ∷
  forward 2 ∷
  down 7 ∷
  forward 9 ∷
  forward 6 ∷
  up 9 ∷
  down 2 ∷
  forward 9 ∷
  up 6 ∷
  forward 8 ∷
  up 1 ∷
  down 5 ∷
  down 8 ∷
  forward 1 ∷
  down 1 ∷
  forward 9 ∷
  up 1 ∷
  forward 9 ∷
  forward 1 ∷
  forward 1 ∷
  down 7 ∷
  forward 3 ∷
  forward 6 ∷
  down 5 ∷
  forward 7 ∷
  forward 1 ∷
  down 7 ∷
  down 6 ∷
  down 6 ∷
  forward 5 ∷
  up 6 ∷
  down 6 ∷
  forward 8 ∷
  up 2 ∷
  down 8 ∷
  down 3 ∷
  up 5 ∷
  up 8 ∷
  down 6 ∷
  forward 4 ∷
  forward 2 ∷
  up 3 ∷
  forward 5 ∷
  forward 3 ∷
  up 8 ∷
  forward 6 ∷
  up 8 ∷
  forward 1 ∷
  up 8 ∷
  up 7 ∷
  up 6 ∷
  forward 2 ∷
  down 9 ∷
  down 9 ∷
  forward 3 ∷
  down 7 ∷
  forward 3 ∷
  down 6 ∷
  forward 9 ∷
  up 5 ∷
  down 1 ∷
  forward 7 ∷
  down 1 ∷
  down 5 ∷
  down 9 ∷
  forward 8 ∷
  forward 9 ∷
  forward 7 ∷
  down 9 ∷
  up 4 ∷
  forward 5 ∷
  down 5 ∷
  forward 5 ∷
  down 9 ∷
  forward 9 ∷
  forward 3 ∷
  up 5 ∷
  forward 8 ∷
  up 5 ∷
  down 1 ∷
  forward 8 ∷
  down 3 ∷
  forward 6 ∷
  up 9 ∷
  forward 8 ∷
  down 4 ∷
  forward 3 ∷
  down 5 ∷
  forward 8 ∷
  forward 9 ∷
  forward 2 ∷
  down 1 ∷
  down 6 ∷
  down 4 ∷
  forward 9 ∷
  up 2 ∷
  down 3 ∷
  down 6 ∷
  down 3 ∷
  down 9 ∷
  down 1 ∷
  up 6 ∷
  down 2 ∷
  down 7 ∷
  up 5 ∷
  forward 5 ∷
  up 1 ∷
  down 7 ∷
  forward 6 ∷
  up 6 ∷
  down 2 ∷
  down 3 ∷
  forward 3 ∷
  down 5 ∷
  forward 8 ∷
  down 9 ∷
  down 7 ∷
  down 8 ∷
  up 7 ∷
  down 1 ∷
  forward 1 ∷
  forward 1 ∷
  down 2 ∷
  up 4 ∷
  forward 2 ∷
  down 3 ∷
  up 2 ∷
  down 3 ∷
  down 2 ∷
  forward 7 ∷
  down 1 ∷
  up 7 ∷
  down 2 ∷
  down 1 ∷
  forward 6 ∷
  down 9 ∷
  up 9 ∷
  down 4 ∷
  down 6 ∷
  up 9 ∷
  forward 7 ∷
  forward 9 ∷
  forward 7 ∷
  down 4 ∷
  down 1 ∷
  forward 7 ∷
  down 4 ∷
  down 7 ∷
  down 3 ∷
  down 5 ∷
  forward 3 ∷
  down 8 ∷
  forward 8 ∷
  forward 7 ∷
  forward 8 ∷
  down 4 ∷
  down 9 ∷
  forward 2 ∷
  forward 7 ∷
  up 8 ∷
  forward 4 ∷
  down 6 ∷
  up 8 ∷
  down 2 ∷
  forward 3 ∷
  down 6 ∷
  down 8 ∷
  forward 8 ∷
  forward 2 ∷
  forward 9 ∷
  up 6 ∷
  forward 7 ∷
  down 3 ∷
  down 5 ∷
  forward 8 ∷
  forward 9 ∷
  down 3 ∷
  forward 3 ∷
  forward 2 ∷
  forward 3 ∷
  down 8 ∷
  up 9 ∷
  up 5 ∷
  up 2 ∷
  up 6 ∷
  up 1 ∷
  up 1 ∷
  up 5 ∷
  forward 3 ∷
  forward 2 ∷
  down 3 ∷
  forward 4 ∷
  []

main : IO ⊤
main = putStrLn (shopMaybeNat (doTask input))

private
  -- checks from the exercise text
  _ : apply (forward 5) (pos 0 0) ≡ just (pos 5 0)
  _ = refl

  _ : apply (down 5) (pos 5 0) ≡ just (pos 5 5)
  _ = refl

  _ : apply (forward 8) (pos 5 5) ≡ just (pos 13 5)
  _ = refl

  _ : apply (up 3) (pos 13 5) ≡ just (pos 13 2)
  _ = refl

  _ : apply (down 8) (pos 13 2) ≡ just (pos 13 10)
  _ = refl

  _ : apply (forward 2) (pos 13 10) ≡ just (pos 15 10)
  _ = refl

  -- submarine does not 'fly'
  _ : apply (up 7) (pos 13 2) ≡ nothing
  _ = refl


open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Agda.Builtin.Nat
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Data.Fin

open import Relation.Binary

module SingleSorted.AlgebraicTheory where

  open import SingleSorted.Context public

  Arity : Set
  Arity = Context

  arg : Arity → Set
  arg = var

  -- an algebraic signature
  record Signature : Set₁ where
    field
      oper : Set -- operations
      oper-arity : oper → Arity -- the arity of an operation

    -- terms over a signature in a context of a given sort
    data Term (Γ : Context) : Set where
      tm-var : var Γ → Term Γ
      tm-oper : ∀ (f : oper) → (arg (oper-arity f) → Term Γ) → Term Γ

    -- Substitutions (definitions - some useful properties are in another file)
    _⇒s_ : ∀ (Γ Δ : Context) → Set
    Γ ⇒s Δ = var Δ → Term Γ

    infix  4 _⇒s_

    -- identity substitution
    id-s : ∀ {Γ : Context} → Γ ⇒s Γ
    id-s = tm-var

    -- the action of a substitution on a term (contravariant)
    _[_]s : ∀ {Γ Δ : Context} → Term Δ → Γ ⇒s Δ → Term Γ
    (tm-var x) [ σ ]s = σ x
    (tm-oper f x) [ σ ]s = tm-oper f (λ i → x i [ σ ]s)

    infixr 6 _[_]s

    -- composition of substitutions
    _∘s_ : ∀ {Γ Δ Θ : Context} → Δ ⇒s Θ → Γ ⇒s Δ → Γ ⇒s Θ
    (σ ∘s ρ) x = σ x [ ρ ]s

    infixl 7 _∘s_

    -- Axioms are equations in context
    record Equation  : Set where
      field
        eq-ctx : Context
        eq-lhs : Term eq-ctx
        eq-rhs : Term eq-ctx

  -- Theory
  -- an equational theory is a family of equations over a given sort
  record Theory ℓ (Σ : Signature) : Set (lsuc ℓ) where
    open Signature Σ public

    field
      ax : Set ℓ -- the axiom names
      ax-eq : ax → Equation -- the axioms

    ax-ctx : ax → Context
    ax-ctx ε = Equation.eq-ctx (ax-eq ε)

    ax-lhs : ∀ (ε : ax) → Term (ax-ctx ε)
    ax-lhs ε = Equation.eq-lhs (ax-eq ε)

    ax-rhs : ∀ (ε : ax) → Term (ax-ctx ε)
    ax-rhs ε = Equation.eq-rhs (ax-eq ε)

    infix 4 _⊢_≈_

    -- equality of terms
    data _⊢_≈_ : (Γ : Context) → Term Γ → Term Γ → Set (lsuc ℓ) where
      -- general rules
      eq-refl : ∀ {Γ} {t : Term Γ} → Γ ⊢ t ≈ t
      eq-symm : ∀ {Γ} {s t : Term Γ} → Γ ⊢ s ≈ t → Γ ⊢ t ≈ s
      eq-tran : ∀ {Γ} {s t u : Term Γ} → Γ ⊢ s ≈ t → Γ ⊢ t ≈ u → Γ ⊢ s ≈ u
      -- congruence rule
      eq-congr : ∀ {Γ} {f : oper} {xs ys : arg (oper-arity f) → Term Γ} →
                 (∀ i → Γ ⊢ xs i ≈ ys i) → Γ ⊢ tm-oper f xs ≈ tm-oper f ys
      -- equational axiom
      eq-axiom : ∀ (ε : ax) {Γ : Context} (σ : Γ ⇒s (ax-ctx ε)) →
                 Γ ⊢ ax-lhs ε [ σ ]s ≈ ax-rhs ε [ σ ]s

    ≡-⊢-≈ : {Γ : Context} {s t : Term Γ} → s ≡ t → Γ ⊢ s ≈ t
    ≡-⊢-≈ refl = eq-refl

    -- the action of the identity substitution is the identity
    id-action : ∀ {Γ : Context} {a : Term Γ} → (Γ ⊢ a ≈ (a [ id-s ]s))
    id-action {a = tm-var a} = eq-refl
    id-action {a = tm-oper f x} = eq-congr (λ i → id-action {a = x i})

    eq-axiom-id : ∀ (ε : ax) → ax-ctx ε ⊢ ax-lhs ε ≈ ax-rhs ε
    eq-axiom-id ε = eq-tran id-action (eq-tran (eq-axiom ε id-s) (eq-symm id-action))

    eq-setoid : ∀ (Γ : Context) → Setoid lzero (lsuc ℓ)
    eq-setoid Γ =
      record
        { Carrier = Term Γ
        ;  _≈_ = λ s t → (Γ ⊢ s ≈ t)
        ; isEquivalence =
            record
              { refl = eq-refl
              ; sym = eq-symm
              ; trans = eq-tran
           }
        }


{-

This files contains:
- Lots of useful properties about (this) decidable predicates on finite sets.
  (P.S. We use the alternative definition of decidability for computational effectivity.)

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

module Cubical.Data.FinSet.DecidablePredicate where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv renaming (_∙ₑ_ to _⋆_)
open import Cubical.Foundations.Equiv.Properties

open import Cubical.HITs.PropositionalTruncation as Prop

open import Cubical.Data.Bool
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Sigma

open import Cubical.Data.Fin
open import Cubical.Data.SumFin renaming (Fin to SumFin)
open import Cubical.Data.FinSet.Base
open import Cubical.Data.FinSet.Properties

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidablePropositions
  hiding (DecProp) renaming (DecProp' to DecProp)

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level

module _
  (X : Type ℓ)(p : isFinOrd X) where

  isDecProp¬' : isDecProp (¬ X)
  isDecProp¬' = _ ,  invEquiv (preCompEquiv (p .snd)) ⋆ SumFin¬ _

  isDecProp∥∥' : isDecProp ∥ X ∥
  isDecProp∥∥' = _ , propTrunc≃ (p .snd) ⋆ SumFin∥∥DecProp _

module _
  (X : Type ℓ )(p : isFinOrd X)
  (P : X → Type ℓ')
  (dec : (x : X) → isDecProp (P x)) where

  private
    e = p .snd

  isFinOrdSub : isFinOrd (Σ X P)
  isFinOrdSub = _ ,
      Σ-cong-equiv {B' = λ x → P (invEq e x)} e (transpFamily p)
    ⋆ Σ-cong-equiv-snd (λ x → dec (invEq e x) .snd)
    ⋆ SumFinSub≃ _ (fst ∘ dec ∘ invEq e)

  isDecProp∃' : isDecProp ∥ Σ X P ∥
  isDecProp∃' = _ ,
      Prop.propTrunc≃ (
        Σ-cong-equiv {B' = λ x → P (invEq e x)} e (transpFamily p)
      ⋆ Σ-cong-equiv-snd (λ x → dec (invEq e x) .snd))
    ⋆ SumFin∃≃ _ (fst ∘ dec ∘ invEq e)

  isDecProp∀' : isDecProp ((x : X) → P x)
  isDecProp∀' = _ ,
      equivΠ {B' = λ x → P (invEq e x)} e (transpFamily p)
    ⋆ equivΠCod (λ x → dec (invEq e x) .snd)
    ⋆ SumFin∀≃ _ (fst ∘ dec ∘ invEq e)

module _
  (X : Type ℓ )(p : isFinOrd X)
  (a b : X) where

  private
    e = p .snd

  isDecProp≡' : isDecProp (a ≡ b)
  isDecProp≡' .fst = SumFin≡ _ (e .fst a) (e .fst b)
  isDecProp≡' .snd = congEquiv e ⋆ SumFin≡≃ _ _ _

module _
  (X : FinSet ℓ)
  (P : X .fst → DecProp ℓ') where

  isFinSetSub : isFinSet (Σ (X .fst) (λ x → P x .fst))
  isFinSetSub = Prop.rec isPropIsFinSet
    (λ p → isFinOrd→isFinSet (isFinOrdSub (X .fst) (_ , p) (λ x → P x .fst) (λ x → P x .snd)))
    (X .snd .snd)

  isDecProp∃ : isDecProp ∥ Σ (X .fst) (λ x → P x .fst) ∥
  isDecProp∃ = Prop.rec isPropIsDecProp
    (λ p → isDecProp∃' (X .fst) (_ , p) (λ x → P x .fst) (λ x → P x .snd)) (X .snd .snd)

  isDecProp∀ : isDecProp ((x : X .fst) → P x .fst)
  isDecProp∀ = Prop.rec isPropIsDecProp
    (λ p → isDecProp∀' (X .fst) (_ , p) (λ x → P x .fst) (λ x → P x .snd)) (X .snd .snd)

module _
  (X : FinSet ℓ)
  (Y : X .fst → FinSet ℓ')
  (Z : (x : X .fst) → Y x .fst → DecProp ℓ'') where

  isDecProp∀2 : isDecProp ((x : X .fst) → (y : Y x .fst) → Z x y .fst)
  isDecProp∀2 = isDecProp∀ X (λ x → _ , isDecProp∀ (Y x) (Z x))

module _
  (X : FinSet ℓ)
  (Y : X .fst → FinSet ℓ')
  (Z : (x : X .fst) → Y x .fst → FinSet ℓ'')
  (W : (x : X .fst) → (y : Y x .fst) → Z x y .fst → DecProp ℓ''') where

  isDecProp∀3 : isDecProp ((x : X .fst) → (y : Y x .fst) → (z : Z x y .fst) → W x y z .fst)
  isDecProp∀3 = isDecProp∀ X (λ x → _ , isDecProp∀2 (Y x) (Z x) (W x))

module _
  (X : FinSet ℓ) where

  isDecProp≡ : (a b : X .fst) → isDecProp (a ≡ b)
  isDecProp≡ a b = Prop.rec isPropIsDecProp
    (λ p → isDecProp≡' (X .fst) (_ , p) a b) (X .snd .snd)

module _
  (P : DecProp ℓ )
  (Q : DecProp ℓ') where

  isDecProp× : isDecProp (P .fst × Q .fst)
  isDecProp× .fst = P .snd .fst and Q .snd .fst
  isDecProp× .snd = Σ-cong-equiv (P .snd .snd) (λ _ → Q .snd .snd) ⋆ Bool→Type×≃ _ _

module _
  (X : FinSet ℓ) where

  isDecProp¬ : isDecProp (¬ (X .fst))
  isDecProp¬ = Prop.rec isPropIsDecProp
    (λ p → isDecProp¬' (X .fst) (_ , p)) (X .snd .snd)

  isDecProp∥∥ : isDecProp ∥ X .fst ∥
  isDecProp∥∥ = Prop.rec isPropIsDecProp
    (λ p → isDecProp∥∥' (X .fst) (_ , p)) (X .snd .snd)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Unit where

open import Cubical.Data.Unit.Base       public
open import Cubical.Data.Unit.Properties public


module Numeral.Finite.Category where

open import Functional
import      Lvl
open import Numeral.Finite
open import Numeral.Natural
open import Type
open import Syntax.Function

-- Equality category on the type of finite natural numbers.
module _ where
  open import Relator.Equals
  open import Relator.Equals.Proofs.Equiv
  open import Relator.Equals.Category
  open import Structure.Category
  open import Structure.Category.Categories
  import      Structure.Category.Functor as Category
  open import Structure.Function
  open import Structure.Function.Domain
  import      Structure.Function.Names as Names
  open import Structure.Groupoid
  open import Structure.Groupoid.Groupoids
  import      Structure.Groupoid.Functor as Groupoid

  𝕟-identityTypeGroupoid : Groupoid((_≡_) on₂ 𝕟)
  𝕟-identityTypeGroupoid = on₂-groupoid identityTypeGroupoid 𝕟

  -- The type constructor `𝕟` is a functor.
  -- This means:
  -- • `map: ∀(a: ℕ)(b: ℕ). (a ≡ b) → (𝕟(a) ≡ 𝕟(b))`
  -- • `map(reflexivity(_≡_)) ≡ reflexivity(_≡_)`
  -- • `transitivity(_≡_) (map p) (map q) ≡ map(transitivity(_≡_) p q)`
  𝕟-functor : Groupoid.Functor(identityTypeGroupoid{T = ℕ})(𝕟-identityTypeGroupoid) id
  𝕟-functor = idTransportFunctor

  instance
    𝕟-injectivity : Injective(𝕟)
    𝕟-injectivity = intro proof where
      proof : Names.Injective(𝕟)
      proof {𝟎}   {𝟎}    [≡]-intro = [≡]-intro
      proof {𝐒 a} {𝐒 .a} [≡]-intro = [≡]-with(𝐒) (proof [≡]-intro)

  𝕟-inverse-functor : Groupoid.Functor(𝕟-identityTypeGroupoid)(identityTypeGroupoid{T = ℕ}) id
  Groupoid.Functor.map 𝕟-inverse-functor = injective(𝕟)
  Function.congruence (Groupoid.Functor.map-function 𝕟-inverse-functor) [≡]-intro = [≡]-intro
  Groupoid.Functor.op-preserving 𝕟-inverse-functor {x} {x} {x} {[≡]-intro} {[≡]-intro} = proof{x} where
    proof : ∀{x} → Groupoid.Functor.map 𝕟-inverse-functor (Groupoid._∘_ 𝕟-identityTypeGroupoid {x} [≡]-intro [≡]-intro) ≡ Groupoid._∘_ identityTypeGroupoid (Groupoid.Functor.map 𝕟-inverse-functor [≡]-intro) (Groupoid.Functor.map 𝕟-inverse-functor [≡]-intro)
    proof {𝟎} = [≡]-intro
    proof {𝐒 x}
      rewrite proof{x}
      rewrite Groupoid.Functor.id-preserving 𝕟-inverse-functor {x}
      = [≡]-intro
  Groupoid.Functor.id-preserving 𝕟-inverse-functor {x} = proof{x} where
    proof : ∀{x} → (injective(𝕟) (Groupoid.id 𝕟-identityTypeGroupoid {x}) ≡ Category.id identityTypeCategory)
    proof {𝟎} = [≡]-intro
    proof {𝐒 x} rewrite proof{x} = [≡]-intro
  Groupoid.Functor.inv-preserving 𝕟-inverse-functor {x} {x} {[≡]-intro} = proof where
    proof : ∀{x} → Groupoid.Functor.map 𝕟-inverse-functor (Groupoid.inv 𝕟-identityTypeGroupoid {x} [≡]-intro) ≡ Groupoid.inv identityTypeGroupoid (Groupoid.Functor.map 𝕟-inverse-functor [≡]-intro)
    proof {𝟎} = [≡]-intro
    proof {𝐒 x}
      rewrite proof{x}
      rewrite Groupoid.Functor.id-preserving 𝕟-inverse-functor {x}
      = [≡]-intro

  open import Function.Equals
  open import Numeral.Finite.Bound
  open import Numeral.Natural.Relation.Order.Category
  open import Numeral.Natural.Relation.Order.Proofs
  open import Numeral.Natural.Relation.Order
  open import Type.Category.ExtensionalFunctionsCategory
  open import Structure.Relator.Properties

  -- A functor for boundary changing of finite numeral types (𝕟).
  bound-functor : Category.Functor [≤]-category (on₂-category typeExtensionalFnCategory 𝕟) id
  Category.Functor.map bound-functor = bound-[≤]
  Function.congruence (Category.Functor.map-function bound-functor) [≡]-intro = reflexivity(_⊜_)
  Category.Functor.op-preserving bound-functor {x}{y}{z} {p}{q} = proof{x}{y}{z} {p}{q} where
    proof : ∀{x y z}{p : (y ≤ z)}{q : (x ≤ y)} → (bound-[≤] (transitivity(_≤_) q p) ⊜ (bound-[≤] p) ∘ (bound-[≤] q))
    _⊜_.proof (proof {𝐒 x} {𝐒 y} {𝐒 z} {succ _} {succ _}) {𝟎}   = [≡]-intro
    _⊜_.proof (proof {𝐒 x} {𝐒 y} {𝐒 z} {succ _} {succ _}) {𝐒 n} = congruence₁(𝐒) (_⊜_.proof (proof {x} {y} {z}) {n})
  Category.Functor.id-preserving bound-functor {n} = proof{n} where
    proof : ∀{n} → (bound-[≤] (reflexivity(_≤_) {n}) ⊜ id)
    _⊜_.proof (proof {𝟎})   {()}
    _⊜_.proof (proof {𝐒 n}) {𝟎}   = [≡]-intro
    _⊜_.proof (proof {𝐒 n}) {𝐒 x} = congruence₁(𝐒) (_⊜_.proof (proof {n}) {x})


module Oscar.AgdaPatternSyntaxTrick where

record ⊤ : Set where
  constructor tt

data List (A : Set) : Set where
  ∅ : List A
  _∷_ : A → List A → List A

Nat = List ⊤
pattern ‼ xs = tt ∷ xs
syntax ‼ xs = ! xs

data Fin : Nat → Set where
  ∅ : ∀ {n} → Fin (! n)
  ! : ∀ {n} → Fin n → Fin (! n)

test : Fin (! (! ∅)) -- OOPS
test = ! ∅

-- record ⊤ : Set where
--   constructor tt

-- data List (A : Set) : Set where
--   ∅ : List A
--   _∷_ : A → List A → List A

-- Nat = List ⊤
-- pattern ‼ xs = tt ∷ xs

-- data Fin : Nat → Set where
--   ∅ : ∀ {n} → Fin (‼ n) -- BOO!
--   ! : ∀ {n} → Fin n → Fin (‼ n)


-- AIM XXXV, 2022-05-06, issue #5891:
-- SizeUniv : SizeUniv was causing non-termination and inhabitation of Size< 0.
-- This is inconsistent; proof by Jonathan Chan.

{-# OPTIONS --sized-types #-}

open import Agda.Primitive
open import Agda.Builtin.Size

data ⊥ : Set where

-- Original exploit:
-- data False : SizeUniv where

False : SizeUniv
False = (X : SizeUniv) → X

-- Should fail.

-- Expected error:
-- Setω != SizeUniv
-- when checking that the expression (X : SizeUniv) → X has type SizeUniv

-- Step 1: Hurken's Paradox with SizeUniv : SizeUniv.

℘ : SizeUniv → SizeUniv
℘ S = S → SizeUniv

U : SizeUniv
U = ∀ (X : SizeUniv) → (℘ (℘ X) → X) → ℘ (℘ X)

τ : ℘ (℘ U) → U
τ t = λ X f p → t (λ x → p (f (x X f)))

σ : U → ℘ (℘ U)
σ s = s U τ

Δ : ℘ U
Δ y = (∀ p → σ y p → p (τ (σ y))) → False

Ω : U
Ω = τ (λ p → (∀ x → σ x p → p x))

R : ∀ p → (∀ x → σ x p → p x) → p Ω
R _ 𝟙 = 𝟙 Ω (λ x → 𝟙 (τ (σ x)))

M : ∀ x → σ x Δ → Δ x
M _ 𝟚 𝟛 = 𝟛 Δ 𝟚 (λ p → 𝟛 (λ y → p (τ (σ y))))

L : (∀ p → (∀ x → σ x p → p x) → p Ω) → False
L 𝟘 = 𝟘 Δ M (λ p → 𝟘 (λ y → p (τ (σ y))))

-- Prevent unfolding, as this term has no whnf.
-- Stops Agda from looping.

abstract
  false : False
  false = L R

-- This gives us a predecessor on Size.

size-pred : ∀ i → Size< i
size-pred i = false (Size< i)

-- Step 2: Size predecessor is inconsistent.

-- Jonathan Chan:
-- I managed to do so using ∞ but only because it's the only closed
-- size expression, not using the ∞ < ∞ property, although the
-- principle is the same as for #3026:

data _>_ (s : Size) : Size → Set where
  lt : (r : Size< s) → s > r

data Acc (s : Size) : Set where
  acc : (∀ {r} → s > r → Acc r) → Acc s

wf : ∀ s → Acc s
wf s = acc λ{ (lt r) → wf r }

¬wf : ∀ s → Acc s → ⊥
¬wf s (acc p) = ¬wf (size-pred s) (p (lt (size-pred s)))

absurd : ⊥
absurd = (¬wf ∞) (wf ∞)


module Issue256 where

open import Common.Level

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x = λ _ → x

level : ∀ {ℓ} → Set ℓ → Level
level {ℓ} _ = ℓ

-- termination check should fail for the following definition
ℓ : Level
ℓ = const lzero (Set ℓ)

-- A : Set (lsuc {!ℓ!})
-- A = Set (level A)


{-
  Day 2, 2nd part
-}
module a2b where

open import Agda.Builtin.IO using (IO)
open import Agda.Builtin.Unit using (⊤)
open import Agda.Builtin.String using (String; primShowNat; primStringAppend)
open import Agda.Builtin.Equality

open import Data.Nat
open import Data.Bool using (if_then_else_)
open import Data.List
open import Data.Maybe renaming (map to maybeMap)

postulate putStrLn : String → IO ⊤
{-# FOREIGN GHC import qualified Data.Text as T #-}
{-# COMPILE GHC putStrLn = putStrLn . T.unpack #-}

-- helper
shopMaybeNat : Maybe ℕ → String
shopMaybeNat (just n) = primShowNat n
shopMaybeNat nothing = "nothing"

data Command : Set where
  forward : ℕ → Command
  up      : ℕ → Command
  down    : ℕ → Command

record Position : Set where
  constructor pos
  field
    h : ℕ
    d : ℕ

{- Alignment of the submarine, i.e. position and aim -}
record Alignment : Set where
  constructor state
  field
    h : ℕ
    d : ℕ
    aim : ℕ

open Position

apply : Command → Alignment → Maybe Alignment

apply (forward x) (state h d aim) = just (state (h + x) (d + (x * aim)) aim)

apply (up x)      (state h d aim) = if aim <ᵇ x
                                    then nothing
                                    else just (state h d ∣ aim - x ∣)

apply (down x) (state h d aim) = just (state h d (aim + x))

iterate : List Command → Alignment → Maybe Alignment
iterate [] a = just a
iterate (command ∷ list) a with apply command a
...                           | just a'  = iterate list a'
...                           | nothing = nothing

doTask : List Command → Maybe ℕ
doTask list = let maybeResult = iterate list (state 0 0 0)
              in maybeMap multiplyComponents maybeResult
  where multiplyComponents : Alignment → ℕ
        multiplyComponents (state h d aim) = h * d

input : List Command
input =
  forward 2 ∷
  forward 3 ∷
  forward 5 ∷
  forward 6 ∷
  down 7 ∷
  forward 8 ∷
  forward 4 ∷
  forward 7 ∷
  forward 5 ∷
  forward 5 ∷
  down 4 ∷
  down 9 ∷
  forward 8 ∷
  forward 5 ∷
  up 5 ∷
  down 5 ∷
  forward 3 ∷
  down 4 ∷
  down 8 ∷
  forward 9 ∷
  down 1 ∷
  up 9 ∷
  down 7 ∷
  up 7 ∷
  up 1 ∷
  forward 1 ∷
  down 1 ∷
  down 4 ∷
  down 4 ∷
  down 8 ∷
  down 4 ∷
  up 3 ∷
  down 1 ∷
  down 3 ∷
  forward 7 ∷
  down 6 ∷
  forward 3 ∷
  forward 5 ∷
  forward 2 ∷
  up 9 ∷
  forward 7 ∷
  up 5 ∷
  down 3 ∷
  forward 1 ∷
  forward 2 ∷
  down 3 ∷
  down 8 ∷
  down 3 ∷
  forward 8 ∷
  up 5 ∷
  down 5 ∷
  forward 3 ∷
  down 5 ∷
  forward 9 ∷
  down 3 ∷
  down 4 ∷
  down 9 ∷
  down 7 ∷
  up 3 ∷
  down 9 ∷
  up 9 ∷
  up 1 ∷
  forward 3 ∷
  up 4 ∷
  down 3 ∷
  forward 7 ∷
  forward 7 ∷
  up 7 ∷
  forward 6 ∷
  down 7 ∷
  down 6 ∷
  forward 2 ∷
  forward 9 ∷
  down 5 ∷
  forward 4 ∷
  up 6 ∷
  down 1 ∷
  down 9 ∷
  down 9 ∷
  forward 4 ∷
  down 1 ∷
  forward 6 ∷
  down 1 ∷
  down 5 ∷
  down 4 ∷
  down 4 ∷
  forward 4 ∷
  forward 9 ∷
  up 1 ∷
  down 2 ∷
  down 8 ∷
  down 5 ∷
  down 8 ∷
  down 8 ∷
  up 2 ∷
  forward 8 ∷
  up 1 ∷
  forward 4 ∷
  down 5 ∷
  down 1 ∷
  up 2 ∷
  forward 6 ∷
  forward 9 ∷
  forward 2 ∷
  forward 6 ∷
  forward 9 ∷
  up 6 ∷
  forward 9 ∷
  up 4 ∷
  down 7 ∷
  up 6 ∷
  forward 2 ∷
  down 1 ∷
  up 3 ∷
  forward 1 ∷
  forward 8 ∷
  down 6 ∷
  down 8 ∷
  down 8 ∷
  forward 8 ∷
  forward 2 ∷
  forward 2 ∷
  down 2 ∷
  up 1 ∷
  down 9 ∷
  up 9 ∷
  down 9 ∷
  up 3 ∷
  forward 9 ∷
  up 4 ∷
  up 7 ∷
  up 6 ∷
  down 9 ∷
  forward 1 ∷
  down 3 ∷
  down 4 ∷
  forward 8 ∷
  down 3 ∷
  down 9 ∷
  up 3 ∷
  forward 2 ∷
  up 5 ∷
  down 3 ∷
  forward 8 ∷
  up 3 ∷
  down 3 ∷
  forward 2 ∷
  forward 9 ∷
  down 1 ∷
  down 9 ∷
  down 4 ∷
  up 7 ∷
  down 4 ∷
  up 6 ∷
  forward 5 ∷
  down 6 ∷
  forward 3 ∷
  down 2 ∷
  forward 1 ∷
  forward 8 ∷
  down 4 ∷
  forward 1 ∷
  up 7 ∷
  forward 6 ∷
  up 9 ∷
  forward 6 ∷
  down 3 ∷
  forward 2 ∷
  down 4 ∷
  forward 6 ∷
  down 3 ∷
  down 6 ∷
  down 1 ∷
  down 1 ∷
  down 5 ∷
  forward 3 ∷
  forward 9 ∷
  forward 8 ∷
  down 3 ∷
  forward 7 ∷
  up 9 ∷
  forward 9 ∷
  up 2 ∷
  forward 4 ∷
  up 3 ∷
  forward 1 ∷
  up 6 ∷
  up 8 ∷
  down 5 ∷
  down 6 ∷
  up 9 ∷
  down 6 ∷
  down 9 ∷
  up 9 ∷
  down 4 ∷
  forward 5 ∷
  up 2 ∷
  down 3 ∷
  up 3 ∷
  down 1 ∷
  forward 3 ∷
  down 5 ∷
  forward 7 ∷
  down 6 ∷
  down 7 ∷
  down 5 ∷
  forward 2 ∷
  up 6 ∷
  down 9 ∷
  down 4 ∷
  down 3 ∷
  forward 9 ∷
  up 8 ∷
  forward 2 ∷
  down 2 ∷
  forward 4 ∷
  up 6 ∷
  down 4 ∷
  up 8 ∷
  down 7 ∷
  down 2 ∷
  up 6 ∷
  up 4 ∷
  down 2 ∷
  forward 5 ∷
  up 4 ∷
  down 8 ∷
  forward 3 ∷
  forward 1 ∷
  down 7 ∷
  forward 8 ∷
  forward 7 ∷
  down 7 ∷
  up 4 ∷
  forward 8 ∷
  down 5 ∷
  up 9 ∷
  forward 1 ∷
  forward 4 ∷
  forward 9 ∷
  forward 7 ∷
  down 9 ∷
  up 9 ∷
  down 1 ∷
  down 7 ∷
  forward 7 ∷
  down 7 ∷
  down 7 ∷
  down 3 ∷
  down 5 ∷
  forward 3 ∷
  down 2 ∷
  forward 6 ∷
  down 9 ∷
  up 5 ∷
  up 3 ∷
  forward 5 ∷
  down 6 ∷
  down 1 ∷
  forward 4 ∷
  down 3 ∷
  forward 8 ∷
  down 7 ∷
  forward 7 ∷
  forward 7 ∷
  up 7 ∷
  up 2 ∷
  up 3 ∷
  forward 9 ∷
  down 5 ∷
  up 2 ∷
  forward 5 ∷
  up 5 ∷
  forward 2 ∷
  forward 2 ∷
  down 8 ∷
  forward 2 ∷
  up 4 ∷
  forward 1 ∷
  forward 3 ∷
  up 8 ∷
  up 9 ∷
  forward 5 ∷
  down 1 ∷
  up 8 ∷
  down 4 ∷
  down 8 ∷
  up 4 ∷
  forward 9 ∷
  down 6 ∷
  down 8 ∷
  up 2 ∷
  up 3 ∷
  down 7 ∷
  down 4 ∷
  forward 5 ∷
  down 6 ∷
  forward 3 ∷
  forward 3 ∷
  forward 8 ∷
  down 1 ∷
  down 7 ∷
  down 9 ∷
  down 2 ∷
  down 7 ∷
  forward 7 ∷
  down 7 ∷
  down 6 ∷
  up 6 ∷
  forward 8 ∷
  forward 5 ∷
  up 5 ∷
  down 2 ∷
  up 8 ∷
  up 4 ∷
  down 9 ∷
  up 2 ∷
  forward 5 ∷
  up 2 ∷
  down 4 ∷
  up 4 ∷
  forward 2 ∷
  forward 4 ∷
  forward 9 ∷
  forward 9 ∷
  up 4 ∷
  up 5 ∷
  down 1 ∷
  down 6 ∷
  down 1 ∷
  down 4 ∷
  down 5 ∷
  down 3 ∷
  forward 3 ∷
  down 9 ∷
  forward 6 ∷
  down 3 ∷
  down 9 ∷
  down 2 ∷
  up 2 ∷
  down 2 ∷
  down 7 ∷
  forward 9 ∷
  down 3 ∷
  down 3 ∷
  down 2 ∷
  down 3 ∷
  forward 2 ∷
  down 9 ∷
  down 9 ∷
  up 5 ∷
  up 3 ∷
  forward 4 ∷
  up 7 ∷
  forward 8 ∷
  up 6 ∷
  forward 7 ∷
  down 7 ∷
  down 1 ∷
  forward 5 ∷
  down 2 ∷
  up 1 ∷
  down 8 ∷
  up 3 ∷
  forward 2 ∷
  up 9 ∷
  down 1 ∷
  down 3 ∷
  down 6 ∷
  down 2 ∷
  down 7 ∷
  up 2 ∷
  forward 5 ∷
  forward 7 ∷
  down 2 ∷
  forward 5 ∷
  forward 4 ∷
  forward 5 ∷
  down 3 ∷
  forward 7 ∷
  down 7 ∷
  forward 8 ∷
  down 3 ∷
  down 2 ∷
  up 1 ∷
  forward 6 ∷
  down 4 ∷
  down 2 ∷
  forward 7 ∷
  up 3 ∷
  down 4 ∷
  forward 2 ∷
  up 6 ∷
  down 3 ∷
  up 6 ∷
  up 8 ∷
  down 9 ∷
  up 6 ∷
  forward 8 ∷
  forward 9 ∷
  forward 4 ∷
  forward 7 ∷
  down 2 ∷
  forward 9 ∷
  down 7 ∷
  up 9 ∷
  down 5 ∷
  down 6 ∷
  up 5 ∷
  down 4 ∷
  forward 8 ∷
  forward 4 ∷
  forward 4 ∷
  down 6 ∷
  forward 3 ∷
  forward 6 ∷
  down 9 ∷
  down 9 ∷
  up 2 ∷
  forward 7 ∷
  down 8 ∷
  down 9 ∷
  down 9 ∷
  forward 7 ∷
  forward 3 ∷
  down 7 ∷
  down 8 ∷
  forward 8 ∷
  down 6 ∷
  down 5 ∷
  down 9 ∷
  down 3 ∷
  forward 1 ∷
  down 5 ∷
  forward 2 ∷
  forward 8 ∷
  down 2 ∷
  forward 6 ∷
  forward 3 ∷
  down 7 ∷
  down 4 ∷
  forward 8 ∷
  forward 1 ∷
  down 6 ∷
  forward 9 ∷
  forward 6 ∷
  up 1 ∷
  up 3 ∷
  down 8 ∷
  forward 1 ∷
  up 5 ∷
  down 4 ∷
  forward 7 ∷
  up 3 ∷
  down 2 ∷
  forward 1 ∷
  forward 9 ∷
  down 9 ∷
  down 7 ∷
  forward 8 ∷
  down 4 ∷
  up 3 ∷
  down 4 ∷
  forward 2 ∷
  forward 6 ∷
  down 7 ∷
  forward 6 ∷
  down 6 ∷
  down 4 ∷
  down 1 ∷
  up 9 ∷
  down 4 ∷
  down 7 ∷
  up 4 ∷
  down 9 ∷
  forward 6 ∷
  down 3 ∷
  forward 2 ∷
  down 4 ∷
  forward 3 ∷
  down 5 ∷
  up 9 ∷
  forward 8 ∷
  up 7 ∷
  up 6 ∷
  up 4 ∷
  forward 1 ∷
  down 1 ∷
  forward 4 ∷
  up 6 ∷
  forward 5 ∷
  forward 4 ∷
  forward 5 ∷
  up 6 ∷
  down 1 ∷
  forward 3 ∷
  up 7 ∷
  down 9 ∷
  up 9 ∷
  down 5 ∷
  forward 6 ∷
  forward 4 ∷
  up 1 ∷
  down 4 ∷
  up 1 ∷
  forward 3 ∷
  forward 1 ∷
  down 3 ∷
  forward 7 ∷
  down 2 ∷
  forward 3 ∷
  up 2 ∷
  forward 8 ∷
  down 3 ∷
  up 9 ∷
  down 5 ∷
  forward 6 ∷
  down 1 ∷
  down 8 ∷
  down 5 ∷
  forward 1 ∷
  down 6 ∷
  up 2 ∷
  forward 6 ∷
  down 2 ∷
  down 1 ∷
  up 6 ∷
  up 7 ∷
  down 5 ∷
  forward 7 ∷
  forward 6 ∷
  forward 6 ∷
  down 7 ∷
  forward 4 ∷
  down 5 ∷
  up 5 ∷
  down 1 ∷
  up 8 ∷
  down 8 ∷
  down 2 ∷
  down 2 ∷
  down 9 ∷
  up 9 ∷
  forward 2 ∷
  forward 7 ∷
  down 7 ∷
  down 4 ∷
  down 4 ∷
  down 8 ∷
  forward 5 ∷
  forward 2 ∷
  up 9 ∷
  down 9 ∷
  forward 7 ∷
  up 9 ∷
  down 2 ∷
  down 7 ∷
  up 2 ∷
  up 8 ∷
  forward 8 ∷
  down 4 ∷
  forward 3 ∷
  forward 4 ∷
  forward 6 ∷
  forward 2 ∷
  down 1 ∷
  down 2 ∷
  forward 2 ∷
  up 1 ∷
  down 1 ∷
  forward 5 ∷
  up 3 ∷
  up 3 ∷
  down 3 ∷
  down 1 ∷
  down 4 ∷
  up 5 ∷
  up 6 ∷
  forward 5 ∷
  up 7 ∷
  forward 6 ∷
  down 4 ∷
  down 7 ∷
  up 8 ∷
  forward 1 ∷
  down 5 ∷
  up 4 ∷
  up 3 ∷
  up 5 ∷
  down 1 ∷
  up 5 ∷
  forward 3 ∷
  up 5 ∷
  forward 2 ∷
  forward 2 ∷
  forward 5 ∷
  forward 2 ∷
  up 9 ∷
  forward 4 ∷
  down 1 ∷
  down 3 ∷
  down 5 ∷
  up 2 ∷
  down 8 ∷
  forward 8 ∷
  forward 9 ∷
  down 1 ∷
  down 3 ∷
  forward 8 ∷
  forward 2 ∷
  down 2 ∷
  down 1 ∷
  up 7 ∷
  forward 2 ∷
  forward 8 ∷
  down 9 ∷
  forward 1 ∷
  forward 4 ∷
  down 7 ∷
  down 4 ∷
  up 7 ∷
  down 3 ∷
  down 1 ∷
  down 4 ∷
  up 7 ∷
  down 6 ∷
  forward 7 ∷
  down 8 ∷
  up 2 ∷
  up 4 ∷
  up 6 ∷
  down 9 ∷
  down 9 ∷
  down 8 ∷
  forward 6 ∷
  up 3 ∷
  up 1 ∷
  forward 9 ∷
  forward 6 ∷
  up 4 ∷
  up 2 ∷
  up 7 ∷
  forward 5 ∷
  up 9 ∷
  up 9 ∷
  forward 9 ∷
  up 6 ∷
  down 1 ∷
  down 3 ∷
  forward 3 ∷
  down 2 ∷
  down 2 ∷
  down 6 ∷
  down 9 ∷
  forward 3 ∷
  forward 7 ∷
  up 3 ∷
  forward 3 ∷
  down 5 ∷
  forward 9 ∷
  up 6 ∷
  down 2 ∷
  forward 8 ∷
  down 3 ∷
  up 5 ∷
  down 6 ∷
  forward 9 ∷
  down 5 ∷
  down 2 ∷
  down 6 ∷
  forward 8 ∷
  forward 6 ∷
  down 1 ∷
  forward 6 ∷
  up 1 ∷
  up 7 ∷
  down 4 ∷
  down 7 ∷
  forward 4 ∷
  forward 7 ∷
  down 4 ∷
  forward 8 ∷
  down 8 ∷
  down 7 ∷
  forward 9 ∷
  down 1 ∷
  down 3 ∷
  down 6 ∷
  forward 7 ∷
  forward 6 ∷
  forward 3 ∷
  forward 8 ∷
  down 5 ∷
  down 3 ∷
  up 1 ∷
  down 9 ∷
  down 8 ∷
  forward 3 ∷
  down 6 ∷
  down 1 ∷
  forward 5 ∷
  forward 5 ∷
  forward 9 ∷
  up 5 ∷
  down 6 ∷
  up 9 ∷
  down 7 ∷
  down 6 ∷
  up 1 ∷
  forward 5 ∷
  forward 7 ∷
  forward 8 ∷
  forward 7 ∷
  forward 6 ∷
  forward 3 ∷
  forward 1 ∷
  forward 2 ∷
  up 4 ∷
  forward 3 ∷
  forward 4 ∷
  forward 5 ∷
  up 2 ∷
  up 3 ∷
  forward 4 ∷
  down 9 ∷
  up 4 ∷
  forward 7 ∷
  down 6 ∷
  down 6 ∷
  down 1 ∷
  forward 2 ∷
  down 2 ∷
  forward 2 ∷
  down 3 ∷
  forward 7 ∷
  forward 8 ∷
  down 4 ∷
  up 7 ∷
  forward 7 ∷
  down 7 ∷
  forward 7 ∷
  forward 9 ∷
  down 7 ∷
  up 2 ∷
  down 3 ∷
  forward 7 ∷
  down 1 ∷
  forward 8 ∷
  forward 2 ∷
  up 9 ∷
  down 3 ∷
  forward 2 ∷
  up 4 ∷
  forward 9 ∷
  down 4 ∷
  down 4 ∷
  forward 4 ∷
  down 2 ∷
  down 9 ∷
  forward 4 ∷
  down 2 ∷
  down 6 ∷
  forward 9 ∷
  forward 2 ∷
  up 1 ∷
  forward 2 ∷
  forward 3 ∷
  down 5 ∷
  up 8 ∷
  down 4 ∷
  down 4 ∷
  forward 7 ∷
  down 2 ∷
  up 6 ∷
  down 9 ∷
  forward 9 ∷
  up 1 ∷
  forward 3 ∷
  down 5 ∷
  forward 3 ∷
  down 3 ∷
  forward 4 ∷
  up 3 ∷
  down 6 ∷
  down 7 ∷
  down 4 ∷
  down 8 ∷
  down 4 ∷
  down 5 ∷
  up 9 ∷
  up 1 ∷
  down 7 ∷
  up 3 ∷
  up 3 ∷
  down 3 ∷
  up 4 ∷
  up 6 ∷
  forward 8 ∷
  down 1 ∷
  forward 7 ∷
  forward 4 ∷
  down 9 ∷
  down 1 ∷
  forward 7 ∷
  forward 9 ∷
  forward 1 ∷
  down 3 ∷
  down 2 ∷
  forward 3 ∷
  forward 2 ∷
  down 7 ∷
  forward 9 ∷
  forward 6 ∷
  up 9 ∷
  down 2 ∷
  forward 9 ∷
  up 6 ∷
  forward 8 ∷
  up 1 ∷
  down 5 ∷
  down 8 ∷
  forward 1 ∷
  down 1 ∷
  forward 9 ∷
  up 1 ∷
  forward 9 ∷
  forward 1 ∷
  forward 1 ∷
  down 7 ∷
  forward 3 ∷
  forward 6 ∷
  down 5 ∷
  forward 7 ∷
  forward 1 ∷
  down 7 ∷
  down 6 ∷
  down 6 ∷
  forward 5 ∷
  up 6 ∷
  down 6 ∷
  forward 8 ∷
  up 2 ∷
  down 8 ∷
  down 3 ∷
  up 5 ∷
  up 8 ∷
  down 6 ∷
  forward 4 ∷
  forward 2 ∷
  up 3 ∷
  forward 5 ∷
  forward 3 ∷
  up 8 ∷
  forward 6 ∷
  up 8 ∷
  forward 1 ∷
  up 8 ∷
  up 7 ∷
  up 6 ∷
  forward 2 ∷
  down 9 ∷
  down 9 ∷
  forward 3 ∷
  down 7 ∷
  forward 3 ∷
  down 6 ∷
  forward 9 ∷
  up 5 ∷
  down 1 ∷
  forward 7 ∷
  down 1 ∷
  down 5 ∷
  down 9 ∷
  forward 8 ∷
  forward 9 ∷
  forward 7 ∷
  down 9 ∷
  up 4 ∷
  forward 5 ∷
  down 5 ∷
  forward 5 ∷
  down 9 ∷
  forward 9 ∷
  forward 3 ∷
  up 5 ∷
  forward 8 ∷
  up 5 ∷
  down 1 ∷
  forward 8 ∷
  down 3 ∷
  forward 6 ∷
  up 9 ∷
  forward 8 ∷
  down 4 ∷
  forward 3 ∷
  down 5 ∷
  forward 8 ∷
  forward 9 ∷
  forward 2 ∷
  down 1 ∷
  down 6 ∷
  down 4 ∷
  forward 9 ∷
  up 2 ∷
  down 3 ∷
  down 6 ∷
  down 3 ∷
  down 9 ∷
  down 1 ∷
  up 6 ∷
  down 2 ∷
  down 7 ∷
  up 5 ∷
  forward 5 ∷
  up 1 ∷
  down 7 ∷
  forward 6 ∷
  up 6 ∷
  down 2 ∷
  down 3 ∷
  forward 3 ∷
  down 5 ∷
  forward 8 ∷
  down 9 ∷
  down 7 ∷
  down 8 ∷
  up 7 ∷
  down 1 ∷
  forward 1 ∷
  forward 1 ∷
  down 2 ∷
  up 4 ∷
  forward 2 ∷
  down 3 ∷
  up 2 ∷
  down 3 ∷
  down 2 ∷
  forward 7 ∷
  down 1 ∷
  up 7 ∷
  down 2 ∷
  down 1 ∷
  forward 6 ∷
  down 9 ∷
  up 9 ∷
  down 4 ∷
  down 6 ∷
  up 9 ∷
  forward 7 ∷
  forward 9 ∷
  forward 7 ∷
  down 4 ∷
  down 1 ∷
  forward 7 ∷
  down 4 ∷
  down 7 ∷
  down 3 ∷
  down 5 ∷
  forward 3 ∷
  down 8 ∷
  forward 8 ∷
  forward 7 ∷
  forward 8 ∷
  down 4 ∷
  down 9 ∷
  forward 2 ∷
  forward 7 ∷
  up 8 ∷
  forward 4 ∷
  down 6 ∷
  up 8 ∷
  down 2 ∷
  forward 3 ∷
  down 6 ∷
  down 8 ∷
  forward 8 ∷
  forward 2 ∷
  forward 9 ∷
  up 6 ∷
  forward 7 ∷
  down 3 ∷
  down 5 ∷
  forward 8 ∷
  forward 9 ∷
  down 3 ∷
  forward 3 ∷
  forward 2 ∷
  forward 3 ∷
  down 8 ∷
  up 9 ∷
  up 5 ∷
  up 2 ∷
  up 6 ∷
  up 1 ∷
  up 1 ∷
  up 5 ∷
  forward 3 ∷
  forward 2 ∷
  down 3 ∷
  forward 4 ∷
  []

main : IO ⊤
main = putStrLn (shopMaybeNat (doTask input))

private
  -- checks from the exercise text
  _ : apply (forward 5) (state 0 0 0) ≡ just (state 5 0 0)
  _ = refl

  _ : apply (down 5) (state 5 0 0) ≡ just (state 5 0 5)
  _ = refl

  _ : apply (forward 8) (state 5 0 5) ≡ just (state 13 (8 * 5) 5)
  _ = refl

  _ : apply (up 3) (state 13 40 5) ≡ just (state 13 40 2)
  _ = refl

  _ : apply (down 8) (state 13 40 2) ≡ just (state 13 40 10)
  _ = refl

  _ : apply (forward 2) (state 13 40 10) ≡ just (state 15 60 10)
  _ = refl

  -- submarine does not 'fly'
  _ : apply (up 7) (state 13 2 2) ≡ nothing
  _ = refl


{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.DarkwingDuck.Primitive
open import Spire.DarkwingDuck.Derived
module Spire.DarkwingDuck.Examples where

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

NatN : String
NatN = "Nat"

NatE : Enum
NatE = "zero" ∷ "suc" ∷ []

NatP : Tel
NatP = Emp

NatI : Indices NatP
NatI = indices NatP Emp

NatC : Constrs NatE NatP NatI
NatC = constrs NatE NatP NatI
  (End tt , Rec tt (End tt) , tt)

Nat : Former NatP NatI
Nat = Form NatN NatE NatP NatI NatC

zero : Inj NatN NatE NatP NatI NatC here
zero = inj NatN NatE NatP NatI NatC here

suc : Inj NatN NatE NatP NatI NatC (there here)
suc = inj NatN NatE NatP NatI NatC (there here)

elimNat : Elim NatN NatE NatP NatI NatC
elimNat = elim NatN NatE NatP NatI NatC

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

VecN : String
VecN = "Vec"

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

VecP : Tel
VecP = Ext Set λ _ → Emp

VecI : Indices VecP
VecI = indices VecP λ A → Ext Nat λ _ → Emp

VecC : Constrs VecE VecP VecI
VecC = constrs VecE VecP VecI λ A →
    End (zero , tt)
  , Arg Nat (λ n → Arg A λ _ → Rec (n , tt) (End (suc n , tt)))
  , tt

Vec : Former VecP VecI
Vec = Form VecN VecE VecP VecI VecC

nil : Inj VecN VecE VecP VecI VecC here
nil = inj VecN VecE VecP VecI VecC here

cons : Inj VecN VecE VecP VecI VecC (there here)
cons = inj VecN VecE VecP VecI VecC (there here)

elimVec : Elim VecN VecE VecP VecI VecC
elimVec = elim VecN VecE VecP VecI VecC

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

add : Nat → Nat → Nat
add = elimNat
  (λ n → Nat → Nat)
  (λ n → n)
  (λ m ih n → suc (ih n))

mult : Nat → Nat → Nat
mult = elimNat
  (λ n → Nat → Nat)
  (λ n → zero)
  (λ m ih n → add n (ih n))

append : (A : Set) (m n : Nat) (xs : Vec A m) (ys : Vec A n) → Vec A (add m n)
append A m n = elimVec A
  (λ m xs → (ys : Vec A n) → Vec A (add m n))
  (λ ys → ys)
  (λ m' x xs ih ys → cons A (add m' n) x (ih ys))
  m

concat : (A : Set) (m n : Nat) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat A m n = elimVec (Vec A m)
  (λ n xss → Vec A (mult n m))
  (nil A)
  (λ m' xs xss ih → append A m (mult m' m) xs ih)
  n

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

one : Nat
one = suc zero

two : Nat
two = suc one

three : Nat
three = suc two

[1,2] : Vec Nat two
[1,2] = cons Nat one one (cons Nat zero two (nil Nat))

[3] : Vec Nat one
[3] = cons Nat zero three (nil Nat)

[1,2,3] : Vec Nat three
[1,2,3] = cons Nat two one (cons Nat one two (cons Nat zero three (nil Nat)))

test-append : [1,2,3] ≡ append Nat two one [1,2] [3]
test-append = refl

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


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

open import HoTT
open import cohomology.CofiberSequence
open import cohomology.Exactness
open import cohomology.FunctionOver
open import cohomology.Theory
open import cohomology.ProductRepr
open import cohomology.WedgeCofiber

{- Finite additivity is provable (and in a stronger form) without using
 - the additivity axiom. We have

         Cⁿ(X ∨ Y) == Cⁿ(X) × Cⁿ(Y)

 - and over this path
 -   ∙ Cⁿ(winl) corresponds to fst : Cⁿ(X) × Cⁿ(Y) → Cⁿ(X),
 -   ∙ Cⁿ(winr) corresponds to snd : Cⁿ(X) × Cⁿ(Y) → Cⁿ(Y),
 -   ∙ Cⁿ(Wedge-rec winl* winr* wglue*) : Cⁿ(Z) → Cⁿ(X ∨ Y)
       corresponds to Cⁿ(winl*) × Cⁿ(winr*).
 -   ∙ Cⁿ(f) : Cⁿ(X ∨ Y) → Cⁿ(Z)
       corresponds to Cⁿ(projl ∘ f) + Cⁿ(projr ∘ f) : Cⁿ(X) × Cⁿ(Y) → Cⁿ(Z)
 -}

module cohomology.Wedge {i} (CT : CohomologyTheory i) where

module CWedge (n : ℤ) (X Y : Ptd i) where

  open WedgeCofiber X Y

  open CohomologyTheory CT
  open import cohomology.Functor CT

  private
    βl : CF-hom n ⊙winl ∘ᴳ CF-hom n (⊙projl X Y) == idhom _
    βl = ! (CF-comp n (⊙projl X Y) ⊙winl) ∙ CF-ident n

    βr : CF-hom n ⊙winr ∘ᴳ CF-hom n (⊙projr X Y) == idhom _
    βr = ! (CF-comp n (⊙projr X Y) ⊙winr)
         ∙ ap (CF-hom n) ⊙projr-winr
         ∙ CF-ident n
      where
      ⊙projr-winr : ⊙projr X Y ⊙∘ ⊙winr == ⊙idf _
      ⊙projr-winr = ⊙λ= (λ _ → idp) $
        ∙-unit-r _ ∙ ap-! (projr X Y) wglue ∙ ap ! (Projr.glue-β X Y)

  open ProductRepr
    (CF-hom n (⊙projl X Y)) (CF-hom n (⊙projr X Y))
    (CF-hom n ⊙winl) (CF-hom n ⊙winr)
    (app= (ap GroupHom.f βl)) (app= (ap GroupHom.f βr))
    (transport
      (λ {(_ , g) → is-exact (CF-hom n g) (CF-hom n ⊙winr)})
      (pair= CofWinr.⊙path CofWinr.cfcod-over)
      (C-exact n ⊙winr))
    (transport
      (λ {(_ , g) → is-exact (CF-hom n g) (CF-hom n ⊙winl)})
      (pair= CofWinl.⊙path CofWinl.cfcod-over)
      (C-exact n ⊙winl))
    public

  ⊙wedge-rec-over : {Z : Ptd i} (winl* : fst (X ⊙→ Z)) (winr* : fst (Y ⊙→ Z))
    → CF-hom n (⊙wedge-rec winl* winr*)
      == ×ᴳ-hom-in (CF-hom n winl*) (CF-hom n (winr*))
      [ (λ K → C n Z →ᴳ K) ↓ path ]
  ⊙wedge-rec-over winl* winr* = codomain-over-iso $
    codomain-over-equiv (CF n R.⊙f) _
    ▹ ap2 (λ f g z → (f z , g z))
          (ap GroupHom.f $ ! (CF-comp n R.⊙f ⊙winl) ∙ ap (CF-hom n) R.⊙winl-β)
          (ap GroupHom.f $ ! (CF-comp n R.⊙f ⊙winr) ∙ ap (CF-hom n) R.⊙winr-β)
    where
    module R = ⊙WedgeRec winl* winr*

  wedge-hom-η : {Z : Ptd i} (φ : C n (⊙Wedge X Y) →ᴳ C n Z)
    → φ == ×ᴳ-sum-hom (C-abelian n _) (φ ∘ᴳ CF-hom n (⊙projl X Y))
                                      (φ ∘ᴳ CF-hom n (⊙projr X Y))
      [ (λ G → G →ᴳ C n Z) ↓ path ]
  wedge-hom-η φ =
    lemma (C-abelian n _) (C-abelian n _) inl-over inr-over
    where
    lemma : {G H K L : Group i}
      (aG : is-abelian G) (aL : is-abelian L) {p : G == H ×ᴳ K}
      {φ : H →ᴳ G} {ψ : K →ᴳ G} {χ : G →ᴳ L}
      → φ == ×ᴳ-inl [ (λ J → H →ᴳ J) ↓ p ]
      → ψ == ×ᴳ-inr {G = H} [ (λ J → K →ᴳ J) ↓ p ]
      → χ == ×ᴳ-sum-hom aL (χ ∘ᴳ φ) (χ ∘ᴳ ψ) [ (λ J → J →ᴳ L) ↓ p ]
    lemma {H = H} {K = K} aG aL {p = idp} {χ = χ} idp idp =
      ap (λ α → χ ∘ᴳ α) (×ᴳ-sum-hom-η H K aG)
      ∙ ! (∘-×ᴳ-sum-hom aG aL χ (×ᴳ-inl {G = H}) (×ᴳ-inr {G = H}))

  wedge-in-over : {Z : Ptd i} (f : fst (Z ⊙→ ⊙Wedge X Y))
    → CF-hom n f
      == ×ᴳ-sum-hom (C-abelian n _) (CF-hom n (⊙projl X Y ⊙∘ f))
                                    (CF-hom n (⊙projr X Y ⊙∘ f))
      [ (λ G → G →ᴳ C n Z) ↓ path ]
  wedge-in-over f =
    wedge-hom-η (CF-hom n f)
    ▹ ap2 (×ᴳ-sum-hom (C-abelian n _))
        (! (CF-comp n (⊙projl X Y) f))
        (! (CF-comp n (⊙projr X Y) f))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Example use case for a trie: a wee generic lexer
------------------------------------------------------------------------

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

module README.Data.Trie.NonDependent where

------------------------------------------------------------------------
-- Introduction

-- A Trie is a tree of values indexed by words in a finite language. It
-- allows users to quickly compute the Brzozowski derivative of that
-- little mapping from words to values.

-- In the most general case, values can depend upon the list of characters
-- that constitutes the path leading to them. Here however we consider a
-- non-dependent case (cf. README.Trie.Dependent for a dependent use case).

-- We can recognize keywords by storing the list of characters they
-- correspond to as paths in a Trie and the constructor they are decoded
-- to as the tree's values.

-- E.g.
-- [     .      ] is a root
-- [  -- m -->  ] is an m-labeled edge and is followed when reading 'm'
-- [    (X)     ] is a value leaf storing constructor X

--                     --> -- m --> -- m --> -- a --> (LEMMA)
--                    /
--       -- l --> -- e --> -- t --> (LET)
--      /
--     /    -- u --> -- t --> -- u --> -- a --> -- l --> (MUTUAL)
--    /    /
--  .< -- m --> -- o --> -- d --> -- u --> -- l --> -- e --> (MODULE)
--    \
--     -- w --> -- h --> -- e --> -- r --> -- e --> (WHERE)
--                           \
--                            --> -- n --> (WHEN)

-- after reading 'w', we get the derivative:

--  . -- h --> -- e --> -- r --> -- e --> (WHERE)
--                 \
--                  --> -- n --> (WHEN)

open import Level
open import Data.Unit
open import Data.Bool
open import Data.Char        as Char
import Data.Char.Properties  as Char
open import Data.List        as List using (List; []; _∷_)
open import Data.List.Fresh  as List# using (List#; []; _∷#_)
open import Data.Maybe       as Maybe
open import Data.Product     as Prod
open import Data.String      as String using (String)
open import Data.These       as These

open import Function using (case_of_; _$_; _∘′_; id; _on_)
open import Relation.Nary
open import Relation.Binary using (Rel)
open import Relation.Nullary.Negation using (¬?)

open import Data.Trie Char.<-strictTotalOrder-≈
open import Data.AVL.Value

------------------------------------------------------------------------
-- Generic lexer

record Lexer t : Set (suc t) where
  field
  -- Our lexer is parametrised over the type of tokens
    Tok : Set t

  -- Keywords are distinguished strings associated to tokens
  Keyword : Set t
  Keyword = String × Tok

  -- Two keywords are considered distinct if the strings are not equal
  Distinct : Rel Keyword 0ℓ
  Distinct a b = ⌊ ¬? ((proj₁ a) String.≟ (proj₁ b)) ⌋

  field

  -- We ask users to provide us with a fresh list of keywords to guarantee
  -- that no two keywords share the same string representation
    keywords : List# Keyword Distinct

  -- Some characters are special: they are separators, breaking a string
  -- into a list of tokens. Some are associated to a token value
  -- (e.g. parentheses) others are not (e.g. space)
    breaking : Char → ∃ λ b → if b then Maybe Tok else Lift _ ⊤

  -- Finally, strings which are not decoded as keywords are coerced
  -- using a function to token values.
    default  : String → Tok

module _ {t} (L : Lexer t) where
  open Lexer L

  tokenize : String → List Tok
  tokenize = start ∘′ String.toList where

   mutual

    -- A Trie is defined for an alphabet of strictly ordered letters (here
    -- we have picked Char for letters and decided to use the strict total
    -- order induced by their injection into ℕ as witnessed by the statement
    -- open import Data.Trie Char.strictTotalOrder earlier in this file).

    -- It is parametrised by a set of Values indexed over list of letters.
    -- Because we focus on the non-dependent case, we pick the constant
    -- family of Value uniformly equal to Tok. It is trivially compatible
    -- with the notion of equality underlying the strict total order on Chars.

    Keywords : Set _
    Keywords = Trie (const _ Tok) _

    -- We build a trie from the association list so that we may easily
    -- compute the successive derivatives obtained by eating the
    -- characters one by one

    init : Keywords
    init = fromList $ List.map (Prod.map₁ String.toList) $ proj₁ $ List#.toList keywords

    -- Kickstart the tokeniser with an empty accumulator and the initial
    -- trie.
    start : List Char → List Tok
    start = loop [] init

    -- The main loop
    loop : (acc  : List Char)  → -- chars read so far in this token
           (toks : Keywords)   → -- keyword candidates left at this point
           (input : List Char) → -- list of chars to tokenize
           List Tok
    -- Empty input: finish up, check whether we have a non-empty accumulator
    loop acc toks []         = push acc []
    -- At least one character
    loop acc toks (c ∷ cs)   = case breaking c of λ where
      -- if we are supposed to break on this character, we do
      (true , m)  → push acc $ maybe′ _∷_ id m $ start cs
      -- otherwise we see whether it leads to a recognized keyword
      (false , _) → case lookupValue (c ∷ []) toks of λ where
        -- if so we can forget about the current accumulator and
        -- restart the tokenizer on the rest of the input
        (just tok) → tok ∷ start cs
        -- otherwise we record the character we read in the accumulator,
        -- compute the derivative of the map of keyword candidates and
        -- keep going with the rest of the input
        nothing    → loop (c ∷ acc) (lookupTrie c toks) cs

    -- Grab the accumulator and, unless it is empty, push it on top of
    -- the decoded list of tokens
    push : List Char → List Tok → List Tok
    push [] ts = ts
    push cs ts = default (String.fromList (List.reverse cs)) ∷ ts

------------------------------------------------------------------------
-- Concrete instance

-- A small set of keywords for a language with expressions of the form
-- `let x = e in b`.

module LetIn where

  data TOK : Set where
    LET EQ IN : TOK
    LPAR RPAR : TOK
    ID : String → TOK

  keywords : List# (String × TOK) (λ a b → ⌊ ¬? ((proj₁ a) String.≟ (proj₁ b)) ⌋)
  keywords =  ("let" , LET)
           ∷# ("="   , EQ)
           ∷# ("in"  , IN)
           ∷# []

  -- Breaking characters: spaces (thrown away) and parentheses (kept)
  breaking : Char → ∃ (λ b → if b then Maybe TOK else Lift 0ℓ ⊤)
  breaking c = if isSpace c then true , nothing else parens c where

    parens : Char → _
    parens '(' = true , just LPAR
    parens ')' = true , just RPAR
    parens _   = false , _

  default : String → TOK
  default = ID

letIn : Lexer 0ℓ
letIn = record { LetIn }

open import Agda.Builtin.Equality

-- A test case:

open LetIn
_ : tokenize letIn "fix f x = let b = fix f in (f b) x"
  ≡ ID "fix"
  ∷ ID "f"
  ∷ ID "x"
  ∷ EQ
  ∷ LET
  ∷ ID "b"
  ∷ EQ
  ∷ ID "fix"
  ∷ ID "f"
  ∷ IN
  ∷ LPAR
  ∷ ID "f"
  ∷ ID "b"
  ∷ RPAR
  ∷ ID "x"
  ∷ []
_ = refl


{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Structures.MultiSet where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)
open import Cubical.Functions.FunExtEquiv

open import Cubical.Structures.Pointed
open import Cubical.Structures.Queue

open import Cubical.Data.Unit
open import Cubical.Data.Sum
open import Cubical.Data.Nat
open import Cubical.Data.Sigma

module _(A : Type ℓ)
        (Aset : isSet A) where

 open Queues-on A Aset

 member-structure : Type ℓ → Type ℓ
 member-structure X = A → X → ℕ

 Member : Type (ℓ-suc ℓ)
 Member = TypeWithStr ℓ member-structure

 member-iso : StrIso member-structure ℓ
 member-iso (X , f) (Y , g) e = ∀ a x → f a x ≡ g a (e .fst x)

 Member-is-SNS : SNS {ℓ} member-structure member-iso
 Member-is-SNS = SNS-≡→SNS-PathP member-iso ((λ _ _ → funExt₂Equiv))

 -- a multi set structure inspired bei Okasaki
 multi-set-structure : Type ℓ → Type ℓ
 multi-set-structure X = X × (A → X → X) × (A → X → ℕ)

 Multi-Set : Type (ℓ-suc ℓ)
 Multi-Set = TypeWithStr ℓ multi-set-structure

 multi-set-iso : StrIso multi-set-structure ℓ
 multi-set-iso (X , emp₁ , insert₁ , memb₁) (Y , emp₂ , insert₂ , memb₂) e =
            (e .fst emp₁ ≡ emp₂)
          × (∀ a q → e .fst (insert₁ a q) ≡ insert₂ a (e .fst q))
          × (∀ a x → memb₁ a x ≡ memb₂ a (e .fst x))

 Multi-Set-is-SNS : SNS {ℓ₁ = ℓ} multi-set-structure multi-set-iso
 Multi-Set-is-SNS =
   join-SNS pointed-iso pointed-is-SNS
            {S₂ = λ X → (left-action-structure X) × (member-structure X)}
            (λ B C e →  (∀ a q → e .fst (B .snd .fst a q) ≡ C .snd .fst a (e .fst q))
                      × (∀ a x → (B .snd .snd a x) ≡ (C .snd .snd a (e .fst x))))
            (join-SNS left-action-iso Left-Action-is-SNS member-iso Member-is-SNS)


{-# OPTIONS --without-K --rewriting #-}

open import HoTT

module groups.KernelCstImageCst {i j k}
  (G : Group i) (H : Group j) (K : Group k)
  (H-ab : is-abelian H) where

  private
    module H = Group H

  open import groups.KernelImage {G = G} {H = H} {K = K} cst-hom cst-hom H-ab

  Ker-cst-quot-Im-cst : Ker/Im ≃ᴳ H
  Ker-cst-quot-Im-cst = ≃-to-≃ᴳ (equiv to from to-from from-to) to-pres-comp where
    to : Ker/Im.El → H.El
    to = SetQuot-rec H.El-level to' to-rel where
      to' : Ker.El (cst-hom {G = H} {H = K}) → H.El
      to' ker = fst ker

      abstract
        to-rel : ∀ {h₁ h₂} → ker/im-rel' h₁ h₂ → h₁ == h₂
        to-rel {h₁} {h₂} = Trunc-rec (H.El-level _ _)
          λ{(_ , 0=h₁h₂⁻¹) → H.zero-diff-same h₁ h₂ (! 0=h₁h₂⁻¹)}

    from : H.El → Ker/Im.El
    from h = q[ h , idp ]

    abstract
      to-from : ∀ h → to (from h) == h
      to-from h = idp

      from-to : ∀ k/i → from (to k/i) == k/i
      from-to = SetQuot-elim (λ _ → =-preserves-set SetQuot-level)
        (λ _ → ap q[_] $ ker-El=-out idp)
        (λ _ → prop-has-all-paths-↓ (SetQuot-level _ _))

      to-pres-comp : preserves-comp Ker/Im.comp H.comp to
      to-pres-comp = SetQuot-elim
        (λ _ → Π-is-set λ _ → =-preserves-set H.El-level)
        (λ _ → SetQuot-elim
          (λ _ → =-preserves-set H.El-level)
          (λ _ → idp)
          (λ _ → prop-has-all-paths-↓ (H.El-level _ _)))
        (λ _ → prop-has-all-paths-↓ (Π-is-prop λ _ → H.El-level _ _))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some theory for commutative semigroup
------------------------------------------------------------------------

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

open import Algebra using (CommutativeSemigroup)

module Algebra.Properties.CommutativeSemigroup
  {a ℓ} (CS : CommutativeSemigroup a ℓ)
  where

open CommutativeSemigroup CS

open import Relation.Binary.Reasoning.Setoid setoid

------------------------------------------------------------------------------
-- Re-export the contents of semigroup

open import Algebra.Properties.Semigroup semigroup public

------------------------------------------------------------------------------
-- Permutation laws for _∙_ for three factors.

------------------------------------------------------------------------------
-- Partitions (1,1).
-- There are five nontrivial permutations.
------------------------------------------------------------------------------

x∙yz≈y∙xz :  ∀ x y z → x ∙ (y ∙ z) ≈ y ∙ (x ∙ z)
x∙yz≈y∙xz x y z = begin
  x ∙ (y ∙ z)    ≈⟨ sym (assoc x y z) ⟩
  (x ∙ y) ∙ z    ≈⟨ ∙-congʳ (comm x y) ⟩
  (y ∙ x) ∙ z    ≈⟨ assoc y x z ⟩
  y ∙ (x ∙ z)    ∎

x∙yz≈z∙yx :  ∀ x y z → x ∙ (y ∙ z) ≈ z ∙ (y ∙ x)
x∙yz≈z∙yx x y z = begin
  x ∙ (y ∙ z)    ≈⟨ ∙-congˡ (comm y z) ⟩
  x ∙ (z ∙ y)    ≈⟨ x∙yz≈y∙xz x z y ⟩
  z ∙ (x ∙ y)    ≈⟨ ∙-congˡ (comm x y) ⟩
  z ∙ (y ∙ x)    ∎

x∙yz≈x∙zy :  ∀ x y z → x ∙ (y ∙ z) ≈ x ∙ (z ∙ y)
x∙yz≈x∙zy _ y z =  ∙-congˡ (comm y z)

x∙yz≈y∙zx :  ∀ x y z → x ∙ (y ∙ z) ≈ y ∙ (z ∙ x)
x∙yz≈y∙zx x y z = begin
  x ∙ (y ∙ z)   ≈⟨ comm x _ ⟩
  (y ∙ z) ∙ x   ≈⟨ assoc y z x ⟩
  y ∙ (z ∙ x)   ∎

x∙yz≈z∙xy :  ∀ x y z → x ∙ (y ∙ z) ≈ z ∙ (x ∙ y)
x∙yz≈z∙xy x y z = begin
  x ∙ (y ∙ z)   ≈⟨ sym (assoc x y z) ⟩
  (x ∙ y) ∙ z   ≈⟨ comm _ z ⟩
  z ∙ (x ∙ y)   ∎

------------------------------------------------------------------------------
-- Partitions (1,2).
-- These permutation laws are proved by composing the proofs for
-- partitions (1,1) with  \p → trans p (sym (assoc _ _ _)).
------------------------------------------------------------------------------

x∙yz≈yx∙z :  ∀ x y z → x ∙ (y ∙ z) ≈ (y ∙ x) ∙ z
x∙yz≈yx∙z x y z =  trans (x∙yz≈y∙xz x y z) (sym (assoc y x z))

x∙yz≈zy∙x :  ∀ x y z → x ∙ (y ∙ z) ≈ (z ∙ y) ∙ x
x∙yz≈zy∙x x y z =  trans (x∙yz≈z∙yx x y z) (sym (assoc z y x))

x∙yz≈xz∙y :  ∀ x y z → x ∙ (y ∙ z) ≈ (x ∙ z) ∙ y
x∙yz≈xz∙y x y z =  trans (x∙yz≈x∙zy x y z) (sym (assoc x z y))

x∙yz≈yz∙x :  ∀ x y z → x ∙ (y ∙ z) ≈ (y ∙ z) ∙ x
x∙yz≈yz∙x x y z =  trans (x∙yz≈y∙zx _ _ _) (sym (assoc y z x))

x∙yz≈zx∙y :  ∀ x y z → x ∙ (y ∙ z) ≈ (z ∙ x) ∙ y
x∙yz≈zx∙y x y z =  trans (x∙yz≈z∙xy x y z) (sym (assoc z x y))

------------------------------------------------------------------------------
-- Partitions (2,1).
-- Their laws are proved by composing proofs for partitions (1,1) with
-- trans (assoc x y z).
------------------------------------------------------------------------------

xy∙z≈y∙xz :  ∀ x y z → (x ∙ y) ∙ z ≈ y ∙ (x ∙ z)
xy∙z≈y∙xz x y z =  trans (assoc x y z) (x∙yz≈y∙xz x y z)

xy∙z≈z∙yx :  ∀ x y z → (x ∙ y) ∙ z ≈ z ∙ (y ∙ x)
xy∙z≈z∙yx x y z =  trans (assoc x y z) (x∙yz≈z∙yx x y z)

xy∙z≈x∙zy :  ∀ x y z → (x ∙ y) ∙ z ≈ x ∙ (z ∙ y)
xy∙z≈x∙zy x y z =  trans (assoc x y z) (x∙yz≈x∙zy x y z)

xy∙z≈y∙zx :  ∀ x y z → (x ∙ y) ∙ z ≈ y ∙ (z ∙ x)
xy∙z≈y∙zx x y z =  trans (assoc x y z) (x∙yz≈y∙zx x y z)

xy∙z≈z∙xy :  ∀ x y z → (x ∙ y) ∙ z ≈ z ∙ (x ∙ y)
xy∙z≈z∙xy x y z =  trans (assoc x y z) (x∙yz≈z∙xy x y z)

------------------------------------------------------------------------------
-- Partitions (2,2).
-- These proofs are by composing with the proofs for (2,1).
------------------------------------------------------------------------------

xy∙z≈yx∙z :  ∀ x y z → (x ∙ y) ∙ z ≈ (y ∙ x) ∙ z
xy∙z≈yx∙z x y z =  trans (xy∙z≈y∙xz _ _ _) (sym (assoc y x z))

xy∙z≈zy∙x :  ∀ x y z → (x ∙ y) ∙ z ≈ (z ∙ y) ∙ x
xy∙z≈zy∙x x y z =  trans (xy∙z≈z∙yx x y z) (sym (assoc z y x))

xy∙z≈xz∙y :  ∀ x y z → (x ∙ y) ∙ z ≈ (x ∙ z) ∙ y
xy∙z≈xz∙y x y z =  trans (xy∙z≈x∙zy x y z) (sym (assoc x z y))

xy∙z≈yz∙x :  ∀ x y z → (x ∙ y) ∙ z ≈ (y ∙ z) ∙ x
xy∙z≈yz∙x x y z =  trans (xy∙z≈y∙zx x y z) (sym (assoc y z x))

xy∙z≈zx∙y :  ∀ x y z → (x ∙ y) ∙ z ≈ (z ∙ x) ∙ y
xy∙z≈zx∙y x y z =  trans (xy∙z≈z∙xy x y z) (sym (assoc z x y))