Fin: _=?_, iterate

Fin: _=?_, iterate

-- NOTE with-K
module Data.Fin.NP where

open import Type hiding (★)
open import Function
open import Data.Zero
open import Data.One using (𝟙)
open import Data.Fin public renaming (toℕ to Fin▹ℕ)
open import Data.Nat.NP using (ℕ; zero; suc; _<=_; module ℕ°) renaming (_+_ to _+ℕ_)
open import Data.Two using (𝟚; 0₂; 1₂; [0:_1:_]; case_0:_1:_)
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup; rot₁; tabulate; foldr) renaming (map to vmap)
import Data.Vec.Properties as Vec
open import Data.Maybe.NP
open import Data.Sum as Sum
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality as ≡

suc-injective : ∀ {m}{i j : Fin m} → Fin.suc i ≡ suc j → i ≡ j
suc-injective refl = refl

-- The isomorphisms about Fin, 𝟘, 𝟙, 𝟚 are in Function.Related.TypeIsomorphisms.NP

Fin▹𝟘 : Fin 0 → 𝟘
Fin▹𝟘 ()

𝟘▹Fin : 𝟘 → Fin 0
𝟘▹Fin ()

Fin▹𝟙 : Fin 1 → 𝟙
Fin▹𝟙 _ = _

𝟙▹Fin : 𝟙 → Fin 1
𝟙▹Fin _ = zero

Fin▹𝟚 : Fin 2 → 𝟚
Fin▹𝟚 zero    = 0₂
Fin▹𝟚 (suc _) = 1₂

𝟚▹Fin : 𝟚 → Fin 2
𝟚▹Fin = [0: # 0 1: # 1 ]

_+′_ : ∀ {m n} (x : Fin m) (y : Fin n) → Fin (m +ℕ n)
_+′_ {suc m} {n} zero y rewrite ℕ°.+-comm (suc m) n = inject+ _ y
suc x +′ y = suc (x +′ y)

_≟_ : ∀ {n} (i j : Fin n) → Dec (i ≡ j)
zero ≟ zero = yes refl
zero ≟ suc j = no (λ())
suc i ≟ zero = no (λ())
suc i ≟ suc j with i ≟ j
suc i ≟ suc j | yes p = yes (cong suc p)
suc i ≟ suc j | no ¬p = no (¬p ∘ suc-injective)

_==_ : ∀ {n} (x y : Fin n) → 𝟚
x == y = ⌊ x ≟ y ⌋
{-helper (compare x y) where
  helper : ∀ {n} {i j : Fin n} → Ordering i j → 𝟚
  helper (equal _) = 1₂
  helper _         = 0₂-}

swap : ∀ {i} (x y : Fin i) → Fin i → Fin i
swap x y z = case x == z 0: (case y == z 0: z 1: x) 1: y

module _ {a} {A : ★ a}
         (B : ℕ → ★₀)
         (_◅_ : ∀ {n} → A → B n → B (suc n))
         (ε : B zero) where
  iterate : ∀ {n} (f : Fin n → A) → B n
  iterate {zero}  f = ε
  iterate {suc n} f = f zero ◅ iterate (f ∘ suc)

  iterate-foldr∘tabulate :
    ∀ {n} (f : Fin n → A) → iterate f ≡ foldr B _◅_ ε (tabulate f)
  iterate-foldr∘tabulate {zero} f = refl
  iterate-foldr∘tabulate {suc n} f = cong (_◅_ (f zero)) (iterate-foldr∘tabulate (f ∘ suc))

module _ {a} {A : ★ a} (B : ★₀)
         (_◅_ : A → B → B)
         (ε : B) where
  iterate′ : ∀ {n} (f : Fin n → A) → B
  iterate′ f = iterate _ _◅_ ε f

data FinSum m n : Fin (m +ℕ n) → ★₀ where
  bound : (x : Fin m) → FinSum m n (inject+ n x)
  free  : (x : Fin n) → FinSum m n (raise m x)

open import Relation.Binary.PropositionalEquality

cmp : ∀ m n (x : Fin (m +ℕ n)) → FinSum m n x
cmp zero n x = free x
cmp (suc m) n zero = bound zero
cmp (suc m) n (suc x) with cmp m n x
cmp (suc m) n (suc .(inject+ n x)) | bound x = bound (suc x)
cmp (suc m) n (suc .(raise m x))   | free x  = free x

max : ∀ n → Fin (suc n)
max = fromℕ

-- reverse x = n ∸ (1 + x)
reverse : ∀ {n} → Fin n → Fin n
reverse {suc n} zero    = fromℕ n
reverse {suc n} (suc x) = inject₁ (reverse {n} x)

open import Data.Nat
open import Data.Nat.Properties
open import Data.Fin.Props renaming (reverse to reverse-old)

reverse-fromℕ : ∀ n → reverse (fromℕ n) ≡ zero
reverse-fromℕ zero = refl
reverse-fromℕ (suc n) rewrite reverse-fromℕ n = refl

reverse-inject₁ : ∀ {n} (x : Fin n) → reverse (inject₁ x) ≡ suc (reverse x)
reverse-inject₁ zero = refl
reverse-inject₁ (suc x) rewrite reverse-inject₁ x = refl

{-
reverse-involutive : ∀ {n} (x : Fin n) → reverse (reverse x) ≡ x
reverse-involutive zero = reverse-fromℕ _
reverse-involutive (suc x) rewrite reverse-inject₁ (reverse x) | reverse-involutive x = refl
-}

reverse-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-lem zero = to-from _
reverse-lem (suc x) rewrite inject₁-lemma (reverse x) = reverse-lem x

Fin▹ℕ-ℕ-lem : ∀ {n} (x : Fin (suc n)) → Fin▹ℕ (n ℕ- x) ≡ n ∸ Fin▹ℕ x
Fin▹ℕ-ℕ-lem zero = to-from _
Fin▹ℕ-ℕ-lem {zero} (suc ())
Fin▹ℕ-ℕ-lem {suc n} (suc x) = Fin▹ℕ-ℕ-lem x

reverse-old-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse-old x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-old-lem {zero} ()
reverse-old-lem {suc n} x rewrite inject≤-lemma (n ℕ- x) (n∸m≤n (Fin▹ℕ x) (suc n)) = Fin▹ℕ-ℕ-lem x

data FinView {n} : Fin (suc n) → ★₀ where
  `fromℕ   : FinView (fromℕ n)
  `inject₁ : ∀ x → FinView (inject₁ x)

sucFinView : ∀ {n} {i : Fin (suc n)} → FinView i → FinView (suc i)
sucFinView `fromℕ = `fromℕ
sucFinView (`inject₁ x) = `inject₁ (suc x)

finView : ∀ {n} → (i : Fin (suc n)) → FinView i
finView {zero}  zero    = `fromℕ
finView {suc n} zero    = `inject₁ zero
finView {suc n} (suc i) = sucFinView (finView i)
finView {zero}  (suc ())

module Modulo where
  modq : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq {zero}  _       = nothing
  modq {suc q} zero    = just zero
  modq {suc q} (suc x) = map? suc (modq x)

  modq-inj : ∀ {q} (i j : Fin (suc q)) → modq i ≡ modq j → i ≡ j
  modq-inj {zero} zero zero eq = refl
  modq-inj {zero} zero (suc ()) eq
  modq-inj {zero} (suc ()) zero eq
  modq-inj {zero} (suc ()) (suc ()) eq
  modq-inj {suc q} zero zero eq = refl
  modq-inj {suc q} zero (suc j) eq with modq j
  modq-inj {suc q} zero (suc j) () | nothing
  modq-inj {suc q} zero (suc j) () | just j'
  modq-inj {suc q} (suc i) zero eq with modq i
  modq-inj {suc q} (suc i) zero () | just x
  modq-inj {suc q} (suc i) zero () | nothing
  modq-inj {suc q} (suc i) (suc j) eq with modq i | modq j | modq-inj i j
  modq-inj {suc q} (suc i) (suc j) eq | just x | just x₁ | p = cong suc (p (cong just (suc-injective (just-injective eq))))
  modq-inj {suc q} (suc i) (suc j) () | just x | nothing | p
  modq-inj {suc q} (suc i) (suc j) () | nothing | just x | p
  modq-inj {suc q} (suc i) (suc j) eq | nothing | nothing | p = cong suc (p refl)

  modq′ : ∀ {q} → Fin (suc q) → Fin (suc q)
  modq′ {zero}  _       = zero
  modq′ {suc q} zero    = suc zero
  modq′ {suc q} (suc x) = lift 1 suc (modq′ x)

  modqq : ∀ {q} → Fin q → Fin q
  modqq {zero}  x = x
  modqq {suc q} x = modq′ x

  -- Maybe (Fin n) ≅ Fin (suc n)

  modq′′ : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq′′ x with modq′ x
  ... | zero  = nothing
  ... | suc y = just y

  zero∃ : ∀ {q} → Fin q → Fin q
  zero∃ {zero}  ()
  zero∃ {suc q} _  = zero

  sucmod : ∀ {q} → Fin q → Fin q
  sucmod x with modq (suc x)
  ... | nothing = zero∃ x
  ... | just y  = y

  modq-suc : ∀ {q} (i j : Fin q) → modq (suc i) ≢ just (zero∃ j)
  modq-suc {zero} () () eq
  modq-suc {suc q} i j eq with modq i
  modq-suc {suc q} i j () | just x
  modq-suc {suc q} i j () | nothing

  sucmod-inj : ∀ {q}{i j : Fin q} → sucmod i ≡ sucmod j → i ≡ j
  sucmod-inj {i = i} {j} eq with modq (suc i) | modq (suc j) | modq-inj (suc i) (suc j) | modq-suc i j | modq-suc j i
  sucmod-inj eq | just _  | just _  | p | _ | _ = suc-injective (p (cong just eq))
  sucmod-inj eq | nothing | nothing | p | _ | _ = suc-injective (p refl)
  sucmod-inj eq | just _  | nothing | _ | p | _ = 𝟘-elim (p (cong Maybe.just eq))
  sucmod-inj eq | nothing | just _  | _ | _ | p = 𝟘-elim (p (cong Maybe.just (sym eq)))

  modq-fromℕ : ∀ q → modq (fromℕ q) ≡ nothing
  modq-fromℕ zero = refl
  modq-fromℕ (suc q) rewrite modq-fromℕ q = refl

  modq-inject₁ : ∀ {q} (i : Fin q) → modq (inject₁ i) ≡ just i
  modq-inject₁ zero = refl
  modq-inject₁ (suc i) rewrite modq-inject₁ i = refl

  sucmod-fromℕ : ∀ q → sucmod (fromℕ q) ≡ zero
  sucmod-fromℕ q rewrite modq-fromℕ q = refl

  sucmod-inject₁ : ∀ {n} (i : Fin n) → sucmod (inject₁ i) ≡ suc i
  sucmod-inject₁ i rewrite modq-inject₁ i = refl

  lem-inject₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n) x → lookup (inject₁ i) (xs ∷ʳ x) ≡ lookup i xs
  lem-inject₁ zero    (x₀ ∷ xs) x₁ = refl
  lem-inject₁ (suc i) (x₀ ∷ xs) x₁ = lem-inject₁ i xs x₁

  lem-fromℕ : ∀ {n a} {A : ★ a} (xs : Vec A n) x → lookup (fromℕ n) (xs ∷ʳ x) ≡ x
  lem-fromℕ {zero}  []       x = refl
  lem-fromℕ {suc n} (_ ∷ xs) x = lem-fromℕ xs x

  lookup-sucmod : ∀ {n a} {A : ★ a} (i : Fin (suc n)) (x : A) xs
                 → lookup i (xs ∷ʳ x) ≡ lookup (sucmod i) (x ∷ xs)
  lookup-sucmod i x xs with finView i
  lookup-sucmod {n} .(fromℕ n) x xs | `fromℕ rewrite sucmod-fromℕ n = lem-fromℕ xs x
  lookup-sucmod .(inject₁ x) x₁ xs | `inject₁ x rewrite sucmod-inject₁ x = lem-inject₁ x xs x₁

  lookup-map : ∀ {n a b} {A : ★ a} {B : ★ b} (f : A → B) i (xs : Vec A n)
               → lookup i (vmap f xs) ≡ f (lookup i xs)
  lookup-map f zero    (x ∷ xs) = refl
  lookup-map f (suc i) (x ∷ xs) = lookup-map f i xs

  vec≗⇒≡ : ∀ {n a} {A : ★ a} (xs ys : Vec A n) → flip lookup xs ≗ flip lookup ys → xs ≡ ys
  vec≗⇒≡ []       []       _ = refl
  vec≗⇒≡ (x ∷ xs) (y ∷ ys) p rewrite vec≗⇒≡ xs ys (p ∘ suc) | p zero = refl

  -- most likely this is subsumed by the StableUnderInjection parts
  private
     module Unused where
        lookup-sucmod-rot₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n)
                       → lookup i (rot₁ xs) ≡ lookup (sucmod i) xs
        lookup-sucmod-rot₁ {zero} () xs
        lookup-sucmod-rot₁ {suc n} i (x ∷ xs) = lookup-sucmod i x xs

        lookup-rot₁-allFin : ∀ {n} i → lookup i (rot₁ (allFin n)) ≡ lookup i (vmap sucmod (allFin n))
        lookup-rot₁-allFin {n} i rewrite lookup-sucmod-rot₁ i (allFin _)
                                       | Vec.lookup-allFin (sucmod i)
                                       | lookup-map sucmod i (allFin n)
                                       | Vec.lookup∘tabulate id i
                                       = refl

        rot₁-map-sucmod : ∀ n → rot₁ (allFin n) ≡ vmap sucmod (allFin n)
        rot₁-map-sucmod _ = vec≗⇒≡ _ _ lookup-rot₁-allFin

  {-

  -- -}
  -- -}
  -- -}
  -- -}
  -- -}

-- NOTE with-K
module Data.Fin.NP where

open import Type hiding (★)
open import Function
open import Data.Zero
open import Data.One
open import Data.Fin public renaming (toℕ to Fin▹ℕ)
open import Data.Nat.NP using (ℕ; zero; suc; _<=_; module ℕ°) renaming (_+_ to _+ℕ_)
open import Data.Two hiding (_==_)
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup; rot₁) renaming (map to vmap)
import Data.Vec.Properties as Vec
open import Data.Maybe.NP
open import Data.Sum as Sum
open import Relation.Binary.PropositionalEquality as ≡

suc-injective : ∀ {m}{i j : Fin m} → Fin.suc i ≡ suc j → i ≡ j
suc-injective refl = refl

-- The isomorphisms about Fin, 𝟘, 𝟙, 𝟚 are in Function.Related.TypeIsomorphisms.NP

Fin▹𝟘 : Fin 0 → 𝟘
Fin▹𝟘 ()

𝟘▹Fin : 𝟘 → Fin 0
𝟘▹Fin ()

Fin▹𝟙 : Fin 1 → 𝟙
Fin▹𝟙 _ = _

𝟙▹Fin : 𝟙 → Fin 1
𝟙▹Fin _ = zero

Fin▹𝟚 : Fin 2 → 𝟚
Fin▹𝟚 zero    = 0₂
Fin▹𝟚 (suc _) = 1₂

𝟚▹Fin : 𝟚 → Fin 2
𝟚▹Fin = [0: # 0 1: # 1 ]

_+′_ : ∀ {m n} (x : Fin m) (y : Fin n) → Fin (m +ℕ n)
_+′_ {suc m} {n} zero y rewrite ℕ°.+-comm (suc m) n = inject+ _ y
suc x +′ y = suc (x +′ y)

_==_ : ∀ {n} (x y : Fin n) → 𝟚
x == y = helper (compare x y) where
  helper : ∀ {n} {i j : Fin n} → Ordering i j → 𝟚
  helper (equal _) = 1₂
  helper _         = 0₂

swap : ∀ {i} (x y : Fin i) → Fin i → Fin i
swap x y z = case x == z 0: (case y == z 0: z 1: x) 1: y

data FinSum m n : Fin (m +ℕ n) → ★₀ where
  bound : (x : Fin m) → FinSum m n (inject+ n x)
  free  : (x : Fin n) → FinSum m n (raise m x)

open import Relation.Binary.PropositionalEquality

cmp : ∀ m n (x : Fin (m +ℕ n)) → FinSum m n x
cmp zero n x = free x
cmp (suc m) n zero = bound zero
cmp (suc m) n (suc x) with cmp m n x
cmp (suc m) n (suc .(inject+ n x)) | bound x = bound (suc x)
cmp (suc m) n (suc .(raise m x))   | free x  = free x

max : ∀ n → Fin (suc n)
max = fromℕ

-- reverse x = n ∸ (1 + x)
reverse : ∀ {n} → Fin n → Fin n
reverse {suc n} zero    = fromℕ n
reverse {suc n} (suc x) = inject₁ (reverse {n} x)

open import Data.Nat
open import Data.Nat.Properties
open import Data.Fin.Props renaming (reverse to reverse-old)

reverse-fromℕ : ∀ n → reverse (fromℕ n) ≡ zero
reverse-fromℕ zero = refl
reverse-fromℕ (suc n) rewrite reverse-fromℕ n = refl

reverse-inject₁ : ∀ {n} (x : Fin n) → reverse (inject₁ x) ≡ suc (reverse x)
reverse-inject₁ zero = refl
reverse-inject₁ (suc x) rewrite reverse-inject₁ x = refl

{-
reverse-involutive : ∀ {n} (x : Fin n) → reverse (reverse x) ≡ x
reverse-involutive zero = reverse-fromℕ _
reverse-involutive (suc x) rewrite reverse-inject₁ (reverse x) | reverse-involutive x = refl
-}

reverse-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-lem zero = to-from _
reverse-lem (suc x) rewrite inject₁-lemma (reverse x) = reverse-lem x

Fin▹ℕ-ℕ-lem : ∀ {n} (x : Fin (suc n)) → Fin▹ℕ (n ℕ- x) ≡ n ∸ Fin▹ℕ x
Fin▹ℕ-ℕ-lem zero = to-from _
Fin▹ℕ-ℕ-lem {zero} (suc ())
Fin▹ℕ-ℕ-lem {suc n} (suc x) = Fin▹ℕ-ℕ-lem x

reverse-old-lem : ∀ {n} (x : Fin n) → Fin▹ℕ (reverse-old x) ≡ n ∸ suc (Fin▹ℕ x)
reverse-old-lem {zero} ()
reverse-old-lem {suc n} x rewrite inject≤-lemma (n ℕ- x) (n∸m≤n (Fin▹ℕ x) (suc n)) = Fin▹ℕ-ℕ-lem x

data FinView {n} : Fin (suc n) → ★₀ where
  `fromℕ   : FinView (fromℕ n)
  `inject₁ : ∀ x → FinView (inject₁ x)

sucFinView : ∀ {n} {i : Fin (suc n)} → FinView i → FinView (suc i)
sucFinView `fromℕ = `fromℕ
sucFinView (`inject₁ x) = `inject₁ (suc x)

finView : ∀ {n} → (i : Fin (suc n)) → FinView i
finView {zero}  zero    = `fromℕ
finView {suc n} zero    = `inject₁ zero
finView {suc n} (suc i) = sucFinView (finView i)
finView {zero}  (suc ())

module Modulo where
  modq : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq {zero}  _       = nothing
  modq {suc q} zero    = just zero
  modq {suc q} (suc x) = map? suc (modq x)

  modq-inj : ∀ {q} (i j : Fin (suc q)) → modq i ≡ modq j → i ≡ j
  modq-inj {zero} zero zero eq = refl
  modq-inj {zero} zero (suc ()) eq
  modq-inj {zero} (suc ()) zero eq
  modq-inj {zero} (suc ()) (suc ()) eq
  modq-inj {suc q} zero zero eq = refl
  modq-inj {suc q} zero (suc j) eq with modq j
  modq-inj {suc q} zero (suc j) () | nothing
  modq-inj {suc q} zero (suc j) () | just j'
  modq-inj {suc q} (suc i) zero eq with modq i
  modq-inj {suc q} (suc i) zero () | just x
  modq-inj {suc q} (suc i) zero () | nothing
  modq-inj {suc q} (suc i) (suc j) eq with modq i | modq j | modq-inj i j
  modq-inj {suc q} (suc i) (suc j) eq | just x | just x₁ | p = cong suc (p (cong just (suc-injective (just-injective eq))))
  modq-inj {suc q} (suc i) (suc j) () | just x | nothing | p
  modq-inj {suc q} (suc i) (suc j) () | nothing | just x | p
  modq-inj {suc q} (suc i) (suc j) eq | nothing | nothing | p = cong suc (p refl)

  modq′ : ∀ {q} → Fin (suc q) → Fin (suc q)
  modq′ {zero}  _       = zero
  modq′ {suc q} zero    = suc zero
  modq′ {suc q} (suc x) = lift 1 suc (modq′ x)

  modqq : ∀ {q} → Fin q → Fin q
  modqq {zero}  x = x
  modqq {suc q} x = modq′ x

  -- Maybe (Fin n) ≅ Fin (suc n)

  modq′′ : ∀ {q} → Fin (suc q) → Maybe (Fin q)
  modq′′ x with modq′ x
  ... | zero  = nothing
  ... | suc y = just y

  zero∃ : ∀ {q} → Fin q → Fin q
  zero∃ {zero}  ()
  zero∃ {suc q} _  = zero

  sucmod : ∀ {q} → Fin q → Fin q
  sucmod x with modq (suc x)
  ... | nothing = zero∃ x
  ... | just y  = y

  modq-suc : ∀ {q} (i j : Fin q) → modq (suc i) ≢ just (zero∃ j)
  modq-suc {zero} () () eq
  modq-suc {suc q} i j eq with modq i
  modq-suc {suc q} i j () | just x
  modq-suc {suc q} i j () | nothing

  sucmod-inj : ∀ {q}{i j : Fin q} → sucmod i ≡ sucmod j → i ≡ j
  sucmod-inj {i = i} {j} eq with modq (suc i) | modq (suc j) | modq-inj (suc i) (suc j) | modq-suc i j | modq-suc j i
  sucmod-inj eq | just _  | just _  | p | _ | _ = suc-injective (p (cong just eq))
  sucmod-inj eq | nothing | nothing | p | _ | _ = suc-injective (p refl)
  sucmod-inj eq | just _  | nothing | _ | p | _ = 𝟘-elim (p (cong Maybe.just eq))
  sucmod-inj eq | nothing | just _  | _ | _ | p = 𝟘-elim (p (cong Maybe.just (sym eq)))

  modq-fromℕ : ∀ q → modq (fromℕ q) ≡ nothing
  modq-fromℕ zero = refl
  modq-fromℕ (suc q) rewrite modq-fromℕ q = refl

  modq-inject₁ : ∀ {q} (i : Fin q) → modq (inject₁ i) ≡ just i
  modq-inject₁ zero = refl
  modq-inject₁ (suc i) rewrite modq-inject₁ i = refl

  sucmod-fromℕ : ∀ q → sucmod (fromℕ q) ≡ zero
  sucmod-fromℕ q rewrite modq-fromℕ q = refl

  sucmod-inject₁ : ∀ {n} (i : Fin n) → sucmod (inject₁ i) ≡ suc i
  sucmod-inject₁ i rewrite modq-inject₁ i = refl

  lem-inject₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n) x → lookup (inject₁ i) (xs ∷ʳ x) ≡ lookup i xs
  lem-inject₁ zero    (x₀ ∷ xs) x₁ = refl
  lem-inject₁ (suc i) (x₀ ∷ xs) x₁ = lem-inject₁ i xs x₁

  lem-fromℕ : ∀ {n a} {A : ★ a} (xs : Vec A n) x → lookup (fromℕ n) (xs ∷ʳ x) ≡ x
  lem-fromℕ {zero}  []       x = refl
  lem-fromℕ {suc n} (_ ∷ xs) x = lem-fromℕ xs x

  lookup-sucmod : ∀ {n a} {A : ★ a} (i : Fin (suc n)) (x : A) xs
                 → lookup i (xs ∷ʳ x) ≡ lookup (sucmod i) (x ∷ xs)
  lookup-sucmod i x xs with finView i
  lookup-sucmod {n} .(fromℕ n) x xs | `fromℕ rewrite sucmod-fromℕ n = lem-fromℕ xs x
  lookup-sucmod .(inject₁ x) x₁ xs | `inject₁ x rewrite sucmod-inject₁ x = lem-inject₁ x xs x₁

  lookup-map : ∀ {n a b} {A : ★ a} {B : ★ b} (f : A → B) i (xs : Vec A n)
               → lookup i (vmap f xs) ≡ f (lookup i xs)
  lookup-map f zero    (x ∷ xs) = refl
  lookup-map f (suc i) (x ∷ xs) = lookup-map f i xs

  vec≗⇒≡ : ∀ {n a} {A : ★ a} (xs ys : Vec A n) → flip lookup xs ≗ flip lookup ys → xs ≡ ys
  vec≗⇒≡ []       []       _ = refl
  vec≗⇒≡ (x ∷ xs) (y ∷ ys) p rewrite vec≗⇒≡ xs ys (p ∘ suc) | p zero = refl

  -- most likely this is subsumed by the StableUnderInjection parts
  private
     module Unused where
        lookup-sucmod-rot₁ : ∀ {n a} {A : ★ a} (i : Fin n) (xs : Vec A n)
                       → lookup i (rot₁ xs) ≡ lookup (sucmod i) xs
        lookup-sucmod-rot₁ {zero} () xs
        lookup-sucmod-rot₁ {suc n} i (x ∷ xs) = lookup-sucmod i x xs

        lookup-rot₁-allFin : ∀ {n} i → lookup i (rot₁ (allFin n)) ≡ lookup i (vmap sucmod (allFin n))
        lookup-rot₁-allFin {n} i rewrite lookup-sucmod-rot₁ i (allFin _)
                                       | Vec.lookup-allFin (sucmod i)
                                       | lookup-map sucmod i (allFin n)
                                       | Vec.lookup∘tabulate id i
                                       = refl

        rot₁-map-sucmod : ∀ n → rot₁ (allFin n) ≡ vmap sucmod (allFin n)
        rot₁-map-sucmod _ = vec≗⇒≡ _ _ lookup-rot₁-allFin

  {-

  -- -}
  -- -}
  -- -}
  -- -}
  -- -}


Vec: unconvincing experiment with reverse

module Data.Vec.NP where

open import Data.Vec public hiding (_⊛_; zipWith; zip; map)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
import Data.Fin.Props as F
open import Data.Bool
open import Data.Product hiding (map; zip)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

open waiting-for-a-fix-in-the-stdlib public

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-aux : ∀ {a} {A : Set a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Set a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                  | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                  | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

module Data.Vec.NP where

open import Data.Vec public hiding (_⊛_; zipWith; zip; map)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product hiding (map; zip)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

open waiting-for-a-fix-in-the-stdlib public

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite inject₁-lemma (countᶠ pred (map f xs))
                  | inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite inject₁-lemma (countᶠ pred (xs ++ ys))
                  | inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)


Added thesis' examples.

Added thesis' examples.

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

module LogicalFramework.AdequacyTheorems where

module Example5 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁    : A → C
    f₂    : B → C

  g : (A → C) → (B → C) → A ∨ B → C
  g f₁ f₂ (inj₁ a) = f₁ a
  g f₁ f₂ (inj₂ b) = f₂ b

  g' : (A → C) → (B → C) → A ∨ B → C
  g' f₁ f₂ x = case f₁ f₂ x

module Example7 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    C  : D → D → Set
    d  : ∀ {a} → C a a

  g : ∀ {a b} → a ≡ b → C a b
  g refl = d

  g' : ∀ {a b} → a ≡ b → C a b
  g' {a} h = subst (λ x → C a x) h d

module Example10 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁ : A → C
    f₂ : B → C

  f : A ∨ B → C
  f (inj₁ a) = f₁ a
  f (inj₂ b) = f₂ b

  f' : A ∨ B → C
  f' = case f₁ f₂

module Example20 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  f : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f {A} {t} {.t} refl At = d At
    where
    postulate d : A t → A t

  f' : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f' {A} h At = subst A h At

module Example30 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C E : Set
    f₁ : A → E
    f₂ : B → E
    f₃ : C → E

  g : (A ∨ B) ∨ C → E
  g (inj₁ (inj₁ a)) = f₁ a
  g (inj₁ (inj₂ b)) = f₂ b
  g (inj₂ c)        = f₃ c

  g' : (A ∨ B) ∨ C → E
  g' = case (case f₁ f₂) f₃

module Example40 where

  infixl 9  _+_ _+'_
  infix  7  _≡_

  data M : Set where
    zero :     M
    succ : M → M

  PA-ind : (A : M → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  PA-ind A A0 h zero     = A0
  PA-ind A A0 h (succ n) = h n (PA-ind A A0 h n)

  data _≡_ (x : M) : M → Set where
    refl : x ≡ x

  subst : (A : M → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A refl Ax = Ax

  _+_ : M → M → M
  zero   + n = n
  succ m + n = succ (m + n)

  _+'_ : M → M → M
  m +' n = PA-ind (λ _ → M) n (λ x y → succ y) m

  -- Properties using pattern matching.
  succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong refl = refl

  +-rightIdentity : ∀ n → n + zero ≡ n
  +-rightIdentity zero     = refl
  +-rightIdentity (succ n) = succCong (+-rightIdentity n)

  -- Properties using the basic inductive constants.
  succCong' : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong' {m} h = subst (λ x → succ m ≡ succ x) h refl

  +'-leftIdentity : ∀ n → zero +' n ≡ n
  +'-leftIdentity n = refl

  +'-rightIdentity : ∀ n → n +' zero ≡ n
  +'-rightIdentity = PA-ind A A0 is
    where
    A : M → Set
    A n = n +' zero ≡ n

    A0 : A zero
    A0 = refl

    is : ∀ n → A n → A (succ n)
    is n ih = succCong' ih

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

module LogicalFramework.AdequacyTheorems where

module Example10 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁ : A → C
    f₂ : B → C

  f : A ∨ B → C
  f (inj₁ a) = f₁ a
  f (inj₂ b) = f₂ b

  f' : A ∨ B → C
  f' = case f₁ f₂

module Example20 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  f : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f {A} {t} {.t} refl At = d At
    where
    postulate d : A t → A t

  f' : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f' {A} h At = subst A h At

module Example30 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C E : Set
    f₁ : A → E
    f₂ : B → E
    f₃ : C → E

  f : (A ∨ B) ∨ C → E
  f (inj₁ (inj₁ a)) = f₁ a
  f (inj₁ (inj₂ b)) = f₂ b
  f (inj₂ c)        = f₃ c

  f' : (A ∨ B) ∨ C → E
  f' = case (case f₁ f₂) f₃

module Example40 where

  infixl 9  _+_ _+'_
  infix  7  _≡_

  data M : Set where
    zero :     M
    succ : M → M

  PA-ind : (A : M → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  PA-ind A A0 h zero     = A0
  PA-ind A A0 h (succ n) = h n (PA-ind A A0 h n)

  data _≡_ (x : M) : M → Set where
    refl : x ≡ x

  subst : (A : M → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A refl Ax = Ax

  _+_ : M → M → M
  zero   + n = n
  succ m + n = succ (m + n)

  _+'_ : M → M → M
  m +' n = PA-ind (λ _ → M) n (λ x y → succ y) m

  -- Properties using pattern matching.
  succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong refl = refl

  +-rightIdentity : ∀ n → n + zero ≡ n
  +-rightIdentity zero     = refl
  +-rightIdentity (succ n) = succCong (+-rightIdentity n)

  -- Properties using the basic inductive constants.
  succCong' : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong' {m} h = subst (λ x → succ m ≡ succ x) h refl

  +'-leftIdentity : ∀ n → zero +' n ≡ n
  +'-leftIdentity n = refl

  +'-rightIdentity : ∀ n → n +' zero ≡ n
  +'-rightIdentity = PA-ind A A0 is
    where
    A : M → Set
    A n = n +' zero ≡ n

    A0 : A zero
    A0 = refl

    is : ∀ n → A n → A (succ n)
    is n ih = succCong' ih


scraps

scraps

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import structural

module lemmas-subst-ta where
  lem-subst-σ : ∀{Δ x Γ τ1 σ Γ' d } →
                  Δ , Γ ,, (x , τ1) ⊢ σ :s: Γ' →
                  Δ , Γ ⊢ d :: τ1 →
                  Δ , Γ ⊢ Subst d x σ :s: Γ'
  lem-subst-σ s wt = STASubst s wt

  -- todo: i'm worried this may actually be false without knowing that x ≠
  -- y, but that's kind of what we usually mean on paper anyway
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y xy = tr (λ qq → Δ , qq ⊢ σ :s: Γ') (funext swap) xy
    where
      swap : (z : Nat) → (Γ ,, (x , τ1) ,, (y , τ2)) z == (Γ ,, (y , τ2) ,, (x , τ1)) z
      swap = {!!}

  mutual
    data envfresh : Nat → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y
                           → envfresh x (Subst d y σ)

    data fresh : Nat → dhexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇ d ⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     envfresh x σ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) )
    weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) =
      STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst))
               (weaken-ta x₁ x₃)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →  -- x # Γ ?
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-parts Γ _ _ x₄ (apart-singleton (flip x₁)))
                                                                              {!weaken-ta {Γ = Γ ,, (y , ?)} x₃ wt!}
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃)
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃)
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃

  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
                  x # Γ →
                  Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
                  Δ , Γ ⊢ d2 :: τ1 →
                  Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst apt TAConst wt2 = TAConst
  lem-subst {x = x} apt (TAVar {x = x'} x₂) wt2 with natEQ x' x
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃
  lem-subst apt (TAVar x₃) wt2 | Inl refl | refl = wt2
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃)
  lem-subst {Γ = Γ} {x = x} apt (TALam  {x = y} x₂ wt1) wt2 -- = {!weaken-ta ? (TALam x₂ wt1)!}
    with natEQ y x
  lem-subst {Γ = Γ} {x = x} apt (TALam x₃ wt1) wt2 | Inl refl = abort ((π1(lem-union-none {Γ = Γ} x₃)) refl)
  lem-subst {Γ = Γ} apt (TALam x₃ wt1) wt2 | Inr x₂
    with lem-union-none {Γ = Γ} x₃ -- | lem-subst apt wt1  -- probably not the straight IH; need to weaken
  ... | neq , r =  {!!} --  TALam r (lem-subst {!!} (weaken-ta {!!} {!!}) (weaken-ta r wt2))
  lem-subst apt (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt wt1 wt3) (lem-subst apt wt2 wt3)
  lem-subst apt (TAEHole inΔ sub) wt2 = TAEHole inΔ (lem-subst-σ sub wt2)
  lem-subst apt (TANEHole x₁ wt1 x₂) wt2 = TANEHole x₁ (lem-subst apt wt1 wt2) (lem-subst-σ  x₂ wt2)
  lem-subst apt (TACast wt1 x₁) wt2 = TACast (lem-subst apt wt1 wt2) x₁
  lem-subst apt (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt wt1 wt2) x₁ x₂ x₃

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import structural

module lemmas-subst-ta where
  lem-subst-σ : ∀{Δ x Γ τ1 σ Γ' d } →
                  Δ , Γ ,, (x , τ1) ⊢ σ :s: Γ' →
                  Δ , Γ ⊢ d :: τ1 →
                  Δ , Γ ⊢ Subst d x σ :s: Γ'
  lem-subst-σ s wt = STASubst s wt

  -- todo: i'm worried this may actually be false without knowing that x ≠
  -- y, but that's kind of what we usually mean on paper anyway
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y xy = tr (λ qq → Δ , qq ⊢ σ :s: Γ') (funext swap) xy
    where
      swap : (z : Nat) → (Γ ,, (x , τ1) ,, (y , τ2)) z == (Γ ,, (y , τ2) ,, (x , τ1)) z
      swap = {!!}

  mutual
    data envfresh : Nat → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y
                           → envfresh x (Subst d y σ)

    data fresh : Nat → dhexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇ d ⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     envfresh x σ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) )
    weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) =
      STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst))
               (weaken-ta x₁ x₃)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →  -- x # Γ ?
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-parts Γ _ _ x₄ (apart-singleton (flip x₁))) (weaken-ta {Γ = {!■ (y , ? )!} ∪ Γ} x₃ wt)
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃)
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃)
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃

  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
                  x # Γ →
                  Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
                  Δ , Γ ⊢ d2 :: τ1 →
                  Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst apt TAConst wt2 = TAConst
  lem-subst {x = x} apt (TAVar {x = x'} x₂) wt2 with natEQ x' x
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃
  lem-subst apt (TAVar x₃) wt2 | Inl refl | refl = wt2
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃)
  lem-subst {Γ = Γ} {x = x} apt (TALam  {x = y} x₂ wt1) wt2 -- = {!weaken-ta ? (TALam x₂ wt1)!}
    with natEQ y x
  lem-subst {Γ = Γ} {x = x} apt (TALam x₃ wt1) wt2 | Inl refl = abort ((π1(lem-union-none {Γ = Γ} x₃)) refl)
  lem-subst {Γ = Γ} apt (TALam x₃ wt1) wt2 | Inr x₂
    with lem-union-none {Γ = Γ} x₃ -- | lem-subst apt wt1  -- probably not the straight IH; need to weaken
  ... | neq , r =  {!!} --  TALam r (lem-subst {!!} (weaken-ta {!!} {!!}) (weaken-ta r wt2))
  lem-subst apt (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt wt1 wt3) (lem-subst apt wt2 wt3)
  lem-subst apt (TAEHole inΔ sub) wt2 = TAEHole inΔ (lem-subst-σ sub wt2)
  lem-subst apt (TANEHole x₁ wt1 x₂) wt2 = TANEHole x₁ (lem-subst apt wt1 wt2) (lem-subst-σ  x₂ wt2)
  lem-subst apt (TACast wt1 x₁) wt2 = TACast (lem-subst apt wt1 wt2) x₁
  lem-subst apt (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt wt1 wt2) x₁ x₂ x₃


Add doc.

Add doc.

Ignore-this: 88c8569ac71a4dadfb6bb8be36321c8f

darcs-hash:20110102201203-3bd4e-b02ac257d8d12f84b6f4a78bf73e3b3c41da75c1.gz

------------------------------------------------------------------------------
-- Closures properties respect to OrdList (flatten-OrdList-aux)
------------------------------------------------------------------------------

-- Agda bug? The recursive calls in flatten-OrdList-aux are
-- structurally smaller, so it is not clear why we need the option
-- --no-termination-check. We tested the option --termination-depth=N
-- with some values, but it had no effect.
{-# OPTIONS --no-termination-check #-}

module LTC.Program.SortList.Properties.Closures.OrdList.FlattenI where

open import LTC.Base

-- open import Common.Function

open import LTC.Data.Bool
open import LTC.Data.Bool.PropertiesI
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesI
open import LTC.Data.Nat.Type
open import LTC.Data.List

open import LTC.Program.SortList.Properties.Closures.BoolI
open import LTC.Program.SortList.Properties.Closures.ListN-I
open import LTC.Program.SortList.Properties.Closures.OrdTreeI
open import LTC.Program.SortList.Properties.MiscellaneousI
open import LTC.Program.SortList.SortList

open import LTC.Relation.Binary.EqReasoning

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

flatten-OrdList-aux : {t₁ i t₂ : D} → Tree t₁ → N i → Tree t₂ →
                      OrdTree (node t₁ i t₂) →
                      LE-Lists (flatten t₁) (flatten t₂)

flatten-OrdList-aux {t₂ = t₂} nilT Ni Tt₂ OTt =
  subst (λ t → LE-Lists t (flatten t₂))
        (sym (flatten-nilTree))
        (≤-Lists-[] (flatten t₂))

flatten-OrdList-aux (tipT {i₁} Ni₁) _ nilT OTt =
  begin
    ≤-Lists (flatten (tip i₁)) (flatten nilTree)
      ≡⟨ subst₂ (λ x₁ x₂ → ≤-Lists (flatten (tip i₁)) (flatten nilTree) ≡
                           ≤-Lists x₁ x₂)
                (flatten-tip i₁)
                flatten-nilTree
                refl
      ⟩
    ≤-Lists (i₁ ∷ []) []
      ≡⟨ ≤-Lists-∷ i₁ [] [] ⟩
    ≤-ItemList i₁ [] && ≤-Lists [] []
      ≡⟨ subst₂ (λ x₁ x₂ → ≤-ItemList i₁ [] && ≤-Lists [] [] ≡ x₁ && x₂ )
                (≤-ItemList-[] i₁)
                (≤-Lists-[] [])
                refl
      ⟩
    true && true
      ≡⟨ &&-tt ⟩
    true
  ∎

flatten-OrdList-aux {i = i} (tipT {i₁} Ni₁) Ni (tipT {i₂} Ni₂) OTt =
  begin
    ≤-Lists (flatten (tip i₁)) (flatten (tip i₂))
      ≡⟨ subst₂ (λ x₁ x₂ → ≤-Lists (flatten (tip i₁)) (flatten (tip i₂)) ≡
                           ≤-Lists x₁ x₂)
                (flatten-tip i₁)
                (flatten-tip i₂)
                refl
      ⟩
    ≤-Lists (i₁ ∷ []) (i₂ ∷ [])
      ≡⟨ ≤-Lists-∷ i₁ [] (i₂ ∷ []) ⟩
    ≤-ItemList i₁ (i₂ ∷ []) && ≤-Lists [] (i₂ ∷ [])
      ≡⟨ subst (λ t → ≤-ItemList i₁ (i₂ ∷ []) && ≤-Lists [] (i₂ ∷ []) ≡
                      t && ≤-Lists [] (i₂ ∷ []))
               (≤-ItemList-∷ i₁ i₂ [])
               refl
      ⟩
    (i₁ ≤ i₂ && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ [])
      ≡⟨ subst (λ t → (i₁ ≤ i₂  && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ []) ≡
                      (t        && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ []))
               lemma
               refl
      ⟩
    (true && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ [])
      ≡⟨ subst₂ (λ x₁ x₂ → (true && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ []) ≡
                           (true && x₁)               && x₂)
                (≤-ItemList-[] i₁)
                (≤-Lists-[] (i₂ ∷ []))
                refl
      ⟩
    (true && true) && true
      ≡⟨ &&-assoc tB tB tB ⟩
    true && true && true
      ≡⟨ &&-true₃ ⟩
    true
  ∎
  where
    aux₁ : Bool (ordTree (tip i₁))
    aux₁ = ordTree-Bool (tipT Ni₁)

    aux₂ : Bool (ordTree (tip i₂))
    aux₂ = ordTree-Bool (tipT Ni₂)

    aux₃ : Bool (≤-TreeItem (tip i₁) i)
    aux₃ = ≤-TreeItem-Bool (tipT Ni₁) Ni

    aux₄ : Bool (≤-ItemTree i (tip i₂))
    aux₄ = ≤-ItemTree-Bool Ni (tipT Ni₂)

    aux₅ : ordTree (tip i₁) &&
           ordTree (tip i₂) &&
           ≤-TreeItem (tip i₁) i &&
           ≤-ItemTree i (tip i₂) ≡ true
    aux₅ = trans (sym (ordTree-node (tip i₁) i (tip i₂))) OTt

    lemma : LE i₁ i₂
    lemma = ≤-trans Ni₁ Ni Ni₂ i₁≤i i≤i₂
     where
       i₁≤i : LE i₁ i
       i₁≤i = trans (sym (≤-TreeItem-tip i₁ i))
                    (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

       i≤i₂ : LE i i₂
       i≤i₂ = trans (sym (≤-ItemTree-tip i i₂))
                    (&&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅)

flatten-OrdList-aux {i = i} (tipT {i₁} Ni₁) Ni
                    (nodeT {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt =
  begin
    ≤-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂))
      ≡⟨ subst (λ x → ≤-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂)) ≡
                      ≤-Lists (flatten (tip i₁)) x)
               (flatten-node t₂₁ i₂ t₂₂)
               refl
      ⟩
    ≤-Lists (flatten (tip i₁)) (flatten t₂₁ ++ flatten t₂₂)
      ≡⟨ xs≤ys→xs≤zs→xs≤ys++zs (flatten-ListN (tipT Ni₁))
                               (flatten-ListN Tt₂₁)
                               (flatten-ListN Tt₂₂)
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (tipT Ni₁)
    aux₂ = ordTree-Bool (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₃ = ≤-TreeItem-Bool (tipT Ni₁) Ni
    aux₄ = ≤-ItemTree-Bool Ni (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₅ = trans (sym (ordTree-node (tip i₁) i (node t₂₁ i₂ t₂₂))) OTt

    -- Auxiliary terms to get the conjuncts from the fourth conjunct of OTt.
    aux₆ = ≤-ItemTree-Bool Ni Tt₂₁
    aux₇ = ≤-ItemTree-Bool Ni Tt₂₂
    aux₈ = trans (sym (≤-ItemTree-node i t₂₁ i₂ t₂₂))
                 (&&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-tip-i₁ : OrdTree (tip i₁)
    OrdTree-tip-i₁ = &&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅

    LE-TreeItem-tip-i₁-i : LE-TreeItem (tip i₁) i
    LE-TreeItem-tip-i₁-i = &&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten (tip i₁)) (flatten t₂₁)
    lemma₁ = flatten-OrdList-aux (tipT Ni₁) Ni Tt₂₁ OT  -- IH.
      where
        OrdTree-t₂₁ : OrdTree t₂₁
        OrdTree-t₂₁ = leftSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂
                                          (&&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-ItemTree-i-t₂₁ : LE-ItemTree i t₂₁
        LE-ItemTree-i-t₂₁ = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node (tip i₁) i t₂₁)
        OT =
          begin
            ordTree (node (tip i₁) i t₂₁)
              ≡⟨ ordTree-node (tip i₁) i t₂₁ ⟩
            ordTree (tip i₁) &&
            ordTree t₂₁ &&
            ≤-TreeItem (tip i₁) i &&
            ≤-ItemTree i t₂₁
              ≡⟨ subst₄ (λ w x y z → ordTree (tip i₁) &&
                                     ordTree t₂₁ &&
                                     ≤-TreeItem (tip i₁) i &&
                                     ≤-ItemTree i t₂₁ ≡
                                     w && x && y && z)
                        OrdTree-tip-i₁
                        OrdTree-t₂₁
                        LE-TreeItem-tip-i₁-i
                        LE-ItemTree-i-t₂₁
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten (tip i₁)) (flatten t₂₂)
    lemma₂ = flatten-OrdList-aux (tipT Ni₁) Ni Tt₂₂ OT  -- IH.
      where
        OrdTree-t₂₂ : OrdTree t₂₂
        OrdTree-t₂₂ = rightSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂
                                           (&&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-ItemTree-i-t₂₂ : LE-ItemTree i t₂₂
        LE-ItemTree-i-t₂₂ = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node (tip i₁) i t₂₂)
        OT =
          begin
            ordTree (node (tip i₁) i t₂₂)
              ≡⟨ ordTree-node (tip i₁) i t₂₂ ⟩
            ordTree (tip i₁) &&
            ordTree t₂₂ &&
            ≤-TreeItem (tip i₁) i &&
            ≤-ItemTree i t₂₂
              ≡⟨ subst₄ (λ w x y z → ordTree (tip i₁) &&
                                     ordTree t₂₂ &&
                                     ≤-TreeItem (tip i₁) i &&
                                     ≤-ItemTree i t₂₂ ≡
                                     w && x && y && z)
                        OrdTree-tip-i₁
                        OrdTree-t₂₂
                        LE-TreeItem-tip-i₁-i
                        LE-ItemTree-i-t₂₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

flatten-OrdList-aux {i = i} (nodeT {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni nilT OTt =
  begin
    ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nilTree)
      ≡⟨ subst (λ x → ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nilTree) ≡
                      ≤-Lists x                           (flatten nilTree))
               (flatten-node t₁₁ i₁ t₁₂ )
               refl
      ⟩
    ≤-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten nilTree)
      ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                               (flatten-ListN Tt₁₂)
                               (flatten-ListN nilT)
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂)
    aux₂ = ordTree-Bool nilT
    aux₃ = ≤-TreeItem-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂) Ni
    aux₄ = ≤-ItemTree-Bool Ni nilT
    aux₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i nilTree )) OTt

    -- Auxiliary terms to get the conjuncts from the third conjunct of OTt.
    aux₆ = ≤-TreeItem-Bool Tt₁₁ Ni
    aux₇ = ≤-TreeItem-Bool Tt₁₂ Ni
    aux₈ = trans (sym (≤-TreeItem-node t₁₁ i₁ t₁₂ i))
                 (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    LE-ItemTree-i-niltree : LE-ItemTree i nilTree
    LE-ItemTree-i-niltree = &&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten t₁₁) (flatten nilTree)
    lemma₁ = flatten-OrdList-aux Tt₁₁ Ni nilT OT  -- IH.
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂
                              (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₁-i : LE-TreeItem t₁₁ i
        LE-TreeItem-t₁₁-i = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₁ i nilTree)
        OT =
          begin
            ordTree (node t₁₁ i nilTree )
              ≡⟨ ordTree-node t₁₁ i nilTree ⟩
            ordTree t₁₁ &&
            ordTree nilTree &&
            ≤-TreeItem t₁₁ i &&
            ≤-ItemTree i nilTree
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                     ordTree nilTree &&
                                     ≤-TreeItem t₁₁ i &&
                                     ≤-ItemTree i nilTree ≡
                                     w && x && y && z)
                        OrdTree-t₁₁
                        ordTree-nilTree
                        LE-TreeItem-t₁₁-i
                        LE-ItemTree-i-niltree
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten t₁₂) (flatten nilTree)
    lemma₂ = flatten-OrdList-aux Tt₁₂ Ni nilT OT  -- IH.
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₂-i : LE-TreeItem t₁₂ i
        LE-TreeItem-t₁₂-i = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₂ i nilTree)
        OT =
          begin
            ordTree (node t₁₂ i nilTree )
              ≡⟨ ordTree-node t₁₂ i nilTree ⟩
            ordTree t₁₂ &&
            ordTree nilTree &&
            ≤-TreeItem t₁₂ i &&
            ≤-ItemTree i nilTree
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                     ordTree nilTree &&
                                     ≤-TreeItem t₁₂ i &&
                                     ≤-ItemTree i nilTree ≡
                                     w && x && y && z)
                        OrdTree-t₁₂
                        ordTree-nilTree
                        LE-TreeItem-t₁₂-i
                        LE-ItemTree-i-niltree
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

flatten-OrdList-aux {i = i} (nodeT {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                    (tipT {i₂} Ni₂) OTt =
  begin
    ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂))
      ≡⟨ subst (λ x → ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂)) ≡
                      ≤-Lists x                           (flatten (tip i₂)))
               (flatten-node t₁₁ i₁ t₁₂ )
               refl
      ⟩
    ≤-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten (tip i₂))
      ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                               (flatten-ListN Tt₁₂)
                               (flatten-ListN (tipT Ni₂))
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂)
    aux₂ = ordTree-Bool (tipT Ni₂)
    aux₃ = ≤-TreeItem-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂) Ni
    aux₄ = ≤-ItemTree-Bool Ni (tipT Ni₂)
    aux₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (tip i₂))) OTt

    -- Auxiliary terms to get the conjuncts from the third conjunct of OTt.
    aux₆ = ≤-TreeItem-Bool Tt₁₁ Ni
    aux₇ = ≤-TreeItem-Bool Tt₁₂ Ni
    aux₈ = trans (sym (≤-TreeItem-node t₁₁ i₁ t₁₂ i))
                 (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-tip-i₂ : OrdTree (tip i₂)
    OrdTree-tip-i₂ = &&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅

    LE-ItemTree-i-tip-i₂ : LE-ItemTree i (tip i₂)
    LE-ItemTree-i-tip-i₂ = &&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten t₁₁) (flatten (tip i₂))
    lemma₁ = flatten-OrdList-aux Tt₁₁ Ni (tipT Ni₂) OT  -- IH.
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₁-i : LE-TreeItem t₁₁ i
        LE-TreeItem-t₁₁-i = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₁ i (tip i₂))
        OT =
          begin
            ordTree (node t₁₁ i (tip i₂) )
              ≡⟨ ordTree-node t₁₁ i (tip i₂) ⟩
            ordTree t₁₁ &&
            ordTree (tip i₂) &&
            ≤-TreeItem t₁₁ i &&
            ≤-ItemTree i (tip i₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                     ordTree (tip i₂) &&
                                     ≤-TreeItem t₁₁ i &&
                                     ≤-ItemTree i (tip i₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₁
                        OrdTree-tip-i₂
                        LE-TreeItem-t₁₁-i
                        LE-ItemTree-i-tip-i₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten t₁₂) (flatten (tip i₂))
    lemma₂ = flatten-OrdList-aux Tt₁₂ Ni (tipT Ni₂) OT  -- IH.
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₂-i : LE-TreeItem t₁₂ i
        LE-TreeItem-t₁₂-i = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₂ i (tip i₂))
        OT =
          begin
            ordTree (node t₁₂ i (tip i₂) )
              ≡⟨ ordTree-node t₁₂ i (tip i₂) ⟩
            ordTree t₁₂ &&
            ordTree (tip i₂) &&
            ≤-TreeItem t₁₂ i &&
            ≤-ItemTree i (tip i₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                     ordTree (tip i₂) &&
                                     ≤-TreeItem t₁₂ i &&
                                     ≤-ItemTree i (tip i₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₂
                        OrdTree-tip-i₂
                        LE-TreeItem-t₁₂-i
                        LE-ItemTree-i-tip-i₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

flatten-OrdList-aux {i = i} (nodeT {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                    (nodeT {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt =
  begin
    ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (node t₂₁ i₂ t₂₂))
      ≡⟨ subst (λ x → ≤-Lists (flatten (node t₁₁ i₁ t₁₂))
                              (flatten (node t₂₁ i₂ t₂₂)) ≡
                      ≤-Lists x (flatten (node t₂₁ i₂ t₂₂)))
               (flatten-node t₁₁ i₁ t₁₂ )
               refl
      ⟩
    ≤-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
      ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                               (flatten-ListN Tt₁₂)
                               (flatten-ListN (nodeT Tt₂₁ Ni₂ Tt₂₂))
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂)
    aux₂ = ordTree-Bool (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₃ = ≤-TreeItem-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂) Ni
    aux₄ = ≤-ItemTree-Bool Ni (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (node t₂₁ i₂ t₂₂))) OTt

    -- Auxiliary terms to get the conjuncts from the third conjunct of OTt.
    aux₆ = ≤-TreeItem-Bool Tt₁₁ Ni
    aux₇ = ≤-TreeItem-Bool Tt₁₂ Ni
    aux₈ = trans (sym (≤-TreeItem-node t₁₁ i₁ t₁₂ i))
                 (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-node-t₂₁-i₂-t₂₂ : OrdTree (node t₂₁ i₂ t₂₂)
    OrdTree-node-t₂₁-i₂-t₂₂ = &&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅

    LE-ItemTree-i-node-t₂₁-i₂-t₂₂ : LE-ItemTree i (node t₂₁ i₂ t₂₂)
    LE-ItemTree-i-node-t₂₁-i₂-t₂₂ = &&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten t₁₁) (flatten (node t₂₁ i₂ t₂₂))
    lemma₁ = flatten-OrdList-aux Tt₁₁ Ni (nodeT Tt₂₁ Ni₂ Tt₂₂) OT  -- IH.
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₁-i : LE-TreeItem t₁₁ i
        LE-TreeItem-t₁₁-i = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₁ i (node t₂₁ i₂ t₂₂))
        OT =
          begin
            ordTree (node t₁₁ i (node t₂₁ i₂ t₂₂) )
              ≡⟨ ordTree-node t₁₁ i (node t₂₁ i₂ t₂₂) ⟩
            ordTree t₁₁ &&
            ordTree (node t₂₁ i₂ t₂₂) &&
            ≤-TreeItem t₁₁ i &&
            ≤-ItemTree i (node t₂₁ i₂ t₂₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                     ordTree (node t₂₁ i₂ t₂₂) &&
                                     ≤-TreeItem t₁₁ i &&
                                     ≤-ItemTree i (node t₂₁ i₂ t₂₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₁
                        OrdTree-node-t₂₁-i₂-t₂₂
                        LE-TreeItem-t₁₁-i
                        LE-ItemTree-i-node-t₂₁-i₂-t₂₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
    lemma₂ = flatten-OrdList-aux Tt₁₂ Ni (nodeT Tt₂₁ Ni₂ Tt₂₂) OT  -- IH.
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₂-i : LE-TreeItem t₁₂ i
        LE-TreeItem-t₁₂-i = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₂ i (node t₂₁ i₂ t₂₂))
        OT =
          begin
            ordTree (node t₁₂ i (node t₂₁ i₂ t₂₂) )
              ≡⟨ ordTree-node t₁₂ i (node t₂₁ i₂ t₂₂) ⟩
            ordTree t₁₂ &&
            ordTree (node t₂₁ i₂ t₂₂) &&
            ≤-TreeItem t₁₂ i &&
            ≤-ItemTree i (node t₂₁ i₂ t₂₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                     ordTree (node t₂₁ i₂ t₂₂) &&
                                     ≤-TreeItem t₁₂ i &&
                                     ≤-ItemTree i (node t₂₁ i₂ t₂₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₂
                        OrdTree-node-t₂₁-i₂-t₂₂
                        LE-TreeItem-t₁₂-i
                        LE-ItemTree-i-node-t₂₁-i₂-t₂₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

------------------------------------------------------------------------------
-- Closures properties respect to OrdList (flatten-OrdList-aux)
------------------------------------------------------------------------------

-- TODO
{-# OPTIONS --no-termination-check #-}

module LTC.Program.SortList.Properties.Closures.OrdList.FlattenI where

open import LTC.Base

-- open import Common.Function

open import LTC.Data.Bool
open import LTC.Data.Bool.PropertiesI
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesI
open import LTC.Data.Nat.Type
open import LTC.Data.List

open import LTC.Program.SortList.Properties.Closures.BoolI
open import LTC.Program.SortList.Properties.Closures.ListN-I
open import LTC.Program.SortList.Properties.Closures.OrdTreeI
open import LTC.Program.SortList.Properties.MiscellaneousI
open import LTC.Program.SortList.SortList

open import LTC.Relation.Binary.EqReasoning

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

flatten-OrdList-aux : {t₁ i t₂ : D} → Tree t₁ → N i → Tree t₂ →
                      OrdTree (node t₁ i t₂) →
                      LE-Lists (flatten t₁) (flatten t₂)

flatten-OrdList-aux {t₂ = t₂} nilT Ni Tt₂ OTt =
  subst (λ t → LE-Lists t (flatten t₂))
        (sym (flatten-nilTree))
        (≤-Lists-[] (flatten t₂))

flatten-OrdList-aux (tipT {i₁} Ni₁) _ nilT OTt =
  begin
    ≤-Lists (flatten (tip i₁)) (flatten nilTree)
      ≡⟨ subst₂ (λ x₁ x₂ → ≤-Lists (flatten (tip i₁)) (flatten nilTree) ≡
                           ≤-Lists x₁ x₂)
                (flatten-tip i₁)
                flatten-nilTree
                refl
      ⟩
    ≤-Lists (i₁ ∷ []) []
      ≡⟨ ≤-Lists-∷ i₁ [] [] ⟩
    ≤-ItemList i₁ [] && ≤-Lists [] []
      ≡⟨ subst₂ (λ x₁ x₂ → ≤-ItemList i₁ [] && ≤-Lists [] [] ≡ x₁ && x₂ )
                (≤-ItemList-[] i₁)
                (≤-Lists-[] [])
                refl
      ⟩
    true && true
      ≡⟨ &&-tt ⟩
    true
  ∎

flatten-OrdList-aux {i = i} (tipT {i₁} Ni₁) Ni (tipT {i₂} Ni₂) OTt =
  begin
    ≤-Lists (flatten (tip i₁)) (flatten (tip i₂))
      ≡⟨ subst₂ (λ x₁ x₂ → ≤-Lists (flatten (tip i₁)) (flatten (tip i₂)) ≡
                           ≤-Lists x₁ x₂)
                (flatten-tip i₁)
                (flatten-tip i₂)
                refl
      ⟩
    ≤-Lists (i₁ ∷ []) (i₂ ∷ [])
      ≡⟨ ≤-Lists-∷ i₁ [] (i₂ ∷ []) ⟩
    ≤-ItemList i₁ (i₂ ∷ []) && ≤-Lists [] (i₂ ∷ [])
      ≡⟨ subst (λ t → ≤-ItemList i₁ (i₂ ∷ []) && ≤-Lists [] (i₂ ∷ []) ≡
                      t && ≤-Lists [] (i₂ ∷ []))
               (≤-ItemList-∷ i₁ i₂ [])
               refl
      ⟩
    (i₁ ≤ i₂ && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ [])
      ≡⟨ subst (λ t → (i₁ ≤ i₂  && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ []) ≡
                      (t        && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ []))
               lemma
               refl
      ⟩
    (true && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ [])
      ≡⟨ subst₂ (λ x₁ x₂ → (true && ≤-ItemList i₁ []) && ≤-Lists [] (i₂ ∷ []) ≡
                           (true && x₁)               && x₂)
                (≤-ItemList-[] i₁)
                (≤-Lists-[] (i₂ ∷ []))
                refl
      ⟩
    (true && true) && true
      ≡⟨ &&-assoc tB tB tB ⟩
    true && true && true
      ≡⟨ &&-true₃ ⟩
    true
  ∎
  where
    aux₁ : Bool (ordTree (tip i₁))
    aux₁ = ordTree-Bool (tipT Ni₁)

    aux₂ : Bool (ordTree (tip i₂))
    aux₂ = ordTree-Bool (tipT Ni₂)

    aux₃ : Bool (≤-TreeItem (tip i₁) i)
    aux₃ = ≤-TreeItem-Bool (tipT Ni₁) Ni

    aux₄ : Bool (≤-ItemTree i (tip i₂))
    aux₄ = ≤-ItemTree-Bool Ni (tipT Ni₂)

    aux₅ : ordTree (tip i₁) &&
           ordTree (tip i₂) &&
           ≤-TreeItem (tip i₁) i &&
           ≤-ItemTree i (tip i₂) ≡ true
    aux₅ = trans (sym (ordTree-node (tip i₁) i (tip i₂))) OTt

    lemma : LE i₁ i₂
    lemma = ≤-trans Ni₁ Ni Ni₂ i₁≤i i≤i₂
     where
       i₁≤i : LE i₁ i
       i₁≤i = trans (sym (≤-TreeItem-tip i₁ i))
                    (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

       i≤i₂ : LE i i₂
       i≤i₂ = trans (sym (≤-ItemTree-tip i i₂))
                    (&&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅)

flatten-OrdList-aux {i = i} (tipT {i₁} Ni₁) Ni
                    (nodeT {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt =
  begin
    ≤-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂))
      ≡⟨ subst (λ x → ≤-Lists (flatten (tip i₁)) (flatten (node t₂₁ i₂ t₂₂)) ≡
                      ≤-Lists (flatten (tip i₁)) x)
               (flatten-node t₂₁ i₂ t₂₂)
               refl
      ⟩
    ≤-Lists (flatten (tip i₁)) (flatten t₂₁ ++ flatten t₂₂)
      ≡⟨ xs≤ys→xs≤zs→xs≤ys++zs (flatten-ListN (tipT Ni₁))
                               (flatten-ListN Tt₂₁)
                               (flatten-ListN Tt₂₂)
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (tipT Ni₁)
    aux₂ = ordTree-Bool (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₃ = ≤-TreeItem-Bool (tipT Ni₁) Ni
    aux₄ = ≤-ItemTree-Bool Ni (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₅ = trans (sym (ordTree-node (tip i₁) i (node t₂₁ i₂ t₂₂))) OTt

    -- Auxiliary terms to get the conjuncts from the fourth conjunct of OTt.
    aux₆ = ≤-ItemTree-Bool Ni Tt₂₁
    aux₇ = ≤-ItemTree-Bool Ni Tt₂₂
    aux₈ = trans (sym (≤-ItemTree-node i t₂₁ i₂ t₂₂))
                 (&&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-tip-i₁ : OrdTree (tip i₁)
    OrdTree-tip-i₁ = &&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅

    LE-TreeItem-tip-i₁-i : LE-TreeItem (tip i₁) i
    LE-TreeItem-tip-i₁-i = &&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten (tip i₁)) (flatten t₂₁)
    lemma₁ = flatten-OrdList-aux (tipT Ni₁) Ni Tt₂₁ OT  -- IH.
      where
        OrdTree-t₂₁ : OrdTree t₂₁
        OrdTree-t₂₁ = leftSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂
                                          (&&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-ItemTree-i-t₂₁ : LE-ItemTree i t₂₁
        LE-ItemTree-i-t₂₁ = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node (tip i₁) i t₂₁)
        OT =
          begin
            ordTree (node (tip i₁) i t₂₁)
              ≡⟨ ordTree-node (tip i₁) i t₂₁ ⟩
            ordTree (tip i₁) &&
            ordTree t₂₁ &&
            ≤-TreeItem (tip i₁) i &&
            ≤-ItemTree i t₂₁
              ≡⟨ subst₄ (λ w x y z → ordTree (tip i₁) &&
                                     ordTree t₂₁ &&
                                     ≤-TreeItem (tip i₁) i &&
                                     ≤-ItemTree i t₂₁ ≡
                                     w && x && y && z)
                        OrdTree-tip-i₁
                        OrdTree-t₂₁
                        LE-TreeItem-tip-i₁-i
                        LE-ItemTree-i-t₂₁
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten (tip i₁)) (flatten t₂₂)
    lemma₂ = flatten-OrdList-aux (tipT Ni₁) Ni Tt₂₂ OT  -- IH.
      where
        OrdTree-t₂₂ : OrdTree t₂₂
        OrdTree-t₂₂ = rightSubTree-OrdTree Tt₂₁ Ni₂ Tt₂₂
                                           (&&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-ItemTree-i-t₂₂ : LE-ItemTree i t₂₂
        LE-ItemTree-i-t₂₂ = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node (tip i₁) i t₂₂)
        OT =
          begin
            ordTree (node (tip i₁) i t₂₂)
              ≡⟨ ordTree-node (tip i₁) i t₂₂ ⟩
            ordTree (tip i₁) &&
            ordTree t₂₂ &&
            ≤-TreeItem (tip i₁) i &&
            ≤-ItemTree i t₂₂
              ≡⟨ subst₄ (λ w x y z → ordTree (tip i₁) &&
                                     ordTree t₂₂ &&
                                     ≤-TreeItem (tip i₁) i &&
                                     ≤-ItemTree i t₂₂ ≡
                                     w && x && y && z)
                        OrdTree-tip-i₁
                        OrdTree-t₂₂
                        LE-TreeItem-tip-i₁-i
                        LE-ItemTree-i-t₂₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

flatten-OrdList-aux {i = i} (nodeT {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni nilT OTt =
  begin
    ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nilTree)
      ≡⟨ subst (λ x → ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten nilTree) ≡
                      ≤-Lists x                           (flatten nilTree))
               (flatten-node t₁₁ i₁ t₁₂ )
               refl
      ⟩
    ≤-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten nilTree)
      ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                               (flatten-ListN Tt₁₂)
                               (flatten-ListN nilT)
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂)
    aux₂ = ordTree-Bool nilT
    aux₃ = ≤-TreeItem-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂) Ni
    aux₄ = ≤-ItemTree-Bool Ni nilT
    aux₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i nilTree )) OTt

    -- Auxiliary terms to get the conjuncts from the third conjunct of OTt.
    aux₆ = ≤-TreeItem-Bool Tt₁₁ Ni
    aux₇ = ≤-TreeItem-Bool Tt₁₂ Ni
    aux₈ = trans (sym (≤-TreeItem-node t₁₁ i₁ t₁₂ i))
                 (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    LE-ItemTree-i-niltree : LE-ItemTree i nilTree
    LE-ItemTree-i-niltree = &&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten t₁₁) (flatten nilTree)
    lemma₁ = flatten-OrdList-aux Tt₁₁ Ni nilT OT  -- IH.
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂
                              (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₁-i : LE-TreeItem t₁₁ i
        LE-TreeItem-t₁₁-i = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₁ i nilTree)
        OT =
          begin
            ordTree (node t₁₁ i nilTree )
              ≡⟨ ordTree-node t₁₁ i nilTree ⟩
            ordTree t₁₁ &&
            ordTree nilTree &&
            ≤-TreeItem t₁₁ i &&
            ≤-ItemTree i nilTree
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                     ordTree nilTree &&
                                     ≤-TreeItem t₁₁ i &&
                                     ≤-ItemTree i nilTree ≡
                                     w && x && y && z)
                        OrdTree-t₁₁
                        ordTree-nilTree
                        LE-TreeItem-t₁₁-i
                        LE-ItemTree-i-niltree
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten t₁₂) (flatten nilTree)
    lemma₂ = flatten-OrdList-aux Tt₁₂ Ni nilT OT  -- IH.
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₂-i : LE-TreeItem t₁₂ i
        LE-TreeItem-t₁₂-i = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₂ i nilTree)
        OT =
          begin
            ordTree (node t₁₂ i nilTree )
              ≡⟨ ordTree-node t₁₂ i nilTree ⟩
            ordTree t₁₂ &&
            ordTree nilTree &&
            ≤-TreeItem t₁₂ i &&
            ≤-ItemTree i nilTree
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                     ordTree nilTree &&
                                     ≤-TreeItem t₁₂ i &&
                                     ≤-ItemTree i nilTree ≡
                                     w && x && y && z)
                        OrdTree-t₁₂
                        ordTree-nilTree
                        LE-TreeItem-t₁₂-i
                        LE-ItemTree-i-niltree
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

flatten-OrdList-aux {i = i} (nodeT {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                    (tipT {i₂} Ni₂) OTt =
  begin
    ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂))
      ≡⟨ subst (λ x → ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (tip i₂)) ≡
                      ≤-Lists x                           (flatten (tip i₂)))
               (flatten-node t₁₁ i₁ t₁₂ )
               refl
      ⟩
    ≤-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten (tip i₂))
      ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                               (flatten-ListN Tt₁₂)
                               (flatten-ListN (tipT Ni₂))
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂)
    aux₂ = ordTree-Bool (tipT Ni₂)
    aux₃ = ≤-TreeItem-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂) Ni
    aux₄ = ≤-ItemTree-Bool Ni (tipT Ni₂)
    aux₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (tip i₂))) OTt

    -- Auxiliary terms to get the conjuncts from the third conjunct of OTt.
    aux₆ = ≤-TreeItem-Bool Tt₁₁ Ni
    aux₇ = ≤-TreeItem-Bool Tt₁₂ Ni
    aux₈ = trans (sym (≤-TreeItem-node t₁₁ i₁ t₁₂ i))
                 (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-tip-i₂ : OrdTree (tip i₂)
    OrdTree-tip-i₂ = &&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅

    LE-ItemTree-i-tip-i₂ : LE-ItemTree i (tip i₂)
    LE-ItemTree-i-tip-i₂ = &&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten t₁₁) (flatten (tip i₂))
    lemma₁ = flatten-OrdList-aux Tt₁₁ Ni (tipT Ni₂) OT  -- IH.
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₁-i : LE-TreeItem t₁₁ i
        LE-TreeItem-t₁₁-i = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₁ i (tip i₂))
        OT =
          begin
            ordTree (node t₁₁ i (tip i₂) )
              ≡⟨ ordTree-node t₁₁ i (tip i₂) ⟩
            ordTree t₁₁ &&
            ordTree (tip i₂) &&
            ≤-TreeItem t₁₁ i &&
            ≤-ItemTree i (tip i₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                     ordTree (tip i₂) &&
                                     ≤-TreeItem t₁₁ i &&
                                     ≤-ItemTree i (tip i₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₁
                        OrdTree-tip-i₂
                        LE-TreeItem-t₁₁-i
                        LE-ItemTree-i-tip-i₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten t₁₂) (flatten (tip i₂))
    lemma₂ = flatten-OrdList-aux Tt₁₂ Ni (tipT Ni₂) OT  -- IH.
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₂-i : LE-TreeItem t₁₂ i
        LE-TreeItem-t₁₂-i = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₂ i (tip i₂))
        OT =
          begin
            ordTree (node t₁₂ i (tip i₂) )
              ≡⟨ ordTree-node t₁₂ i (tip i₂) ⟩
            ordTree t₁₂ &&
            ordTree (tip i₂) &&
            ≤-TreeItem t₁₂ i &&
            ≤-ItemTree i (tip i₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                     ordTree (tip i₂) &&
                                     ≤-TreeItem t₁₂ i &&
                                     ≤-ItemTree i (tip i₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₂
                        OrdTree-tip-i₂
                        LE-TreeItem-t₁₂-i
                        LE-ItemTree-i-tip-i₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

flatten-OrdList-aux {i = i} (nodeT {t₁₁} {i₁} {t₁₂} Tt₁₁ Ni₁ Tt₁₂) Ni
                    (nodeT {t₂₁} {i₂} {t₂₂} Tt₂₁ Ni₂ Tt₂₂) OTt =
  begin
    ≤-Lists (flatten (node t₁₁ i₁ t₁₂)) (flatten (node t₂₁ i₂ t₂₂))
      ≡⟨ subst (λ x → ≤-Lists (flatten (node t₁₁ i₁ t₁₂))
                              (flatten (node t₂₁ i₂ t₂₂)) ≡
                      ≤-Lists x (flatten (node t₂₁ i₂ t₂₂)))
               (flatten-node t₁₁ i₁ t₁₂ )
               refl
      ⟩
    ≤-Lists (flatten t₁₁ ++  flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
      ≡⟨ xs≤zs→ys≤zs→xs++ys≤zs (flatten-ListN Tt₁₁)
                               (flatten-ListN Tt₁₂)
                               (flatten-ListN (nodeT Tt₂₁ Ni₂ Tt₂₂))
                               lemma₁
                               lemma₂
      ⟩
    true
  ∎
  where
    -- Auxiliary terms to get the conjuncts from OTt.
    aux₁ = ordTree-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂)
    aux₂ = ordTree-Bool (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₃ = ≤-TreeItem-Bool (nodeT Tt₁₁ Ni₁ Tt₁₂) Ni
    aux₄ = ≤-ItemTree-Bool Ni (nodeT Tt₂₁ Ni₂ Tt₂₂)
    aux₅ = trans (sym (ordTree-node (node t₁₁ i₁ t₁₂) i (node t₂₁ i₂ t₂₂))) OTt

    -- Auxiliary terms to get the conjuncts from the third conjunct of OTt.
    aux₆ = ≤-TreeItem-Bool Tt₁₁ Ni
    aux₇ = ≤-TreeItem-Bool Tt₁₂ Ni
    aux₈ = trans (sym (≤-TreeItem-node t₁₁ i₁ t₁₂ i))
                 (&&₃-proj₃ aux₁ aux₂ aux₃ aux₄ aux₅)

    -- Common terms for the lemma₁ and lemma₂.
    OrdTree-node-t₂₁-i₂-t₂₂ : OrdTree (node t₂₁ i₂ t₂₂)
    OrdTree-node-t₂₁-i₂-t₂₂ = &&₃-proj₂ aux₁ aux₂ aux₃ aux₄ aux₅

    LE-ItemTree-i-node-t₂₁-i₂-t₂₂ : LE-ItemTree i (node t₂₁ i₂ t₂₂)
    LE-ItemTree-i-node-t₂₁-i₂-t₂₂ = &&₃-proj₄ aux₁ aux₂ aux₃ aux₄ aux₅

    lemma₁ : LE-Lists (flatten t₁₁) (flatten (node t₂₁ i₂ t₂₂))
    lemma₁ = flatten-OrdList-aux Tt₁₁ Ni (nodeT Tt₂₁ Ni₂ Tt₂₂) OT  -- IH.
      where
        OrdTree-t₁₁ : OrdTree t₁₁
        OrdTree-t₁₁ =
          leftSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₁-i : LE-TreeItem t₁₁ i
        LE-TreeItem-t₁₁-i = &&-proj₁ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₁ i (node t₂₁ i₂ t₂₂))
        OT =
          begin
            ordTree (node t₁₁ i (node t₂₁ i₂ t₂₂) )
              ≡⟨ ordTree-node t₁₁ i (node t₂₁ i₂ t₂₂) ⟩
            ordTree t₁₁ &&
            ordTree (node t₂₁ i₂ t₂₂) &&
            ≤-TreeItem t₁₁ i &&
            ≤-ItemTree i (node t₂₁ i₂ t₂₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₁ &&
                                     ordTree (node t₂₁ i₂ t₂₂) &&
                                     ≤-TreeItem t₁₁ i &&
                                     ≤-ItemTree i (node t₂₁ i₂ t₂₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₁
                        OrdTree-node-t₂₁-i₂-t₂₂
                        LE-TreeItem-t₁₁-i
                        LE-ItemTree-i-node-t₂₁-i₂-t₂₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎

    lemma₂ : LE-Lists (flatten t₁₂) (flatten (node t₂₁ i₂ t₂₂))
    lemma₂ = flatten-OrdList-aux Tt₁₂ Ni (nodeT Tt₂₁ Ni₂ Tt₂₂) OT  -- IH.
      where
        OrdTree-t₁₂ : OrdTree t₁₂
        OrdTree-t₁₂ =
          rightSubTree-OrdTree Tt₁₁ Ni₁ Tt₁₂ (&&₃-proj₁ aux₁ aux₂ aux₃ aux₄ aux₅)

        LE-TreeItem-t₁₂-i : LE-TreeItem t₁₂ i
        LE-TreeItem-t₁₂-i = &&-proj₂ aux₆ aux₇ aux₈

        OT : OrdTree (node t₁₂ i (node t₂₁ i₂ t₂₂))
        OT =
          begin
            ordTree (node t₁₂ i (node t₂₁ i₂ t₂₂) )
              ≡⟨ ordTree-node t₁₂ i (node t₂₁ i₂ t₂₂) ⟩
            ordTree t₁₂ &&
            ordTree (node t₂₁ i₂ t₂₂) &&
            ≤-TreeItem t₁₂ i &&
            ≤-ItemTree i (node t₂₁ i₂ t₂₂)
              ≡⟨ subst₄ (λ w x y z → ordTree t₁₂ &&
                                     ordTree (node t₂₁ i₂ t₂₂) &&
                                     ≤-TreeItem t₁₂ i &&
                                     ≤-ItemTree i (node t₂₁ i₂ t₂₂) ≡
                                     w && x && y && z)
                        OrdTree-t₁₂
                        OrdTree-node-t₂₁-i₂-t₂₂
                        LE-TreeItem-t₁₂-i
                        LE-ItemTree-i-node-t₂₁-i₂-t₂₂
                        refl
            ⟩
            true && true && true && true
              ≡⟨ &&-true₄ ⟩
            true
          ∎


Boring.

Boring.

Ignore-this: c17974f2bac758a84b125f426d4798a0

darcs-hash:20100410164802-3bd4e-10acc80d0acab3f763cace7626e83817333a8176.gz

module Test.Fail.UsingPredicatesWithConjectures where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D

-- The identity type.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_    : D → D → D
  add-x0 : (n : D) → n + zero     ≡ n
  add-xS : (m n : D) → m + succ n ≡ succ (m + n)

{-# ATP axiom add-x0 #-}
{-# ATP axiom add-xS #-}

P : D → Set
P i = zero + i ≡ i

postulate
  P0₁ : zero + zero ≡ zero
{-# ATP prove P0₁ #-}

postulate
  iStep₁ : {i : D} → N i → zero + i ≡ i → zero + (succ i) ≡ succ i
{-# ATP prove iStep₁ #-}

addLeftIdentity₁ : {n : D} → N n → zero + n ≡ n
addLeftIdentity₁ = indN (λ i → P i) P0₁ iStep₁

-- Equinox cannot prove the postulates P0₂ and iStep₂ because he does
-- not the definition of the predicate P. It seems we should use the
-- TPTP definitions.
postulate
  P0₂ : P zero
-- {-# ATP prove P0₂ #-}

postulate
  iStep₂ : {i : D} → N i → P i → P (succ i)
-- {-# ATP prove iStep₂ #-}

addLeftIdentity₂ : {n : D} → N n → zero + n ≡ n
addLeftIdentity₂ = indN (λ i → P i) P0₂ iStep₂