module Data.List.Functions where

import      Lvl
open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Data.List
open import Data.Option as Option using (Option)
import      Data.Option.Functions as Option
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Numeral.Finite
open import Numeral.Natural
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T A A₁ A₂ B B₁ B₂ Result : Type{ℓ}

infixl 1000 _++_

open import Data.List.Functions.Positional public

-- The list of the successive application of `tail` on a list.
-- For a list `l`, the range of `n ↦ (tail ^ n)(l)` as a list.
-- Example:
--   tails []      = [[]]
--   tails [a]     = [[a] , []]
--   tails [a,b]   = [[a,b] , [b] , []]
--   tails [a,b,c] = [[a,b,c] , [b,c] , [c] , []]
-- Note: `∀{l} → (tails l = accumulateIterate (length l) tail l)`.
tails : List(T) → List(List(T))
tails ∅       = singleton(∅)
tails (x ⊰ l) = (x ⊰ l) ⊰ tails l

-- Applies a binary operator to each element in the list starting with the initial element.
-- Example:
--   foldₗ(▫)(init)[]          = init
--   foldₗ(▫)(init)[a]         = init▫a
--   foldₗ(▫)(init)[a,b]       = (init▫a)▫b
--   foldₗ(▫)(init)[a,b,c,d,e] = ((((init▫a)▫b)▫c)▫d)▫e
foldₗ : (Result → T → Result) → Result → List(T) → Result
foldₗ _   result ∅          = result
foldₗ _▫_ result (elem ⊰ l) = foldₗ _▫_ (result ▫ elem) l

-- Applies a binary operator to each element in the list starting with the initial element.
-- Example:
--   foldᵣ(▫)(init)[]          = init
--   foldᵣ(▫)(init)[a]         = a▫init
--   foldᵣ(▫)(init)[a,b]       = a▫(b▫init)
--   foldᵣ(▫)(init)[a,b,c,d,e] = a▫(b▫(c▫(d▫(e▫init))))
foldᵣ : (T → Result → Result) → Result → List(T) → Result
foldᵣ _   init ∅          = init
foldᵣ _▫_ init (elem ⊰ l) = elem ▫ (foldᵣ _▫_ init l)

-- Applies a binary operator to each element in the list starting with the initial element.
-- Example:
--   foldᵣ-init(▫)(init)[]          = init
--   foldᵣ-init(▫)(init)[a]         = init▫a
--   foldᵣ-init(▫)(init)[a,b]       = init▫(a▫b)
--   foldᵣ-init(▫)(init)[a,b,c,d,e] = init▫(a▫(b▫(c▫(d▫e))))
-- Same as (reduceOrᵣ (_▫_) (a) (a⊰l)) except that
-- this allows matching out one element when
-- there is only a first element as the head
--  and an _arbitrary_ list as the tail.
-- Also, this dIffers from foldᵣ in the following way:
--   foldᵣ      (_▫_) (1) [2,3] = 2 ▫ (3 ▫ 1)
--   foldᵣ-init (_▫_) (1) [2,3] = 1 ▫ (2 ▫ 3)
-- Also: foldᵣ-init(▫)(init)(l++[last]) = foldᵣ(▫)(last)(init⊰l)
foldᵣ-init : (T → T → T) → T → List(T) → T
foldᵣ-init _   init ∅          = init
foldᵣ-init _▫_ init (elem ⊰ l) = init ▫ (foldᵣ-init _▫_ elem l)

-- If the list is empty, use the result, else like foldₗ
-- Example:
--   reduceOrₗ(▫)(result)[]          = result
--   reduceOrₗ(▫)(result)[a]         = a
--   reduceOrₗ(▫)(result)[a,b]       = a▫b
--   reduceOrₗ(▫)(result)[a,b,c]     = (a▫b)▫c
--   reduceOrₗ(▫)(result)[a,b,c,d,e] = (((a▫b)▫c)▫d)▫e
reduceOrₗ : (T → T → T) → T → List(T) → T
reduceOrₗ _   result ∅          = result
reduceOrₗ _▫_ result (elem ⊰ l) = foldₗ _▫_ elem l

-- If the list is empty, use the result, else like foldᵣ
-- Example:
--   reduceOrᵣ(▫)(result)[]          = result
--   reduceOrᵣ(▫)(result)[a]         = a
--   reduceOrᵣ(▫)(result)[a,b]       = a▫b
--   reduceOrᵣ(▫)(result)[a,b,c]     = a▫(b▫c)
--   reduceOrᵣ(▫)(result)[a,b,c,d,e] = a▫(b▫(c▫(d▫e)))
reduceOrᵣ : (T → T → T) → T → List(T) → T
reduceOrᵣ _   init ∅          = init
reduceOrᵣ _▫_ init (elem ⊰ l) = foldᵣ-init _▫_ elem l

-- Accumulates the results of every step in `foldₗ` into a list.
-- Example:
--   accumulateFoldₗ(_▫_) result []        = [result]
--   accumulateFoldₗ(_▫_) result [a]       = [result▫a]
--   accumulateFoldₗ(_▫_) result [a,b]     = [result▫a , (result▫a)▫b]
--   accumulateFoldₗ(_▫_) result [a,b,c]   = [result▫a , (result▫a)▫b , ((result▫a)▫b)▫c]
--   accumulateFoldₗ(_▫_) result [a,b,c,d] = [result▫a , (result▫a)▫b , ((result▫a)▫b)▫c , (((result▫a)▫b)▫c)▫d]
accumulateFoldₗ : (Result → T → Result) → Result → List(T) → List(Result)
accumulateFoldₗ(_▫_) result ∅       = singleton(result)
accumulateFoldₗ(_▫_) result (x ⊰ l) = result ⊰ accumulateFoldₗ(_▫_) (result ▫ x) l

-- Accumulates the results of every step in `reduceₗ` into a list.
-- Example:
--   accumulateReduceₗ(_▫_) []        = []
--   accumulateReduceₗ(_▫_) [a]       = [a]
--   accumulateReduceₗ(_▫_) [a,b]     = [a , a▫b]
--   accumulateReduceₗ(_▫_) [a,b,c]   = [a , a▫b , (a▫b)▫c]
--   accumulateReduceₗ(_▫_) [a,b,c,d] = [a , a▫b , (a▫b)▫c , ((a▫b)▫c)▫d]
accumulateReduceₗ : (T → T → T) → List(T) → List(T)
accumulateReduceₗ(_▫_) ∅       = ∅
accumulateReduceₗ(_▫_) (x ⊰ l) = accumulateFoldₗ(_▫_) x l

-- Accumulates the results of every step in `_^_` into a list.
-- Example:
--   accumulateIterate₀ 0 f(x) = []
--   accumulateIterate₀ 1 f(x) = [x]
--   accumulateIterate₀ 2 f(x) = [x , f(x)]
--   accumulateIterate₀ 3 f(x) = [x , f(x) , f(f(x))]
--   accumulateIterate₀ 4 f(x) = [x , f(x) , f(f(x)) , f(f(f(x)))]
accumulateIterate₀ : ℕ → (T → T) → (T → List(T))
accumulateIterate₀ 𝟎      f(x) = ∅
accumulateIterate₀ (𝐒(n)) f(x) = x ⊰ accumulateIterate₀ n f (f(x))

-- Accumulates the results of every step in `_^_` into a list.
-- Example:
--   accumulateIterate 0 f(x) = [x]
--   accumulateIterate 1 f(x) = [x , f(x)]
--   accumulateIterate 2 f(x) = [x , f(x) , f(f(x))]
--   accumulateIterate 3 f(x) = [x , f(x) , f(f(x)) , f(f(f(x)))]
--   accumulateIterate 4 f(x) = [x , f(x) , f(f(x)) , f(f(f(x))) , f(f(f(f(x))))]
accumulateIterate : ℕ → (T → T) → (T → List(T))
accumulateIterate n = accumulateIterate₀(𝐒(n))

-- List concatenation.
-- Concatenates (joins/glues) two lists together.
-- Examples:
--   [] ++ [] = []
--   [a] ++ [b] = [a,b]
--   [a,b,c] ++ [d,e,f] = [a,b,c,d,e,f]
_++_ : List(T) → List(T) → List(T)
_++_ = swap(foldᵣ (_⊰_))

-- Concatenates multiple lists together.
-- Examples:
--   concat [[a,b,c] , [d,e] , [f] , [g,h]]
--   = [a,b,c] ++ [d,e] ++ [f] ++ [g,h] =
--   = [a,b,c,d,e,f,g,h]
concat : List(List(T)) → List(T)
concat = foldᵣ(_++_) ∅

-- Postpends an element to a list, inserting it to the end of the list.
-- Examples:
--   postpend a []      = [a]
--   postpend b [a]     = [a,b]
--   postpend c [a,b]   = [a,b,c]
--   postpend d [a,b,c] = [a,b,c,d]
postpend : T → List(T) → List(T)
postpend a ∅       = a ⊰ ∅
postpend a (x ⊰ l) = x ⊰ postpend a l

-- Inserts an element to a list, inserting it at the given position of the list.
-- If the given position is out of range, then the element is postpended to the list.
-- Examples:
--   insert 2 x []        = [x]
--   insert 2 x [a]       = [a,x]
--   insert 2 x [a,b]     = [a,b,x]
--   insert 2 x [a,b,c]   = [a,b,x,c]
--   insert 2 x [a,b,c,d] = [a,b,x,c,d]
insert : ℕ → T → List(T) → List(T)
insert 𝟎                = _⊰_
insert (𝐒(_)) a ∅       = singleton a
insert (𝐒(i)) a (x ⊰ l) = x ⊰ insert i a l

module LongOper where
  pattern empty = ∅
  pattern prepend elem list = elem ⊰ list

-- Applies a function on each element in the list
-- Examples:
--   map f[]      = []
--   map f[a]     = [f(a)]
--   map f[a,b]   = [f(a),f(b)]
--   map f[a,b,c] = [f(a),f(b),f(c)]
map : (A → B) → (List(A) → List(B))
map _ ∅ = ∅
map f (x ⊰ l) = f(x) ⊰ (map f l)

-- Filters the list while mapping it
mapFilter : (A → Option(B)) → (List(A) → List(B))
mapFilter _ ∅ = ∅
mapFilter f (x ⊰ l) with f(x)
... | Option.Some(y) = y ⊰ (mapFilter f l)
... | Option.None    = mapFilter f l

-- Maps every element to a list in the given list and then concatenates the resulting list.
-- Note: Functionally equivalent to: `concat ∘₂ map`.
-- Example: `concatMap(x ↦ [x , x + 1 , x + 2]) [10,20,30,40] = [10,11,12 , 20,21,22 , 30,31,32 , 40,41,42]`
-- Alternative implementation:
--   concatMap f ∅ = ∅
--   concatMap f (x ⊰ l) = f(x) ++ concatMap f l
concatMap : (A → List(B)) → (List(A) → List(B))
concatMap f = foldᵣ((_++_) ∘ f) ∅

-- The nth element in the list
-- Examples:
-- • `index₀ 0 [a,b,c] = Some a`
-- • `index₀ 1 [a,b,c] = Some b`
-- • `index₀ 2 [a,b,c] = Some c`
-- • `index₀ 3 [a,b,c] = None`
-- • `index₀ 4 [a,b,c] = None`
index₀ : ℕ → List(T) → Option(T)
index₀ _      ∅       = Option.None
index₀ 𝟎      (x ⊰ _) = Option.Some(x)
index₀ (𝐒(n)) (_ ⊰ l) = index₀ n l

-- The sublist with the first n elements in the list.
-- Also called: "take" in the Haskell standard library.
-- Example:
-- • `initial 0 [1,2,3] = []`
-- • `initial 1 [1,2,3] = [1]`
-- • `initial 2 [1,2,3] = [1,2]`
-- • `initial 3 [1,2,3] = [1,2,3]`
-- • `initial 4 [1,2,3] = [1,2,3]`
-- • `initial 5 [1,2,3] = [1,2,3]`
initial : ℕ → List(T) → List(T)
initial _      ∅       = ∅
initial 𝟎      (_ ⊰ _) = ∅
initial (𝐒(n)) (x ⊰ l) = x ⊰ (initial n l)

-- The sublist without the first n elements in the list
-- Example:
-- • `skip 0 [1,2,3] = [1,2,3]`
-- • `skip 1 [1,2,3] = [2,3]`
-- • `skip 2 [1,2,3] = [3]`
-- • `skip 3 [1,2,3] = []`
-- • `skip 4 [1,2,3] = []`
-- • `skip 5 [1,2,3] = []`
skip : ℕ → List(T) → List(T)
skip _      ∅         = ∅
skip 𝟎      l@(_ ⊰ _) = l
skip (𝐒(n)) (x ⊰ l)   = skip n l

-- TODO: Maybe rename this to "extractFirst"?
-- Extracts the first element from the list if there is one.
-- Example: `splitFirst [1,2,3] = Some(1 , [2,3])`
splitFirst : List(T) → Option(T ⨯ List(T))
splitFirst ∅       = Option.None
splitFirst (x ⊰ l) = Option.Some(x , l)

-- Extracts the last element from the list if there is one.
-- Example: `splitLast [1,2,3] = Some([1,2] , 3)`
splitLast : List(T) → Option(List(T) ⨯ T)
splitLast ∅           = Option.None
splitLast (x ⊰ ∅)     = Option.Some(∅ , x)
splitLast (x ⊰ y ⊰ l) = Option.map (Tuple.mapLeft (x ⊰_)) (splitLast (y ⊰ l))

-- Split a list into two sublist parts at the specified index.
-- The first list's length is the specified index.
-- The second list starts at the specified index.
-- Example:
--   splitAt 0 [a,b,c,d] = ([] , [a,b,c,d])
--   splitAt 1 [a,b,c,d] = ([a] , [b,c,d])
--   splitAt 2 [a,b,c,d] = ([a,b] , [c,d])
--   splitAt 3 [a,b,c,d] = ([a,b,c] , [d])
--   splitAt 4 [a,b,c,d] = ([a,b,c,d] , [])
--   splitAt 5 [a,b,c,d] = ([a,b,c,d] , [])
splitAt : ℕ → List(T) → (List(T) ⨯ List(T))
splitAt 𝟎     l       = (∅ , l)
splitAt (𝐒 n) ∅       = (∅ , ∅)
splitAt (𝐒 n) (x ⊰ l) = Tuple.mapLeft (x ⊰_) (splitAt n l)

-- All ordered sublist partitions of the specified list with only two parts.
--
splits₂ : List(T) → List(List(T) ⨯ List(T))
splits₂ l = (∅ , l) ⊰ f ∅ l where
  f : List(T) → List(T) → List(List(T) ⨯ List(T))
  f _ ∅       = ∅
  f a (x ⊰ b) = (postpend x a , b) ⊰ f (postpend x a) b

-- Length of the list (number of elements in the list).
-- Examples:
-- • `length []      = 0`
-- • `length [a]     = 1`
-- • `length [a,b]   = 2`
-- • `length [a,b,c] = 3`
-- • `length [b,c,a] = 3`
-- • `length [c,a,b] = 3`
-- • `length [b,a,c] = 3`
-- • `length [a,c,b] = 3`
-- • `length [b,a,c] = 3`
length : List(T) → ℕ
length = foldᵣ (const 𝐒) 0

-- The nth element in the list as a total function.
index : (l : List(T)) → 𝕟(length(l)) → T
index ∅       ()
index (x ⊰ l) 𝟎     = x
index (x ⊰ l) (𝐒 n) = index l n

-- The sublist with the last n elements in the list
-- last : ℕ → List(T) → List(T)
-- last n l = skip(length(l) −₀ ) l

-- TODO: Generalize
mapWindow2ₗ : (T → T → T) → List(T) → List(T)
mapWindow2ₗ f (x₁ ⊰ x₂ ⊰ l) = (f x₁ x₂) ⊰ (mapWindow2ₗ f (x₂ ⊰ l))
{-# CATCHALL #-}
mapWindow2ₗ _ _ = ∅

_orₗ_ : List(T) → List(T) → List(T)
_orₗ_ ∅ default      = default
_orₗ_ (l @(_ ⊰ _)) _ = l

-- Reverse the order of the elements in the list.
-- Example: `reverse [a,b,c,d] = [d,c,b,a]`.
reverse : List(T) → List(T)
reverse ∅ = ∅
reverse (x ⊰ l) = postpend x (reverse l)

import Function.Iteration as Function

-- The list with a list concatenated (repeated) n times.
-- Example: `[a,b,c] ++^ 4 = [a,b,c] ++ [a,b,c] ++ [a,b,c] ++ [a,b,c] = [a,b,c , a,b,c , a,b,c , a,b,c]`.
_++^_ : List(T) → ℕ → List(T)
_++^_ l n = Function.repeatᵣ n (_++_) l ∅

-- The list with an element repeated n times
-- Example: `repeat a 4 = [a,a,a,a]`.
repeat : T → ℕ → List(T)
repeat = (_++^_) ∘ singleton

-- Whether at least one element in the list satisfies the given boolean predicate function.
-- Note: `∀{pred}{l} → (satisfiesAny pred l = foldᵣ((_||_) ∘ pred) 𝐹 l)`. They are functionally equivalent but the difference is that this exits early when something false is found which is good for performance.
satisfiesAny : (T → Bool) → List(T) → Bool
satisfiesAny pred ∅       = 𝐹
satisfiesAny pred (x ⊰ l) with pred(x)
... | 𝑇 = 𝑇
... | 𝐹 = satisfiesAny(pred)(l)

-- Whether all elements in the list satisfies the given boolean predicate function.
-- Note: `∀{pred}{l} → (satisfiesAll pred l = foldᵣ((_&&_) ∘ pred) 𝑇 l)`. They are functionally equivalent but the difference is that this exits early when something false is found which is good for performance.
satisfiesAll : (T → Bool) → List(T) → Bool
satisfiesAll pred ∅       = 𝑇
satisfiesAll pred (x ⊰ l) with pred(x)
... | 𝑇 = satisfiesAll(pred)(l)
... | 𝐹 = 𝐹

satisfiesAll₂ : (T → T → Bool) → (T → Bool) → (T → Bool) → (List(T) → List(T) → Bool)
satisfiesAll₂(_▫_) l r ∅          ∅          = 𝑇
satisfiesAll₂(_▫_) l r l₁@(_ ⊰ _) ∅          = satisfiesAll l l₁
satisfiesAll₂(_▫_) l r ∅          l₂@(_ ⊰ _) = satisfiesAll r l₂
satisfiesAll₂(_▫_) l r (x₁ ⊰ l₁)  (x₂ ⊰ l₂)  = (x₁ ▫ x₂) && satisfiesAll₂(_▫_) l r l₁ l₂
{-satisfiesAll₂(_▫_) l r (x₁ ⊰ l₁)  (x₂ ⊰ l₂)  with (x₁ ▫ x₂)
... | 𝑇 = satisfiesAll₂(_▫_) l r l₁ l₂
... | 𝐹 = 𝐹-}

-- TODO
-- List-apply : ∀{L : List(Type{ℓ})} → (foldᵣ (_⨯_) (Out) (L)) → ∀{Out : Type{ℓ}} → (foldᵣ (_→ᶠ_) (Out) (L)) → Out
-- List-apply(∅)           (f) = f
-- List-apply(head ⊰ rest) (f) = List-apply(rest) (f(head))

-- fn-to-list : ∀{L : List(Type{ℓ})}{Out : Type{ℓ}} → (foldᵣ (_→ᶠ_) (Out) (L)) → (List(Type{ℓ}) → Out)
-- fn-to-list{∅} =

-- Replacing the nth element in the list.
-- Example: `modifyAt 2 f [a,b,c,d] = [a,b,f(c),d]`.
modifyAt : ℕ → (T → T) → List(T) → List(T)
modifyAt _      f ∅       = ∅
modifyAt 𝟎      f (x ⊰ l) = f(x) ⊰ l
modifyAt (𝐒(n)) f (x ⊰ l) = x ⊰ modifyAt n f l

-- Example: `replaceAt 2 x [a,b,c,d] = [a,b,x,d]`.
replaceAt : ℕ → T → List(T) → List(T)
replaceAt n = modifyAt n ∘ const

-- The list without the nth element in the list
-- Example: `withoutIndex 2 [a,b,c,d] = [a,b,d]`.
withoutIndex : ℕ → List(T) → List(T)
withoutIndex _       ∅       = ∅
withoutIndex 𝟎       (_ ⊰ l) = l
withoutIndex (𝐒(n))  (x ⊰ l) = x ⊰ withoutIndex(n)(l)

-- Example: `swapIndex 1 3 [a,b,c,d,e,f] = [a,d,c,b,e,f]`.
swapIndex : ℕ → ℕ → List(T) → List(T)
swapIndex _      _      ∅      = ∅
swapIndex 𝟎      𝟎      (x ⊰ l) = (x ⊰ l)
swapIndex (𝐒(a)) 𝟎      (x ⊰ l) = Option.map(_⊰ replaceAt a x l) (index₀ a l) Option.or (x ⊰ l)
swapIndex 𝟎      (𝐒(b)) (x ⊰ l) = Option.map(_⊰ replaceAt b x l) (index₀ b l) Option.or (x ⊰ l)
swapIndex (𝐒(a)) (𝐒(b)) (x ⊰ l) = x ⊰ swapIndex a b l

-- The given list with only the elements that satisfy the given predicate (without the elements that do not satisfy the given predicate).
-- Example: `filter(_<? 10) [0,10,11,1,2,12,3,13,14,4,5] = [0,1,2,3,4,5]`.
filter : (T → Bool) → List(T) → List(T)
filter f(∅)     = ∅
filter f(x ⊰ l) = (if f(x) then (x ⊰_) else id) (filter f(l))

-- Finds the first element that satisfies the given predicate in the given list.
find : (T → Bool) → List(T) → Option(T)
find f(∅)     = Option.None
find f(x ⊰ l) with f(x)
... | 𝑇 = Option.Some(x)
... | 𝐹 = find f(l)

-- Finds and extracts the first element satisfying the given predicate.
-- Example: `extractFirst(_> 2) [0,1,2,3,4,5] = Some(3 , [0,1,2,4,5])`.
extractFirstBy : (T → Bool) → List(T) → Option(T ⨯ List(T))
extractFirstBy f(∅)     = Option.None
extractFirstBy f(x ⊰ l) with f(x)
... | 𝑇 = Option.Some(x , l)
... | 𝐹 = Option.map(Tuple.mapRight(x ⊰_)) (extractFirstBy f(l))

-- The number of elements satisfying the given predicate in the given list.
count : (T → Bool) → List(T) → ℕ
count f(∅)     = 𝟎
count f(x ⊰ l) = (if f(x) then 𝐒 else id) (count f(l))

-- Whether the given list is the empty list.
isEmpty : List(T) → Bool
isEmpty(∅)     = 𝑇
isEmpty(_ ⊰ _) = 𝐹

-- Separates a list into 2 lists of almost equal length putting every other element into different lists.
-- Example:
--   separate₂ []          = ([]      , [])
--   separate₂ [a]         = ([a]     , [])
--   separate₂ [a,b]       = ([a]     , [b])
--   separate₂ [a,b,c]     = ([a,c]   , [b])
--   separate₂ [a,b,c,d]   = ([a,c]   , [b,d])
--   separate₂ [a,b,c,d,e] = ([a,c,e] , [b,d])
separate₂ : List(T) → (List(T) ⨯ List(T))
separate₂ ∅           = (∅ , ∅)
separate₂ (x ⊰ ∅)     = (singleton x , ∅)
separate₂ (x ⊰ y ⊰ l) = Tuple.map (x ⊰_) (y ⊰_) (separate₂ l)

-- Example:
--   interleave [[0,1,2],[10,11,12,13,14],[100,101]] = [0,10,100 , 1,11,101 , 2,12 , 13 , 14]
-- Termination:
--   Terminates because the argument in the recursion `map tail ls` shrinks every list until they all become empty, and when all lists are empty, the function branches to the other trivially terminating case.
{-# TERMINATING #-}
interleave : List(List(T)) → List(T)
interleave ls with satisfiesAll isEmpty ls
... | 𝑇 = ∅
... | 𝐹 = foldᵣ (Option.partialMap id (_⊰_) ∘ first) (interleave(map tail ls)) ls

-- Note: This is similiar to a function called `zipWith` in the Haskell standard library.
-- TODO: Generalize like https://stackoverflow.com/questions/39991581/how-can-i-implement-generalized-zipn-and-unzipn-in-haskell
map₂ : (A₁ → A₂ → B) → (List(A₁) → List(B)) → (List(A₂) → List(B)) → (List(A₁) → List(A₂) → List(B))
map₂ f g₁ g₂ ∅          ∅          = ∅
map₂ f g₁ g₂ ∅          l₂@(_ ⊰ _) = g₂ l₂
map₂ f g₁ g₂ l₁@(_ ⊰ _) ∅          = g₁ l₁
map₂ f g₁ g₂ (x₁ ⊰ l₁)  (x₂ ⊰ l₂)  = f x₁ x₂ ⊰ map₂ f g₁ g₂ l₁ l₂

-- Rotates to the left.
-- Example:
--   rotateₗ 3 [a,b,c,d,e]
--   = rotateₗ 2 [b,c,d,e,a]
--   = rotateₗ 1 [c,d,e,a,b]
--   = rotateₗ 0 [d,e,a,b,c]
--   = [d,e,a,b,c]
rotateₗ : ℕ → List(T) → List(T)
rotateₗ 𝟎      l       = l
rotateₗ (𝐒(n)) ∅       = ∅
rotateₗ (𝐒(n)) (x ⊰ l) = postpend x (rotateₗ n l)

rotateᵣ : ℕ → List(T) → List(T)
rotateᵣ n l with splitLast l
... | Option.None        = ∅
... | Option.Some(r , x) = x ⊰ r

-- Examples:
--   every n [] = []
--   every 0  [0,1,2,3,4,5,6,7,8] = []
--   every 1  [0,1,2,3,4,5,6,7,8] = [0,1,2,3,4,5,6,7,8]
--   every 2  [0,1,2,3,4,5,6,7,8] = [0,2,4,6,8]
--   every 3  [0,1,2,3,4,5,6,7,8] = [0,3,6]
--   every 4  [0,1,2,3,4,5,6,7,8] = [0,4,8]
--   every 5  [0,1,2,3,4,5,6,7,8] = [0,5]
--   every 6  [0,1,2,3,4,5,6,7,8] = [0,6]
--   every 7  [0,1,2,3,4,5,6,7,8] = [0,7]
--   every 8  [0,1,2,3,4,5,6,7,8] = [0,8]
--   every 9  [0,1,2,3,4,5,6,7,8] = [0]
--   every 10 [0,1,2,3,4,5,6,7,8] = [0]
-- Alternative implementations:
-- • every n l = map head (accumulateIterate₀ (length(n) ⌈/₀⌉ n) (skip n) l)
--   every 0         _       = ∅
--   every 1         l       = l
--   every (𝐒(𝐒(n))) ∅       = ∅
-- • every (𝐒(𝐒(n))) (x ⊰ l) = x ⊰ every (𝐒(𝐒(n))) (skip (𝐒(n)) l)
every : ℕ → List(T) → List(T)
every 𝟎      = const ∅
every (𝐒(n)) = impl 𝟎 where
  -- TODO: Is it possible to prove stuff about `every` when `impl` is hidden in a where clause? `impl` essentially contains a counter, so an alternative implementation would be having `every` having two arguments.
  impl : ℕ → List(T) → List(T)
  impl _     ∅       = ∅
  impl 𝟎     (x ⊰ l) = x ⊰ impl n l
  impl (𝐒 k) (x ⊰ l) = impl k l

-- Examples:
--   separate 0  [0,1,2,3,4,5,6,7,8] = []
--   separate 1  [0,1,2,3,4,5,6,7,8] = [[0,1,2,3,4,5,6,7,8]]
--   separate 2  [0,1,2,3,4,5,6,7,8] = [[0,2,4,6,8],[1,3,5,7]]
--   separate 3  [0,1,2,3,4,5,6,7,8] = [[0,3,6],[1,4,7],[2,5,8]]
--   separate 4  [0,1,2,3,4,5,6,7,8] = [[0,4,8],[1,5],[2,6],[3,7]]
--   separate 5  [0,1,2,3,4,5,6,7,8] = [[0,5],[1,6],[2,7],[3,8],[4]]
--   separate 6  [0,1,2,3,4,5,6,7,8] = [[0,6],[1,7],[2,8],[3],[4],[5]]
--   separate 7  [0,1,2,3,4,5,6,7,8] = [[0,7],[1,8],[2],[3],[4],[5],[6]]
--   separate 8  [0,1,2,3,4,5,6,7,8] = [[0,8],[1],[2],[3],[4],[5],[6],[7]]
--   separate 9  [0,1,2,3,4,5,6,7,8] = [[0],[1],[2],[3],[4],[5],[6],[7],[8]]
--   separate 10 [0,1,2,3,4,5,6,7,8] = [[0],[1],[2],[3],[4],[5],[6],[7],[8],[]]
--   separate 11 [0,1,2,3,4,5,6,7,8] = [[0],[1],[2],[3],[4],[5],[6],[7],[8],[],[]]
separate : ℕ → List(T) → List(List(T))
separate n l = map (every n) (accumulateIterate₀ n tail l)

insertIn : T → (l : List(T)) → 𝕟₌(length l) → List(T)
insertIn a l       𝟎      = a ⊰ l
insertIn a ∅       (𝐒(_)) = singleton a
insertIn a (x ⊰ l) (𝐒(i)) = x ⊰ insertIn a l i


{-# OPTIONS --without-K #-}
module Common.Integer where

open import Agda.Builtin.Int public renaming (Int to Integer)


{-# OPTIONS --safe #-}
module Cubical.Data.Int.MoreInts.DiffInt where

open import Cubical.Data.Int.MoreInts.DiffInt.Base public
open import Cubical.Data.Int.MoreInts.DiffInt.Properties public


module Pi where

open import Agda.Builtin.Equality
  using (_≡_; refl)

f
  : {A : Set}
  → {x y : A}
  → (z w : A)
  → x ≡ z
  → z ≡ x
f _ _ refl
  = refl


module _ where

open import Agda.Primitive

module _ (a ℓ ℓ' : Level) where

  mutual
    X : Level
    X = _  -- Agda 2.5.1.1 solves this level meta

    hyp : Set₁
    hyp with (lsuc ℓ')
    ... | _ = Set
      where
        X<=a : Set (X ⊔ a) → Set a
        X<=a A = A

    test : Set₁
    test with (lsuc ℓ)
    ... | _ = Set
      where
        a<=X : Set (X ⊔ a) → Set X
        a<=X A = A


{- This example goes through now that we allow instantiation of
   blocked terms #-}
module Issue439 where

record Σ (A : Set) (B : A → Set) : Set where
 constructor _,_
 field
   p₁ : A
   p₂ : B p₁

open Σ

record ⊤ : Set where

data Tree : Set where
 leaf : Tree
 node : Tree → Tree → Tree

mutual

 U : Tree → Set
 U leaf           = ⊤
 U (node tr₁ tr₂) = Σ (U tr₁) λ a → El a → U tr₂

 El : ∀ {tr} → U tr → Set
 El {leaf}         _       = ⊤
 El {node tr₁ tr₂} (a , b) = (x : El a) → El (b x)

mutual

 data C : Set where
   c : (Γ : C) → T Γ → C

 T : C → Set
 T Γ = Σ Tree (λ tr → E Γ → U tr)

 E : C → Set
 E (c Γ σ) = Σ (E Γ) λ γ → El (p₂ σ γ)

postulate
 e : C
 M : (Γ : C) → T Γ → Set
 z : ∀ {Γ σ} → M (c Γ σ) (p₁ σ , λ γ → p₂ σ (p₁ γ))
 l : ∀ {Γ} σ {τ} → M (c Γ σ) τ →
     M Γ (_ , λ γ → p₂ σ γ , λ v → p₂ τ (γ , v))
 a : ∀ {Γ tr₁ tr₂ σ} →
     M Γ (node tr₁ tr₂ , σ) → M Γ (tr₁ , λ γ → p₁ (σ γ)) →
     M Γ (leaf , _)
 s : ∀ {Γ} → M Γ (leaf , _)

t : ∀ {Γ σ} → M Γ σ → T Γ
t {σ = σ} _ = σ

foo : M (c e (leaf , _)) (leaf , _)
foo = a (l (t s) z) z


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

open import Base
open import Homotopy.TruncatedHIT
open import Integers

module Algebra.FreeGroup {i} (A : Set i) where

{-
The definition is the following

    (0)data freegroup : Set i where
      e : freegroup
      _·_   : A → freegroup → freegroup
      _⁻¹·_ : A → freegroup → freegroup
      right-inverse-· : (x : A) (u : freegroup) → x · (x ⁻¹· u) ≡ u
      left-inverse-·  : (x : A) (u : freegroup) → x ⁻¹· (x · u) ≡ u

("(0)data" means that it’s a higher inductive 0-truncated type)
-}

private
  data #freegroup : Set i where
    #e  : #freegroup
    #·  : A → #freegroup → #freegroup
    #⁻¹· : A → #freegroup → #freegroup

    #top : (f : hSⁿ ⟨0⟩ → #freegroup) → #freegroup

freegroup : Set i
freegroup = #freegroup

e : freegroup
e = #e

_·_ : A → freegroup → freegroup
_·_ = #·

_⁻¹·_ : A → freegroup → freegroup
_⁻¹·_ = #⁻¹·

postulate  -- HIT
  right-inverse-· : (x : A) (u : freegroup) → x · (x ⁻¹· u) ≡ u
  left-inverse-·  : (x : A) (u : freegroup) → x ⁻¹· (x · u) ≡ u

top : (f : hSⁿ ⟨0⟩ → freegroup) → freegroup
top = #top

postulate  -- HIT
  rays : (f : hSⁿ ⟨0⟩ → freegroup) (x : hSⁿ ⟨0⟩) → top f ≡ f x

#freegroup-rec : ∀ {j} (P : freegroup → Set j)
  (base : P e)
  (g   : (x : A) (u : freegroup) → P u → P (x · u))
  (g'  : (x : A) (u : freegroup) → P u → P (x ⁻¹· u))
  (gg' : (x : A) (u : freegroup) (t : P u)
         → transport P (right-inverse-· x u) (g x _ (g' x u t)) ≡ t)
  (g'g : (x : A) (u : freegroup) (t : P u)
         → transport P (left-inverse-· x u) (g' x _ (g x u t)) ≡ t)
  (top* :  (f : hSⁿ ⟨0⟩ → freegroup) (p : (x : hSⁿ ⟨0⟩) → P (f x)) → P (top f))
  (rays* : (f : hSⁿ ⟨0⟩ → freegroup) (p : (x : hSⁿ ⟨0⟩) → P (f x)) (x : hSⁿ ⟨0⟩)
         → transport P (rays f x) (top* f p) ≡ p x)
  → ((t : freegroup) → P t)
#freegroup-rec P base g g' gg' g'g top* rays* #e = base
#freegroup-rec P base g g' gg' g'g top* rays* (#· x u) =
  g x u (#freegroup-rec P base g g' gg' g'g top* rays* u)
#freegroup-rec P base g g' gg' g'g top* rays* (#⁻¹· x u) =
  g' x u (#freegroup-rec P base g g' gg' g'g top* rays* u)
#freegroup-rec P base g g' gg' g'g top* rays* (#top f) =
  top* f (λ x → #freegroup-rec P base g g' gg' g'g top* rays* (f x))

#freegroup-rec-nondep : ∀ {j} (B : Set j)
  (base : B)
  (g   : A → B → B)
  (g'  : A → B → B)
  (gg' : (x : A) (u : B) → (g x (g' x u)) ≡ u)
  (g'g : (x : A) (u : B) → (g' x (g x u)) ≡ u)
  (top* :  (f : hSⁿ ⟨0⟩ → freegroup) (p : hSⁿ ⟨0⟩ → B) → B)
  (rays* : (f : hSⁿ ⟨0⟩ → freegroup) (p : hSⁿ ⟨0⟩ → B) (x : hSⁿ ⟨0⟩)
    → top* f p ≡ p x)
  → freegroup → B
#freegroup-rec-nondep P base g g' gg' g'g top* rays* #e = base
#freegroup-rec-nondep P base g g' gg' g'g top* rays* (#· x u) =
  g x (#freegroup-rec-nondep P base g g' gg' g'g top* rays* u)
#freegroup-rec-nondep P base g g' gg' g'g top* rays* (#⁻¹· x u) =
  g' x (#freegroup-rec-nondep P base g g' gg' g'g top* rays* u)
#freegroup-rec-nondep P base g g' gg' g'g top* rays* (#top f) =
  top* f (λ x → #freegroup-rec-nondep P base g g' gg' g'g top* rays* (f x))

freegroup-rec : ∀ {j} (P : freegroup → Set j)
  (base : P e)
  (g   : (x : A) (u : freegroup) → P u → P (x · u))
  (g'  : (x : A) (u : freegroup) → P u → P (x ⁻¹· u))
  (gg' : (x : A) (u : freegroup) (t : P u)
         → transport P (right-inverse-· x u) (g x _ (g' x u t)) ≡ t)
  (g'g : (x : A) (u : freegroup) (t : P u)
         → transport P (left-inverse-· x u) (g' x _ (g x u t)) ≡ t)
  (p : (u : freegroup) → is-set (P u))
  → ((t : freegroup) → P t)
freegroup-rec P base g g' gg' g'g p =
  #freegroup-rec P base g g' gg' g'g
                 (λ f p₁ → π₁ (u f p₁))
                 (λ f p₁ → π₂ (u f p₁)) where
  u = truncated-has-filling-dep freegroup P ⟨0⟩ (λ ()) (λ f → (top f , rays f))

freegroup-rec-nondep : ∀ {j} (B : Set j)
  (base : B)
  (g   : A → B → B)
  (g'  : A → B → B)
  (gg' : (x : A) (u : B) → (g x (g' x u)) ≡ u)
  (g'g : (x : A) (u : B) → (g' x (g x u)) ≡ u)
  (p : is-set B)
  → freegroup → B
freegroup-rec-nondep B base g g' gg' g'g p =
  #freegroup-rec-nondep B base g g' gg' g'g
                        (λ _ p → π₁ (u p))
                        (λ _ p → π₂ (u p)) where
  u = truncated-has-spheres-filled ⟨0⟩ _ p


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

module library.types.Types where

open import library.Basics
open import library.types.Empty public
open import library.types.Unit public
open import library.types.Bool public
open import library.types.Nat public
open import library.types.Int public
open import library.types.TLevel public
open import library.types.Paths public
open import library.types.Sigma public
open import library.types.Pi public
open import library.types.Coproduct public
open import library.types.Lift public
open import library.types.Circle public
open import library.types.Span public
open import library.types.Pushout public
open import library.types.PushoutFlattening public
open import library.types.Suspension public
open import library.types.Join public
open import library.types.Torus public
open import library.types.Truncation public
open import library.types.Cospan public
open import library.types.Pullback public
open import library.types.Group public
open import library.types.Groupoid public
open import library.types.GroupSet public
open import library.types.KG1 public
open import library.types.Pointed public
open import library.types.LoopSpace public
open import library.types.HomotopyGroup public
open import library.types.PathSet public
open import library.types.FundamentalGroupoid public
open import library.types.Cover public
open import library.types.OneSkeleton public

open import library.types.PathSeq public

-- This should probably not be exported
-- module Generic1HIT {i j} (A : Type i) (B : Type j) (f g : B → A) where
--   open import library.types.Generic1HIT A B f g public


{-# OPTIONS --allow-unsolved-metas #-}
module LiteralProblem where

open import OscarPrelude
open import Problem
open import IsLiteralProblem

record LiteralProblem : Set
 where
  constructor ⟨_⟩
  field
    {problem} : Problem
    isLiteralProblem : IsLiteralProblem problem

open LiteralProblem public

instance EqLiteralProblem : Eq LiteralProblem
EqLiteralProblem = {!!}

open import 𝓐ssertion

instance 𝓐ssertionLiteralProblem : 𝓐ssertion LiteralProblem
𝓐ssertionLiteralProblem = record {}

open import HasSatisfaction

instance HasSatisfactionLiteralProblem : HasSatisfaction LiteralProblem
HasSatisfaction._⊨_ HasSatisfactionLiteralProblem I 𝔓 = I ⊨ problem 𝔓

open import HasDecidableValidation

instance HasDecidableValidationLiteralProblem : HasDecidableValidation LiteralProblem
HasDecidableValidationLiteralProblem = {!!}


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

open import lib.Basics
open import lib.types.Pi
open import lib.types.TwoSemiCategory
open import lib.two-semi-categories.Functor

module lib.two-semi-categories.FunCategory where

module _ {i j k} (A : Type i) (G : TwoSemiCategory j k) where

  private
    module G = TwoSemiCategory G

  fun-El : Type (lmax i j)
  fun-El = A → G.El

  fun-Arr : fun-El → fun-El → Type (lmax i k)
  fun-Arr F G = ∀ a → G.Arr (F a) (G a)

  fun-Arr-level : (F G : fun-El) → has-level 1 (fun-Arr F G)
  fun-Arr-level F G = Π-level (λ a → G.Arr-level (F a) (G a))

  fun-comp : {F G H : fun-El} (α : fun-Arr F G) (β : fun-Arr G H)
    → fun-Arr F H
  fun-comp α β a = G.comp (α a) (β a)

  fun-assoc : {F G H I : fun-El} (α : fun-Arr F G) (β : fun-Arr G H) (γ : fun-Arr H I)
    → fun-comp (fun-comp α β) γ == fun-comp α (fun-comp β γ)
  fun-assoc α β γ = λ= (λ a → G.assoc (α a) (β a) (γ a))

  abstract
    fun-pentagon : {F G H I J : fun-El}
      (α : fun-Arr F G) (β : fun-Arr G H) (γ : fun-Arr H I) (δ : fun-Arr I J)
      → fun-assoc (fun-comp α β) γ δ ◃∙
        fun-assoc α β (fun-comp γ δ) ◃∎
        =ₛ
        ap (λ s → fun-comp s δ) (fun-assoc α β γ) ◃∙
        fun-assoc α (fun-comp β γ) δ ◃∙
        ap (fun-comp α) (fun-assoc β γ δ) ◃∎
    fun-pentagon α β γ δ =
      fun-assoc (fun-comp α β) γ δ ◃∙
      fun-assoc α β (fun-comp γ δ) ◃∎
        =ₛ⟨ ∙-λ= (λ a → G.assoc (G.comp (α a) (β a)) (γ a) (δ a))
                 (λ a → G.assoc (α a) (β a) (G.comp (γ a) (δ a))) ⟩
      λ= (λ a → G.assoc (G.comp (α a) (β a)) (γ a) (δ a) ∙
                G.assoc (α a) (β a) (G.comp (γ a) (δ a))) ◃∎
        =ₛ₁⟨ ap λ= (λ= (λ a → =ₛ-out (G.pentagon-identity (α a) (β a) (γ a) (δ a)))) ⟩
      λ= (λ a → ap (λ s → G.comp s (δ a)) (G.assoc (α a) (β a) (γ a)) ∙
                G.assoc (α a) (G.comp (β a) (γ a)) (δ a) ∙
                ap (G.comp (α a)) (G.assoc (β a) (γ a) (δ a))) ◃∎
        =ₛ⟨ λ=-∙∙ (λ a → ap (λ s → G.comp s (δ a)) (G.assoc (α a) (β a) (γ a)))
                  (λ a → G.assoc (α a) (G.comp (β a) (γ a)) (δ a))
                  (λ a → ap (G.comp (α a)) (G.assoc (β a) (γ a) (δ a))) ⟩
      λ= (λ a → ap (λ s → G.comp s (δ a)) (G.assoc (α a) (β a) (γ a))) ◃∙
      fun-assoc α (fun-comp β γ) δ ◃∙
      λ= (λ a → ap (G.comp (α a)) (G.assoc (β a) (γ a) (δ a))) ◃∎
        =ₛ₁⟨ 0 & 1 & ! (λ=-ap (λ a s → G.comp s (δ a)) (λ a → G.assoc (α a) (β a) (γ a))) ⟩
      ap (λ s → fun-comp s δ) (fun-assoc α β γ) ◃∙
      fun-assoc α (fun-comp β γ) δ ◃∙
      λ= (λ a → ap (G.comp (α a)) (G.assoc (β a) (γ a) (δ a))) ◃∎
        =ₛ₁⟨ 2 & 1 & ! (λ=-ap (λ a → G.comp (α a)) (λ a → G.assoc (β a) (γ a) (δ a))) ⟩
      ap (λ s → fun-comp s δ) (fun-assoc α β γ) ◃∙
      fun-assoc α (fun-comp β γ) δ ◃∙
      ap (fun-comp α) (fun-assoc β γ δ) ◃∎ ∎ₛ

  fun-cat : TwoSemiCategory (lmax i j) (lmax i k)
  fun-cat =
    record
    { El = fun-El
    ; Arr = fun-Arr
    ; Arr-level = fun-Arr-level
    ; two-semi-cat-struct =
      record
      { comp = fun-comp
      ; assoc = fun-assoc
      ; pentagon-identity = fun-pentagon
      }
    }

module _ {i j₁ k₁ j₂ k₂} (A : Type i) {G : TwoSemiCategory j₁ k₁} {H : TwoSemiCategory j₂ k₂}
  (F : TwoSemiFunctor G H) where

  private
    module G = TwoSemiCategory G
    module H = TwoSemiCategory H
    module F = TwoSemiFunctor F
    module fun-G = TwoSemiCategory (fun-cat A G)
    module fun-H = TwoSemiCategory (fun-cat A H)

  fun-F₀ : fun-G.El → fun-H.El
  fun-F₀ I = λ a → F.F₀ (I a)

  fun-F₁ : {I J : fun-G.El} → fun-G.Arr I J → fun-H.Arr (fun-F₀ I) (fun-F₀ J)
  fun-F₁ α = λ a → F.F₁ (α a)

  fun-pres-comp : {I J K : fun-G.El} (α : fun-G.Arr I J) (β : fun-G.Arr J K)
    → fun-F₁ (fun-G.comp α β) == fun-H.comp (fun-F₁ α) (fun-F₁ β)
  fun-pres-comp α β = λ= (λ a → F.pres-comp (α a) (β a))

  abstract
    fun-pres-comp-coh : {I J K L : fun-G.El}
      (α : fun-G.Arr I J) (β : fun-G.Arr J K) (γ : fun-G.Arr K L)
      → fun-pres-comp (fun-G.comp α β) γ ◃∙
        ap (λ s → fun-H.comp s (fun-F₁ γ)) (fun-pres-comp α β) ◃∙
        fun-H.assoc (fun-F₁ α) (fun-F₁ β) (fun-F₁ γ) ◃∎
        =ₛ
        ap fun-F₁ (fun-G.assoc α β γ) ◃∙
        fun-pres-comp α (fun-G.comp β γ) ◃∙
        ap (fun-H.comp (fun-F₁ α)) (fun-pres-comp β γ) ◃∎
    fun-pres-comp-coh α β γ =
      fun-pres-comp (fun-G.comp α β) γ ◃∙
      ap (λ s → fun-H.comp s (fun-F₁ γ)) (fun-pres-comp α β) ◃∙
      fun-H.assoc (fun-F₁ α) (fun-F₁ β) (fun-F₁ γ) ◃∎
        =ₛ₁⟨ 1 & 1 & λ=-ap (λ a s → H.comp s (fun-F₁ γ a) ) (λ a → F.pres-comp (α a) (β a)) ⟩
      fun-pres-comp (fun-G.comp α β) γ ◃∙
      λ= (λ a → ap (λ s → H.comp s (fun-F₁ γ a)) (F.pres-comp (α a) (β a))) ◃∙
      fun-H.assoc (fun-F₁ α) (fun-F₁ β) (fun-F₁ γ) ◃∎
        =ₛ⟨ ∙∙-λ= (λ a → F.pres-comp (G.comp (α a) (β a)) (γ a))
                  (λ a → ap (λ s → H.comp s (fun-F₁ γ a)) (F.pres-comp (α a) (β a)))
                  (λ a → H.assoc (fun-F₁ α a) (fun-F₁ β a) (fun-F₁ γ a)) ⟩
      λ= (λ a → F.pres-comp (G.comp (α a) (β a)) (γ a) ∙
                ap (λ s → H.comp s (fun-F₁ γ a)) (F.pres-comp (α a) (β a)) ∙
                H.assoc (fun-F₁ α a) (fun-F₁ β a) (fun-F₁ γ a)) ◃∎
        =ₛ₁⟨ ap λ= (λ= (λ a → =ₛ-out (F.pres-comp-coh (α a) (β a) (γ a)))) ⟩
      λ= (λ a → ap F.F₁ (G.assoc (α a) (β a) (γ a)) ∙
                F.pres-comp (α a) (G.comp (β a) (γ a)) ∙
                ap (H.comp (fun-F₁ α a)) (F.pres-comp (β a) (γ a))) ◃∎
        =ₛ⟨ λ=-∙∙ (λ a → ap F.F₁ (G.assoc (α a) (β a) (γ a)))
                  (λ a → F.pres-comp (α a) (G.comp (β a) (γ a)))
                  (λ a → ap (H.comp (fun-F₁ α a)) (F.pres-comp (β a) (γ a))) ⟩
      λ= (λ a → ap F.F₁ (G.assoc (α a) (β a) (γ a))) ◃∙
      fun-pres-comp α (fun-G.comp β γ) ◃∙
      λ= (λ a → ap (H.comp (fun-F₁ α a)) (F.pres-comp (β a) (γ a))) ◃∎
        =ₛ₁⟨ 0 & 1 & ! $ λ=-ap (λ _ → F.F₁) (λ a → G.assoc (α a) (β a) (γ a)) ⟩
      ap fun-F₁ (fun-G.assoc α β γ) ◃∙
      fun-pres-comp α (fun-G.comp β γ) ◃∙
      λ= (λ a → ap (H.comp (fun-F₁ α a)) (F.pres-comp (β a) (γ a))) ◃∎
        =ₛ₁⟨ 2 & 1 & ! $ λ=-ap (λ a → H.comp (fun-F₁ α a)) (λ a → F.pres-comp (β a) (γ a)) ⟩
      ap fun-F₁ (fun-G.assoc α β γ) ◃∙
      fun-pres-comp α (fun-G.comp β γ) ◃∙
      ap (fun-H.comp (fun-F₁ α)) (fun-pres-comp β γ) ◃∎ ∎ₛ

  fun-functor-map : TwoSemiFunctor (fun-cat A G) (fun-cat A H)
  fun-functor-map =
    record
    { F₀ = fun-F₀
    ; F₁ = fun-F₁
    ; pres-comp = fun-pres-comp
    ; pres-comp-coh = fun-pres-comp-coh
    }


True : Prop
True = {P : Prop} → P → P


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Data.Integer as ℤ using (ℤ)
open import Data.Rational as ℚ using (ℚ)

module simple-untypedDecls-temp-output where

fin3 : ∀ {_x0 : Set} {{_x1 : HasNatLits _x0}} → _x0
fin3 = 3

intMinus3 : ∀ {_x4 : Set} {{_x5 : HasNatLits _x4}} {{_x6 : HasNeg _x4}} → _x4
intMinus3 = - 3

ratMinus3 : ∀ {_x10 : Set} {{_x11 : HasRatLits _x10}} {{_x12 : HasNeg _x10}} → _x10
ratMinus3 = - (ℤ.+ 3 ℚ./ 1)


------------------------------------------------------------------------------
-- Testing the class AgdaInternal.RemoveProofTerms.RemoveVar: Lam term
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module RemoveVar.LamTerm where

-- We add 3 to the fixities of the standard library.
infixr 8 _∷_
infixr 7 _,_
infix  7 _≡_ _≈_
infixr 5 _∧_
infix 5  ∃

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

postulate
  D      : Set
  _∷_    : D → D → D
  Stream : D → Set
  _≈_    : D → D → Set

data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

syntax ∃ (λ x → e) = ∃[ x ] e

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

postulate
  Stream-gfp₂ : (P : D → Set) →
                -- P is post-fixed point of StreamF.
                (∀ {xs} → P xs → ∃[ x' ] ∃[ xs' ] P xs' ∧ xs ≡ x' ∷ xs') →
                -- Stream is greater than P.
                ∀ {xs} → P xs → Stream xs

postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- See Issue #81.
P : D → Set
P ws = ∃[ zs ] ws ≈ zs
{-# ATP definition P #-}

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P helper (ys , xs≈ys)
  where
  postulate helper : ∀ {ws} → P ws → ∃[ w' ] ∃[ ws' ] P ws' ∧ ws ≡ w' ∷ ws'
  {-# ATP prove helper #-}


{-# OPTIONS --warning ShadowingInTelescope --allow-unsolved-metas #-}

open import Agda.Primitive

-- warning here
data _~_ {a a : Level} {A : Set a} (a : A) : A -> Set where
  refl : a ~ a

module _ {a} {A : Set a} where

-- nothing: the repetition is in separate telescopes
  data Eq (a : A) : (a : A) → Set where
    refl : Eq a a

-- warning here
f : ∀ (a : Level) → ∀ {A : Set a} A ~ A → Set → Set
f a A ~ B = λ x → x

-- nothing here: the repetition is in separate telescopes
f' : ∀ a → Set a → Set a
f' a = g a where

  g : ∀ a → Set a → Set a
  g a z = z

-- nothing here: the variable {a} is not user-written
h : ∀ {a} → Set a → Set a
h = g _ where

  g : ∀ a → Set a → Set a
  g a z = z

i : (Set → Set → Set) → (∀ _ _ → _)
i f = f


{-
Joseph Eremondi
Utrecht University Capita Selecta
UU# 4229924
July 22, 2015
-}

module RETypes where

open import Data.Char
open import Data.List
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Data.Product

--Tag for whether an RE can match the empty string or not
data Null? : Set where
  NonNull : Null?
  MaybeNull : Null?

--Equivalent of AND for Nullable
data NullTop : Null? -> Null? -> Null? -> Set where
  BothNullT : NullTop MaybeNull MaybeNull MaybeNull
  LeftNullT : NullTop MaybeNull NonNull NonNull
  RightNullT : NullTop NonNull MaybeNull NonNull
  BothNonNullT : NullTop NonNull NonNull NonNull

--Equivalent of OR for null
data NullBottom : Null? -> Null? -> Null? -> Set where
  BothNullB : NullBottom NonNull NonNull NonNull
  LeftNullB : NullBottom MaybeNull NonNull MaybeNull
  RightNullB : NullBottom NonNull MaybeNull MaybeNull
  BothNonNullB : NullBottom MaybeNull MaybeNull MaybeNull

--Standard definition of regular expressions
--plus nullable tags. Star can only accept non-nullable REs.
data RE : Null? -> Set where
  ε : RE MaybeNull
  ∅ : RE NonNull
  Lit : Char -> RE NonNull
  --Union is nullable if either input is nullable
  _+_ : {n1 n2 n3 : Null? }
    -> {nb : NullBottom n1 n2 n3}
    -> RE n1
    -> RE n2
    -> RE n3
  --Concatenation is nullable only if both inputs are nullable
  _·_ :  {n1 n2 n3 : Null? }
    -> {nt : NullTop n1 n2 n3}
    -> RE n1
    -> RE n2
    -> RE n3
  --Star always matches the empty string
  _* : RE NonNull -> RE MaybeNull

--Witness type, defining what it means for a word to match a regular expression
data REMatch : {n : Null?} -> List Char -> RE n -> Set where
  EmptyMatch : REMatch [] ε
  LitMatch : (c : Char) -> REMatch (c ∷ []) (Lit c)
  LeftPlusMatch :
    {n1 n2 n3 : Null? }
    -> {nb : NullBottom n1 n2 n3}
    -> {s : List Char} {r1 : RE n1}
    -> (r2 : RE n2)
    -> REMatch s r1
    -> REMatch {n3} s (_+_ {n1} {n2} {n3} {nb} r1 r2)
  RightPlusMatch :
    {n1 n2 n3 : Null? }
    -> {nb : NullBottom n1 n2 n3}
    -> {s : List Char} -> (r1 : RE n1) -> {r2 : RE n2}
    -> REMatch s r2
    -> REMatch {n3} s (_+_ {n1} {n2} {n3} {nb} r1 r2)
  ConcatMatch :
    {n1 n2 n3 : Null? }
    -> {nt : NullTop n1 n2 n3}
    -> {s1 s2 s3 : List Char} {spf : s1 ++ s2 ≡ s3} {r1 : RE n1} {r2 : RE n2}
    -> REMatch s1 r1
    -> REMatch s2 r2
    -> REMatch {n3} s3 (_·_ {n1} {n2} {n3} {nt} r1 r2)
  EmptyStarMatch : {r : RE NonNull} -> REMatch [] (r *)
  StarMatch :
    {s1 s2 s3 : List Char} {spf : (s1 ++ s2) ≡ s3} {r : RE NonNull}
    -> REMatch s1 r
    -> REMatch s2 (r *)
    -> REMatch s3 (r *)

extendRightNonNull : (s : List Char) -> (sRest : List Char) -> (∃ λ c -> ∃ λ t -> (s ≡ c ∷ t)) -> (∃ λ c1 -> ∃ λ t1 -> (s ++ sRest ≡ c1 ∷ t1))
extendRightNonNull .(c ∷ t) sRest (c , t , refl) = c , t ++ sRest , refl

extendLeftNonNull : (s : List Char) -> (sRest : List Char) -> (∃ λ c -> ∃ λ t -> (s ≡ c ∷ t)) -> (∃ λ c1 -> ∃ λ t1 -> (sRest ++ s ≡ c1 ∷ t1))
extendLeftNonNull .(t ∷ c) [] (t , c , refl) = t , c , refl
extendLeftNonNull .(t ∷ c) (x ∷ sRest) (t , c , refl)  = x , sRest ++ t ∷ c , refl

nullCorrect : (r : RE NonNull ) -> (s : List Char) -> REMatch s r -> ∃ λ c -> ∃ λ t -> (s ≡ c ∷ t)
nullCorrect .(Lit c) .(c ∷ []) (LitMatch c) = c , [] , refl
nullCorrect ._ s (LeftPlusMatch {nb = BothNullB} {r1 = r1} r2 match) = nullCorrect r1 s match
nullCorrect ._ s (RightPlusMatch {nb = BothNullB} r1 {r2 = r2} match) = nullCorrect r2 s match
nullCorrect (r1 · r2) s (ConcatMatch {nt = LeftNullT} {s2 = s2} match match₁) with nullCorrect r2 s2 match₁
nullCorrect (r1 · r2) .(s1 ++ c ∷ t) (ConcatMatch {.MaybeNull} {.NonNull} {.NonNull} {LeftNullT} {s1} {.(c ∷ t)} {.(s1 ++ c ∷ t)} {refl} match match₁) | c , t , refl = extendLeftNonNull (c ∷ t) s1 (c , t , refl)
nullCorrect (r1 · r2) ._ (ConcatMatch {nt = RightNullT} {s1 = s1} {spf = refl} match match₁) with nullCorrect r1 s1 match
nullCorrect (r1 · r2) .((c ∷ t) ++ s2) (ConcatMatch {.NonNull} {.MaybeNull} {.NonNull} {RightNullT} {.(c ∷ t)} {s2} {.((c ∷ t) ++ s2)} {refl} match match₁) | c , t , refl = extendRightNonNull (c ∷ t) s2 (c , t , refl)
nullCorrect (r1 · r2) s (ConcatMatch {nt = BothNonNullT} {s1 = s1} {s2 = s2} match match₁) with nullCorrect r1 s1 match
nullCorrect (r1 · r2) .(c ∷ t ++ s2) (ConcatMatch {.NonNull} {.NonNull} {.NonNull} {BothNonNullT} {.(c ∷ t)} {s2} {.(c ∷ t ++ s2)} {refl} match match₁) | c , t , refl = extendRightNonNull (c ∷ t) s2 (c , t , refl)


{-# OPTIONS --copatterns #-}

open import Common.Nat
open import Common.IO
open import Common.Unit

record Test : Set where
  field
    a b c : Nat

f : Test -> Nat
f r = a + b + c
  where open Test r

open Test

r1 : Test
a r1 = 100
b r1 = 120
c r1 = 140

r2 : Test
c r2 = 400
a r2 = 200
b r2 = 300

g : Nat
g = f r1 + a m + b m + c m
  where m = r2

main : IO Unit
main = printNat g

-- Expected Output: 1260


-- 2012-10-20 Andreas
module Issue721c where

data Bool : Set where
  false true : Bool

record Foo (b : Bool) : Set where
  field
    _*_ : Bool → Bool → Bool

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

record ∃ {A : Set} (B : A → Set) : Set where
  constructor pack
  field fst : A
        snd : B fst

dontExpandTooMuch : (F : Foo false) → ∃ λ t → t ≡ t
dontExpandTooMuch F = pack t t
  where open Foo F
        d = λ x → x * x
        t = d (d (d (d true)))
-- t should not be expanded in the error message


module Dave.Logic.Theorems where

    K : {A B : Set} → A → B → A
    K a b = a

    S : {A B C : Set} → (A → B → C) → (A → B) → A → C
    S = λ f → λ g → λ a → f a (g a)


module _ where

module M where

  infixr 3 _!_
  data D : Set₁ where
    _!_ : D → D → D

infixl 3 _!_
data E : Set₁ where
  _!_ : E → E → E

open M

postulate
  [_]E : E → Set
  [_]D : D → Set

fail : ∀ {d e} → [ (d ! d) ! d ]D → [ e ! (e ! e) ]E
fail x = x -- should use the right fixity for the overloaded constructor


{-# OPTIONS --safe #-}
module Cubical.HITs.Pushout.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Unit
open import Cubical.Data.Sigma

open import Cubical.HITs.Susp.Base

data Pushout {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''}
             (f : A → B) (g : A → C) : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) where
  inl : B → Pushout f g
  inr : C → Pushout f g
  push : (a : A) → inl (f a) ≡ inr (g a)

-- cofiber (equivalent to Cone in Cubical.HITs.MappingCones.Base)
cofib : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) → Type _
cofib f = Pushout (λ _ → tt) f

cfcod : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) → B → cofib f
cfcod f = inr

-- Symmetry of pushout

symPushout : {ℓ ℓ' ℓ'' : Level} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''}
  → (f : A → B) (g : A → C) → Pushout f g ≃ Pushout g f
symPushout f g = isoToEquiv
  (iso (λ { (inl x) → inr x ; (inr x) → inl x ; (push x i) → push x (~ i)})
       (λ { (inl x) → inr x ; (inr x) → inl x ; (push x i) → push x (~ i)})
       (λ { (inl x) → refl  ; (inr x) → refl  ; (push x i) → refl})
       (λ { (inl x) → refl  ; (inr x) → refl  ; (push x i) → refl}))

-- Suspension defined as a pushout

PushoutSusp : ∀ {ℓ} (A : Type ℓ) → Type ℓ
PushoutSusp A = Pushout {A = A} {B = Unit} {C = Unit} (λ _ → tt) (λ _ → tt)

PushoutSusp→Susp : ∀ {ℓ} {A : Type ℓ} → PushoutSusp A → Susp A
PushoutSusp→Susp (inl _) = north
PushoutSusp→Susp (inr _) = south
PushoutSusp→Susp (push a i) = merid a i

Susp→PushoutSusp : ∀ {ℓ} {A : Type ℓ} → Susp A → PushoutSusp A
Susp→PushoutSusp north = inl tt
Susp→PushoutSusp south = inr tt
Susp→PushoutSusp (merid a i) = push a i

Susp→PushoutSusp→Susp : ∀ {ℓ} {A : Type ℓ} (x : Susp A) →
                        PushoutSusp→Susp (Susp→PushoutSusp x) ≡ x
Susp→PushoutSusp→Susp north = refl
Susp→PushoutSusp→Susp south = refl
Susp→PushoutSusp→Susp (merid _ _) = refl

PushoutSusp→Susp→PushoutSusp : ∀ {ℓ} {A : Type ℓ} (x : PushoutSusp A) →
                               Susp→PushoutSusp (PushoutSusp→Susp x) ≡ x
PushoutSusp→Susp→PushoutSusp (inl _) = refl
PushoutSusp→Susp→PushoutSusp (inr _) = refl
PushoutSusp→Susp→PushoutSusp (push _ _) = refl

PushoutSuspIsoSusp : ∀ {ℓ} {A : Type ℓ} → Iso (PushoutSusp A) (Susp A)
Iso.fun PushoutSuspIsoSusp = PushoutSusp→Susp
Iso.inv PushoutSuspIsoSusp = Susp→PushoutSusp
Iso.rightInv PushoutSuspIsoSusp = Susp→PushoutSusp→Susp
Iso.leftInv PushoutSuspIsoSusp = PushoutSusp→Susp→PushoutSusp

PushoutSusp≃Susp : ∀ {ℓ} {A : Type ℓ} → PushoutSusp A ≃ Susp A
PushoutSusp≃Susp = isoToEquiv PushoutSuspIsoSusp

PushoutSusp≡Susp : ∀ {ℓ} {A : Type ℓ} → PushoutSusp A ≡ Susp A
PushoutSusp≡Susp = isoToPath PushoutSuspIsoSusp

-- Generalised pushout, used in e.g. BlakersMassey
data PushoutGen {ℓ₁ ℓ₂ ℓ₃ : Level} {X : Type ℓ₁} {Y : Type ℓ₂}
                (Q : X → Y → Type ℓ₃) : Type (ℓ-max (ℓ-max ℓ₁ ℓ₂) ℓ₃)
     where
     inl : X → PushoutGen Q
     inr : Y → PushoutGen Q
     push : {x : X} {y : Y} → Q x y → inl x ≡ inr y

-- The usual pushout is a special case of the above
module _ {ℓ₁ ℓ₂ ℓ₃ : Level} {A : Type ℓ₁} {B : Type ℓ₂} {C : Type ℓ₃}
         (f : A → B) (g : A → C) where
  open Iso

  doubleFib : B → C → Type _
  doubleFib b c = Σ[ a ∈ A ] (f a ≡ b) × (g a ≡ c)

  PushoutGenFib = PushoutGen doubleFib

  Pushout→PushoutGen : Pushout f g → PushoutGenFib
  Pushout→PushoutGen (inl x) = inl x
  Pushout→PushoutGen (inr x) = inr x
  Pushout→PushoutGen (push a i) = push (a , refl , refl) i

  PushoutGen→Pushout : PushoutGenFib → Pushout f g
  PushoutGen→Pushout (inl x) = inl x
  PushoutGen→Pushout (inr x) = inr x
  PushoutGen→Pushout (push (x , p , q) i) =
    ((λ i → inl (p (~ i))) ∙∙ push x ∙∙ (λ i → inr (q i))) i

  IsoPushoutPushoutGen : Iso (Pushout f g) (PushoutGenFib)
  fun IsoPushoutPushoutGen = Pushout→PushoutGen
  inv IsoPushoutPushoutGen = PushoutGen→Pushout
  rightInv IsoPushoutPushoutGen (inl x) = refl
  rightInv IsoPushoutPushoutGen (inr x) = refl
  rightInv IsoPushoutPushoutGen (push (x , p , q) i) j = lem x p q j i
    where
    lem : {b : B} {c : C} (x : A) (p : f x ≡ b) (q : g x ≡ c)
      → cong Pushout→PushoutGen (cong PushoutGen→Pushout (push (x , p , q)))
      ≡ push (x , p , q)
    lem {c = c} x =
      J (λ b p → (q : g x ≡ c)
        → cong Pushout→PushoutGen
           (cong PushoutGen→Pushout (push (x , p , q)))
         ≡ push (x , p , q))
        (J (λ c q → cong Pushout→PushoutGen
                      (cong PushoutGen→Pushout (push (x , refl , q)))
         ≡ push (x , refl , q))
         (cong (cong Pushout→PushoutGen) (sym (rUnit (push x)))))
  leftInv IsoPushoutPushoutGen (inl x) = refl
  leftInv IsoPushoutPushoutGen (inr x) = refl
  leftInv IsoPushoutPushoutGen (push a i) j = rUnit (push a) (~ j) i


open import Relation.Binary.Core

module PLRTree.Push.Permutation {A : Set}
                     (_≤_ : A → A → Set)
                     (tot≤ : Total _≤_) where

open import Data.List
open import Data.Sum
open import Induction.WellFounded
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import List.Permutation.Base.Equivalence A
open import PLRTree {A}
open import PLRTree.Complete {A}
open import PLRTree.Drop _≤_ tot≤
open import PLRTree.Equality {A}
open import PLRTree.Order {A}
open import PLRTree.Order.Properties {A}

lemma-push-∼-≃ : {l r : PLRTree}(x : A) → Complete l → Complete r → l ≃ r → (acc : Acc _≺_ (node perfect x l r)) → flatten (push (node perfect x l r) acc) ∼ flatten (node right x l r)
lemma-push-∼-≃ {l} {r} x cl cr l≃r (acc rs)
    with l | r | l≃r | cl | cr
... | leaf | leaf | ≃lf | _ | _ = ∼x /head /head ∼[]
... | node perfect x' l' r' | node perfect x'' l'' r'' | ≃nd .x' .x'' l'≃r' l''≃r'' l'≃l'' | perfect .x' cl' cr' _ | perfect .x'' cl'' cr'' _
    with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
... | inj₁ x≤x' | inj₁ x≤x'' | _ = refl∼
... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr

lemma-push-∼-⋗ : {l r : PLRTree}(x : A) → Complete l → Complete r → l ⋗ r → (acc : Acc _≺_ (node right x l r)) → flatten (push (node right x l r) acc) ∼ flatten (node right x l r)
lemma-push-∼-⋗ {l} {r} x cl cr l⋗r (acc rs)
    with l | r | l⋗r | cl | cr
... | leaf | _ | () | _ | _
... | node perfect x' leaf leaf | leaf | ⋗lf .x' | perfect .x' leaf leaf ≃lf | leaf
    with tot≤ x x'
... | inj₁ x≤x' = ∼x /head /head (∼x /head /head ∼[])
... | inj₂ x'≤x = ∼x (/tail /head) /head (∼x /head /head ∼[])
lemma-push-∼-⋗ x cl cr l⋗r (acc rs) | node perfect x' l' r' | node perfect x'' l'' r'' | ⋗nd .x' .x'' l'≃r' l''≃r'' l'⋗l'' | perfect .x' cl' cr' _ | perfect .x'' cl'' cr'' _
    with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
... | inj₁ x≤x' | inj₁ x≤x'' | _ = refl∼
... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr

mutual
  lemma-push-∼-⋙ : {l r : PLRTree}(x : A) → Complete l → Complete r → l ⋙ r → (acc : Acc _≺_ (node right x l r)) → flatten (push (node right x l r) acc) ∼ flatten (node right x l r)
  lemma-push-∼-⋙ {l} {r} x cl cr l⋙r (acc rs)
      with l | r | l⋙r | cl | cr
  ... | leaf | _ | ⋙p () | _ | _
  ... | node perfect x' leaf leaf | leaf | ⋙p (⋗lf .x') | perfect .x' leaf leaf ≃lf | leaf = lemma-push-∼-⋗ x (perfect x' leaf leaf ≃lf) leaf (⋗lf x') (acc rs)
  ... | node perfect x' l' r' | node perfect x'' l'' r'' | ⋙p (⋗nd .x' .x'' l'≃r' l''≃r'' l'⋗l'') | perfect .x' cl' cr' _ | perfect .x'' cl'' cr'' _ =
             lemma-push-∼-⋗ x (perfect x' cl' cr' l'≃r') (perfect x'' cl'' cr'' l''≃r'') (⋗nd x' x'' l'≃r' l''≃r'' l'⋗l'') (acc rs)
  ... | node perfect x' leaf leaf | node left _ _ _ | ⋙p () | _ | _
  ... | node perfect x' leaf leaf | node right _ _ _ | ⋙p () | _ | _
  ... | node perfect x' l' r' | node left x'' l'' r'' | ⋙l .x' .x'' l'≃r' l''⋘r'' l'⋗r'' | perfect .x' cl' cr' _ | left .x'' cl'' cr'' _
      with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
  ... | inj₁ x≤x' | inj₁ x≤x'' | _ = refl∼
  ... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height left x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node left x l'' r'') (lemma-≺-right perfect x _l (node left x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-⋘ x cl'' cr'' l''⋘r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  ... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node left x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node left x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height left x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node left x l'' r'') (lemma-≺-right perfect x _l (node left x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-⋘ x cl'' cr'' l''⋘r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  lemma-push-∼-⋙ x cl cr l⋙r (acc rs)| node perfect x' l' r' | node right x'' l'' r'' | ⋙r .x' .x'' l'≃r' l''⋙r'' l'≃l'' | perfect .x' cl' cr' _ | right .x'' cl'' cr'' _
      with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
  ... | inj₁ x≤x' | inj₁ x≤x'' | _ = refl∼
  ... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height right x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node right x l'' r'') (lemma-≺-right perfect x _l (node right x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-⋙ x cl'' cr'' l''⋙r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  ... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node right x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height perfect x x' l' r' =
             let _r = node right x'' l'' r'' ;
                  acc-xl'r' = rs (node perfect x l' r') (lemma-≺-left perfect x (node perfect x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-≃ x cl' cr' l'≃r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height right x x'' l'' r'' =
             let _l = node perfect x' l' r' ;
                  acc-xl''r'' = rs (node right x l'' r'') (lemma-≺-right perfect x _l (node right x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-⋙ x cl'' cr'' l''⋙r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  lemma-push-∼-⋙ x cl cr l⋙r (acc rs) | node left _ _ _ | _ | ⋙p () | _ | _
  lemma-push-∼-⋙ x cl cr l⋙r (acc rs) | node right _ _ _ | _ | ⋙p () | _ | _

  lemma-push-∼-⋘ : {l r : PLRTree}(x : A) → Complete l → Complete r → l ⋘ r → (acc : Acc _≺_ (node left x l r)) → flatten (push (node left x l r) acc) ∼ flatten (node left x l r)
  lemma-push-∼-⋘ {l} {r} x cl cr l⋘r (acc rs)
      with l | r | l⋘r | cl | cr
  ... | node left x' l' r' | node perfect x'' l'' r'' | l⋘ .x' .x'' l'⋘r' l''≃r'' r'≃l'' | left .x' cl' cr' _ | perfect .x'' cl'' cr'' _
      with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
  ... | inj₁ x≤x' | inj₁ x≤x'' | _ = refl∼
  ... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node left x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  ... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height left x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node left x l' r') (lemma-≺-left perfect x (node left x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-⋘ x cl' cr' l'⋘r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height left x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node left x l' r') (lemma-≺-left perfect x (node left x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-⋘ x cl' cr' l'⋘r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node left x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  lemma-push-∼-⋘ x cl cr l⋘r (acc rs) | node right x' (node perfect x'' leaf leaf) leaf | node perfect x''' leaf leaf | x⋘ .x' .x'' .x''' | right .x' (perfect .x'' leaf leaf ≃lf) leaf (⋙p (⋗lf .x'')) | perfect .x''' leaf leaf ≃lf
      with tot≤ x x' | tot≤ x x''' | tot≤ x' x'''
  ... | inj₁ x≤x' | inj₁ x≤x''' | _ = refl∼
  ... | inj₁ x≤x' | inj₂ x'''≤x | _ =
             let _l = node perfect x' (node perfect x'' leaf leaf) leaf ;
                  acc-x = rs (node perfect x leaf leaf) (lemma-≺-right perfect x _l (node perfect x''' leaf leaf)) ;
                  x'''flfpx∼x'''flx = lemma++∼l {x''' ∷ flatten _l} (lemma-push-∼-≃ x leaf leaf ≃lf acc-x) ;
                  flxfr/x'''⟶flx = lemma++/l {x'''} {flatten _l} (/tail /head) ;
                  x'''flx∼flxfr = ∼x /head flxfr/x'''⟶flx refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x'''flx∼xflfr = trans∼ x'''flx∼flxfr flxfr∼xflfr
             in trans∼ x'''flfpx∼x'''flx x'''flx∼xflfr
  ... | inj₂ x'≤x | inj₁ x≤x''' | _ =
             let _r = node perfect x''' leaf leaf ;
                  acc-xx'' = rs (node right x (node perfect x'' leaf leaf) leaf) (lemma-≺-left perfect x (node right x' (node perfect x'' leaf leaf) leaf) _r) ;
                  fpxx''x'''∼xx''x''' = lemma++∼r (lemma-push-∼-⋗ x (perfect x'' leaf leaf ≃lf) leaf (⋗lf x'') acc-xx'') ;
                  x'fpxx''x'''∼x'xx''x''' = ∼x /head /head fpxx''x'''∼xx''x''' ;
                  x'xx''x'''∼xx'x''x''' = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxx''x'''∼x'xx''x''' x'xx''x'''∼xx'x''x'''
  ... | inj₂ x'≤x | inj₂ x'''≤x | inj₁ x'≤x''' =
             let _r = node perfect x''' leaf leaf ;
                  acc-xx'' = rs (node right x (node perfect x'' leaf leaf) leaf) (lemma-≺-left perfect x (node right x' (node perfect x'' leaf leaf) leaf) _r) ;
                  fpxx''x'''∼xx''x''' = lemma++∼r (lemma-push-∼-⋗ x (perfect x'' leaf leaf ≃lf) leaf (⋗lf x'') acc-xx'') ;
                  x'fpxx''x'''∼x'xx''x''' = ∼x /head /head fpxx''x'''∼xx''x''' ;
                  x'xx''x'''∼xx'x''x''' = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxx''x'''∼x'xx''x''' x'xx''x'''∼xx'x''x'''
  ... | inj₂ x'≤x | inj₂ x'''≤x | inj₂ x'''≤x' =
             let _l = node perfect x' (node perfect x'' leaf leaf) leaf ;
                  acc-x = rs (node perfect x leaf leaf) (lemma-≺-right perfect x _l (node perfect x''' leaf leaf)) ;
                  x'''flfpx∼x'''flx = lemma++∼l {x''' ∷ flatten _l} (lemma-push-∼-≃ x leaf leaf ≃lf acc-x) ;
                  flxfr/x'''⟶flx = lemma++/l {x'''} {flatten _l} (/tail /head) ;
                  x'''flx∼flxfr = ∼x /head flxfr/x'''⟶flx refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x'''flx∼xflfr = trans∼ x'''flx∼flxfr flxfr∼xflfr
             in trans∼ x'''flfpx∼x'''flx x'''flx∼xflfr
  lemma-push-∼-⋘ x cl cr l⋘r (acc rs) | node right x' l' r' | node perfect x'' l'' r'' | r⋘ .x' .x'' l'⋙r' l''≃r'' l'⋗l'' | right .x' cl' cr' _ | perfect .x'' cl'' cr'' _
      with tot≤ x x' | tot≤ x x'' | tot≤ x' x''
  ... | inj₁ x≤x' | inj₁ x≤x'' | _ = refl∼
  ... | inj₁ x≤x' | inj₂ x''≤x | _ rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node right x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr
  ... | inj₂ x'≤x | inj₁ x≤x'' | _ rewrite lemma-≡-height right x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node right x l' r') (lemma-≺-left perfect x (node right x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-⋙ x cl' cr' l'⋙r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₁ x'≤x'' rewrite lemma-≡-height right x x' l' r' =
             let _r = node perfect x'' l'' r'' ;
                  acc-xl'r' = rs (node right x l' r') (lemma-≺-left perfect x (node right x' l' r') _r) ;
                  fpxl'r'fr∼xfl'fr'fr = lemma++∼r (lemma-push-∼-⋙ x cl' cr' l'⋙r' acc-xl'r') ;
                  x'fpxl'r'fr∼x'xfl'fr'fr = ∼x /head /head fpxl'r'fr∼xfl'fr'fr ;
                  x'xfl'fr'fr∼xflfr = ∼x /head (/tail /head) refl∼
             in trans∼ x'fpxl'r'fr∼x'xfl'fr'fr x'xfl'fr'fr∼xflfr
  ... | inj₂ x'≤x | inj₂ x''≤x | inj₂ x''≤x' rewrite lemma-≡-height perfect x x'' l'' r'' =
             let _l = node right x' l' r' ;
                  acc-xl''r'' = rs (node perfect x l'' r'') (lemma-≺-right perfect x _l (node perfect x'' l'' r'')) ;
                  x''flfpxl''r''∼x''flxfl''fr'' = lemma++∼l {x'' ∷ flatten _l} (lemma-push-∼-≃ x cl'' cr'' l''≃r'' acc-xl''r'') ;
                  flxfr/x''⟶flxfl''fr'' = lemma++/l {x''} {flatten _l} (/tail /head) ;
                  x''flxfl''fr''∼flxfr = ∼x /head flxfr/x''⟶flxfl''fr'' refl∼ ;
                  flxfr/x⟶flfr = lemma++/ {x} {flatten _l} ;
                  flxfr∼xflfr = ∼x flxfr/x⟶flfr /head refl∼ ;
                  x''flxfl''fr''∼xflfr = trans∼ x''flxfl''fr''∼flxfr flxfr∼xflfr
             in trans∼ x''flfpxl''r''∼x''flxfl''fr'' x''flxfl''fr''∼xflfr

lemma-push-∼ : {t : PLRTree} → Complete t → (acc : Acc _≺_ t) → flatten (push t acc) ∼ flatten t
lemma-push-∼ leaf _ = ∼[]
lemma-push-∼ (perfect {l} {r}x cl cr l≃r) (acc rs) = lemma-push-∼-≃ x cl cr l≃r (acc rs)
lemma-push-∼ (left {l} {r}x cl cr l⋘r) (acc rs) = lemma-push-∼-⋘ x cl cr l⋘r (acc rs)
lemma-push-∼ (right {l} {r}x cl cr l⋙r) (acc rs) = lemma-push-∼-⋙ x cl cr l⋙r (acc rs)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Equiv.Reasoning where

open import Cubical.Foundations.Prelude using (refl; sym)

open import Cubical.Relation.Binary

-- Properties of equivalence

≃-reflexive : Reflexive _≃_
≃-reflexive = ?


------------------------------------------------------------------------
-- Compiler correctness
------------------------------------------------------------------------

open import Prelude

import Lambda.Syntax

module Lambda.Compiler-correctness
  {Name : Type}
  (open Lambda.Syntax Name)
  (def : Name → Tm 1)
  where

import Equality.Propositional as E
import Tactic.By.Propositional as By
open import Prelude.Size

open import List E.equality-with-J using (_++_)
open import Monad E.equality-with-J using (return; _>>=_)
open import Vec.Data E.equality-with-J

open import Delay-monad.Bisimilarity

open import Lambda.Compiler def
open import Lambda.Delay-crash
open import Lambda.Interpreter def
open import Lambda.Virtual-machine.Instructions Name hiding (crash)
open import Lambda.Virtual-machine comp-name

private
  module C = Closure Code
  module T = Closure Tm

------------------------------------------------------------------------
-- A lemma

-- A rearrangement lemma for ⟦_⟧.

⟦⟧-· :
  ∀ {n} (t₁ t₂ : Tm n) {ρ} {k : T.Value → Delay-crash C.Value ∞} →
  ⟦ t₁ · t₂ ⟧ ρ >>= k ∼
  ⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂ >>= k
⟦⟧-· t₁ t₂ {ρ} {k} =
  ⟦ t₁ · t₂ ⟧ ρ >>= k      ∼⟨⟩

  (do v₁ ← ⟦ t₁ ⟧ ρ
      v₂ ← ⟦ t₂ ⟧ ρ
      v₁ ∙ v₂) >>= k       ∼⟨ symmetric (associativity (⟦ t₁ ⟧ _) _ _) ⟩

  (do v₁ ← ⟦ t₁ ⟧ ρ
      (do v₂ ← ⟦ t₂ ⟧ ρ
          v₁ ∙ v₂) >>= k)  ∼⟨ (⟦ t₁ ⟧ _ ∎) >>=-cong (λ _ → symmetric (associativity (⟦ t₂ ⟧ _) _ _)) ⟩

  (do v₁ ← ⟦ t₁ ⟧ ρ
      v₂ ← ⟦ t₂ ⟧ ρ
      v₁ ∙ v₂ >>= k)       ∎

------------------------------------------------------------------------
-- Well-formed continuations and stacks

-- A continuation is OK with respect to a certain state if the
-- following property is satisfied.

Cont-OK : Size → State → (T.Value → Delay-crash C.Value ∞) → Type
Cont-OK i ⟨ c , s , ρ ⟩ k =
  ∀ v → [ i ] exec ⟨ c , val (comp-val v) ∷ s , ρ ⟩ ≈ k v

-- If the In-tail-context parameter indicates that we are in a tail
-- context, then the stack must have a certain shape, and it must be
-- related to the continuation in a certain way.

data Stack-OK (i : Size) (k : T.Value → Delay-crash C.Value ∞) :
              In-tail-context → Stack → Type where
  unrestricted : ∀ {s} → Stack-OK i k false s
  restricted   : ∀ {s n} {c : Code n} {ρ : C.Env n} →
                 Cont-OK i ⟨ c , s , ρ ⟩ k →
                 Stack-OK i k true (ret c ρ ∷ s)

-- A lemma that can be used to show that certain stacks are OK.

ret-ok :
  ∀ {p i s n c} {ρ : C.Env n} {k} →
  Cont-OK i ⟨ c , s , ρ ⟩ k →
  Stack-OK i k p (ret c ρ ∷ s)
ret-ok {true}  c-ok = restricted c-ok
ret-ok {false} _    = unrestricted

------------------------------------------------------------------------
-- The semantics of the compiled program matches that of the source
-- code

mutual

  -- Some lemmas making up the main part of the compiler correctness
  -- result.

  ⟦⟧-correct :
    ∀ {i n} (t : Tm n) (ρ : T.Env n) {c s}
      {k : T.Value → Delay-crash C.Value ∞} {tc} →
    Stack-OK i k tc s →
    Cont-OK i ⟨ c , s , comp-env ρ ⟩ k →
    [ i ] exec ⟨ comp tc t c , s , comp-env ρ ⟩ ≈ ⟦ t ⟧ ρ >>= k

  ⟦⟧-correct (var x) ρ {c} {s} {k} _ c-ok =
    exec ⟨ var x ∷ c , s , comp-env ρ ⟩                            ≳⟨⟩
    exec ⟨ c , val By.⟨ index (comp-env ρ) x ⟩ ∷ s , comp-env ρ ⟩  ≡⟨ By.⟨by⟩ (comp-index ρ x) ⟩
    exec ⟨ c , val (comp-val (index ρ x)) ∷ s , comp-env ρ ⟩       ≈⟨ c-ok (index ρ x) ⟩∼
    k (index ρ x)                                                  ∼⟨⟩
    ⟦ var x ⟧ ρ >>= k                                              ∎

  ⟦⟧-correct (lam t) ρ {c} {s} {k} _ c-ok =
    exec ⟨ clo (comp-body t) ∷ c , s , comp-env ρ ⟩             ≳⟨⟩
    exec ⟨ c , val (comp-val (T.lam t ρ)) ∷ s , comp-env ρ ⟩    ≈⟨ c-ok (T.lam t ρ) ⟩∼
    k (T.lam t ρ)                                               ∼⟨⟩
    ⟦ lam t ⟧ ρ >>= k                                           ∎

  ⟦⟧-correct (t₁ · t₂) ρ {c} {s} {k} _ c-ok =
    exec ⟨ comp false t₁ (comp false t₂ (app ∷ c))
         , s
         , comp-env ρ
         ⟩                                                   ≈⟨ (⟦⟧-correct t₁ _ unrestricted λ v₁ →

      exec ⟨ comp false t₂ (app ∷ c)
           , val (comp-val v₁) ∷ s
           , comp-env ρ
           ⟩                                                       ≈⟨ (⟦⟧-correct t₂ _ unrestricted λ v₂ →

        exec ⟨ app ∷ c
             , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
             , comp-env ρ
             ⟩                                                           ≈⟨ ∙-correct v₁ v₂ c-ok ⟩∼

        v₁ ∙ v₂ >>= k                                                    ∎) ⟩∼

      (⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂ >>= k)                          ∎) ⟩∼

    (⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂ >>= k)  ∼⟨ symmetric (⟦⟧-· t₁ t₂) ⟩

    ⟦ t₁ · t₂ ⟧ ρ >>= k                                      ∎

  ⟦⟧-correct (call f t) ρ {c} {s} {k} unrestricted c-ok =
    exec ⟨ comp false (call f t) c , s , comp-env ρ ⟩         ∼⟨⟩

    exec ⟨ comp false t (cal f ∷ c) , s , comp-env ρ ⟩        ≈⟨ (⟦⟧-correct t _ unrestricted λ v →

      exec ⟨ cal f ∷ c , val (comp-val v) ∷ s , comp-env ρ ⟩        ≈⟨ (later λ { .force →

        exec ⟨ comp-name f
             , ret c (comp-env ρ) ∷ s
             , comp-val v ∷ []
             ⟩                                                            ≈⟨ body-lemma (def f) [] c-ok ⟩∼

        (⟦ def f ⟧ (v ∷ []) >>= k)                                        ∎ }) ⟩∼

      (T.lam (def f) [] ∙ v >>= k)                                  ∎) ⟩∼

    (⟦ t ⟧ ρ >>= λ v → T.lam (def f) [] ∙ v >>= k)            ∼⟨ associativity (⟦ t ⟧ ρ) _ _ ⟩

    (⟦ t ⟧ ρ >>= λ v → T.lam (def f) [] ∙ v) >>= k            ∼⟨⟩

    ⟦ call f t ⟧ ρ >>= k                                      ∎

  ⟦⟧-correct (call f t) ρ {c} {ret c′ ρ′ ∷ s} {k} (restricted c-ok) _ =
    exec ⟨ comp true (call f t) c , ret c′ ρ′ ∷ s , comp-env ρ ⟩    ∼⟨⟩

    exec ⟨ comp false t (tcl f ∷ c) , ret c′ ρ′ ∷ s , comp-env ρ ⟩  ≈⟨ (⟦⟧-correct t _ unrestricted λ v →

      exec ⟨ tcl f ∷ c
           , val (comp-val v) ∷ ret c′ ρ′ ∷ s
           , comp-env ρ
           ⟩                                                              ≈⟨ (later λ { .force →

        exec ⟨ comp-name f
             , ret c′ ρ′ ∷ s
             , comp-val v ∷ []
             ⟩                                                                  ≈⟨ body-lemma (def f) [] c-ok ⟩∼

        ⟦ def f ⟧ (v ∷ []) >>= k                                                ∎ }) ⟩∼

      T.lam (def f) [] ∙ v >>= k                                          ∎) ⟩∼

    (⟦ t ⟧ ρ >>= λ v → T.lam (def f) [] ∙ v >>= k)                  ∼⟨ associativity (⟦ t ⟧ ρ) _ _ ⟩

    (⟦ t ⟧ ρ >>= λ v → T.lam (def f) [] ∙ v) >>= k                  ∼⟨⟩

    ⟦ call f t ⟧ ρ >>= k                                            ∎

  ⟦⟧-correct (con b) ρ {c} {s} {k} _ c-ok =
    exec ⟨ con b ∷ c , s , comp-env ρ ⟩                     ≳⟨⟩
    exec ⟨ c , val (comp-val (T.con b)) ∷ s , comp-env ρ ⟩  ≈⟨ c-ok (T.con b) ⟩∼
    k (T.con b)                                             ∼⟨⟩
    ⟦ con b ⟧ ρ >>= k                                       ∎

  ⟦⟧-correct (if t₁ t₂ t₃) ρ {c} {s} {k} {tc} s-ok c-ok =
    exec ⟨ comp false t₁ (bra (comp tc t₂ []) (comp tc t₃ []) ∷ c)
         , s
         , comp-env ρ
         ⟩                                                          ≈⟨ (⟦⟧-correct t₁ _ unrestricted λ v₁ → ⟦if⟧-correct v₁ t₂ t₃ s-ok c-ok) ⟩∼

    (⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦if⟧ v₁ t₂ t₃ ρ >>= k)                     ∼⟨ associativity (⟦ t₁ ⟧ ρ) _ _ ⟩

    (⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦if⟧ v₁ t₂ t₃ ρ) >>= k                     ∼⟨⟩

    ⟦ if t₁ t₂ t₃ ⟧ ρ >>= k                                         ∎

  body-lemma :
    ∀ {i n n′} (t : Tm (1 + n)) ρ {ρ′ : C.Env n′} {c s v}
      {k : T.Value → Delay-crash C.Value ∞} →
    Cont-OK i ⟨ c , s , ρ′ ⟩ k →
    [ i ] exec ⟨ comp-body t
               , ret c ρ′ ∷ s
               , comp-val v ∷ comp-env ρ
               ⟩ ≈
          ⟦ t ⟧ (v ∷ ρ) >>= k
  body-lemma t ρ {ρ′} {c} {s} {v} {k} c-ok =
    exec ⟨ comp-body t , ret c ρ′ ∷ s , comp-val v ∷ comp-env ρ ⟩  ∼⟨⟩

    exec ⟨ comp-body t , ret c ρ′ ∷ s , comp-env (v ∷ ρ) ⟩         ≈⟨ (⟦⟧-correct t (_ ∷ _) (ret-ok c-ok) λ v′ →

      exec ⟨ ret ∷ []
           , val (comp-val v′) ∷ ret c ρ′ ∷ s
           , comp-env (v ∷ ρ)
           ⟩                                                             ≳⟨⟩

      exec ⟨ c , val (comp-val v′) ∷ s , ρ′ ⟩                            ≈⟨ c-ok v′ ⟩∼

      k v′                                                               ∎) ⟩∼

    ⟦ t ⟧ (v ∷ ρ) >>= k                                            ∎

  ∙-correct :
    ∀ {i n} v₁ v₂ {ρ : C.Env n} {c s}
      {k : T.Value → Delay-crash C.Value ∞} →
    Cont-OK i ⟨ c , s , ρ ⟩ k →
    [ i ] exec ⟨ app ∷ c
               , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
               , ρ
               ⟩ ≈
          v₁ ∙ v₂ >>= k

  ∙-correct (T.lam t₁ ρ₁) v₂ {ρ} {c} {s} {k} c-ok =
    exec ⟨ app ∷ c
         , val (comp-val v₂) ∷ val (comp-val (T.lam t₁ ρ₁)) ∷ s
         , ρ
         ⟩                                                             ≈⟨ later (λ { .force →

      exec ⟨ comp-body t₁ , ret c ρ ∷ s , comp-val v₂ ∷ comp-env ρ₁ ⟩       ≈⟨ body-lemma t₁ _ c-ok ⟩∼

      ⟦ t₁ ⟧ (v₂ ∷ ρ₁) >>= k                                                ∎ }) ⟩∎

    T.lam t₁ ρ₁ ∙ v₂ >>= k                                             ∎

  ∙-correct (T.con b) v₂ {ρ} {c} {s} {k} _ =
    exec ⟨ app ∷ c
         , val (comp-val v₂) ∷ val (comp-val (T.con b)) ∷ s
         , ρ
         ⟩                                                   ≳⟨⟩

    crash                                                    ∼⟨⟩

    T.con b ∙ v₂ >>= k                                       ∎

  ⟦if⟧-correct :
    ∀ {i n} v₁ (t₂ t₃ : Tm n) {ρ : T.Env n} {c s}
      {k : T.Value → Delay-crash C.Value ∞} {tc} →
    Stack-OK i k tc s →
    Cont-OK i ⟨ c , s , comp-env ρ ⟩ k →
    [ i ] exec ⟨ bra (comp tc t₂ []) (comp tc t₃ []) ∷ c
               , val (comp-val v₁) ∷ s
               , comp-env ρ
               ⟩ ≈
          ⟦if⟧ v₁ t₂ t₃ ρ >>= k

  ⟦if⟧-correct (T.lam t₁ ρ₁) t₂ t₃ {ρ} {c} {s} {k} {tc} _ _ =
    exec ⟨ bra (comp tc t₂ []) (comp tc t₃ []) ∷ c
         , val (comp-val (T.lam t₁ ρ₁)) ∷ s
         , comp-env ρ
         ⟩                                          ≳⟨⟩

    crash                                           ∼⟨⟩

    ⟦if⟧ (T.lam t₁ ρ₁) t₂ t₃ ρ >>= k                ∎

  ⟦if⟧-correct (T.con true) t₂ t₃ {ρ} {c} {s} {k} {tc} s-ok c-ok =
    exec ⟨ bra (comp tc t₂ []) (comp tc t₃ []) ∷ c
         , val (comp-val (T.con true)) ∷ s
         , comp-env ρ
         ⟩                                          ≳⟨⟩

    exec ⟨ comp tc t₂ [] ++ c , s , comp-env ρ ⟩    ≡⟨ By.by (comp-++ _ t₂) ⟩

    exec ⟨ comp tc t₂ c , s , comp-env ρ ⟩          ≈⟨ ⟦⟧-correct t₂ _ s-ok c-ok ⟩∼

    ⟦ t₂ ⟧ ρ >>= k                                  ∼⟨⟩

    ⟦if⟧ (T.con true) t₂ t₃ ρ >>= k                 ∎

  ⟦if⟧-correct (T.con false) t₂ t₃ {ρ} {c} {s} {k} {tc} s-ok c-ok =
    exec ⟨ bra (comp tc t₂ []) (comp tc t₃ []) ∷ c
         , val (comp-val (T.con false)) ∷ s
         , comp-env ρ
         ⟩                                          ≳⟨⟩

    exec ⟨ comp tc t₃ [] ++ c , s , comp-env ρ ⟩    ≡⟨ By.by (comp-++ _ t₃) ⟩

    exec ⟨ comp tc t₃ c , s , comp-env ρ ⟩          ≈⟨ ⟦⟧-correct t₃ _ s-ok c-ok ⟩∼

    ⟦ t₃ ⟧ ρ >>= k                                  ∼⟨⟩

    ⟦if⟧ (T.con false) t₂ t₃ ρ >>= k                ∎

-- Compiler correctness. Note that the equality that is used here is
-- syntactic.

correct :
  (t : Tm 0) →
  exec ⟨ comp₀ t , [] , [] ⟩ ≈
  ⟦ t ⟧ [] >>= λ v → return (comp-val v)
correct t =
  exec ⟨ comp false t [] , [] , [] ⟩           ∼⟨⟩
  exec ⟨ comp false t [] , [] , comp-env [] ⟩  ≈⟨ ⟦⟧-correct t [] unrestricted (λ v → laterˡ (return (comp-val v) ∎)) ⟩
  (⟦ t ⟧ [] >>= λ v → return (comp-val v))     ∎


module Pi.Properties where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Pi.Syntax
open import Pi.Opsem
open import Pi.NoRepeat
open import Pi.Invariants
open import Pi.Eval
open import Pi.Interp

-- Forward evaluation is deterministic
deterministic-eval : ∀ {A B} → (c : A ↔ B) (v : ⟦ A ⟧) (v₁ v₂ : ⟦ B ⟧)
                   → ⟨ c ∣ v ∣ ☐ ⟩ ↦* ［ c ∣ v₁ ∣ ☐ ］
                   → ⟨ c ∣ v ∣ ☐ ⟩ ↦* ［ c ∣ v₂ ∣ ☐ ］
                   → v₁ ≡ v₂
deterministic-eval c v v₁ v₂ ↦*₁ ↦*₂ with deterministic* ↦*₁ ↦*₂ (λ ()) (λ ())
... | refl = refl

-- Backward evaluation is deterministic
deterministic-evalᵣₑᵥ : ∀ {A B} → (c : A ↔ B) (v : ⟦ B ⟧) (v₁ v₂ : ⟦ A ⟧)
                      → ［ c ∣ v ∣ ☐ ］ ↦ᵣₑᵥ* ⟨ c ∣ v₁ ∣ ☐ ⟩
                      → ［ c ∣ v ∣ ☐ ］ ↦ᵣₑᵥ* ⟨ c ∣ v₂ ∣ ☐ ⟩
                      → v₁ ≡ v₂
deterministic-evalᵣₑᵥ c v v₁ v₂ ↦ᵣₑᵥ*₁ ↦ᵣₑᵥ*₂ with deterministicᵣₑᵥ* ↦ᵣₑᵥ*₁ ↦ᵣₑᵥ*₂ (λ ()) (λ ())
... | refl = refl

-- Forward evaluator is reversible
evalIsRev : ∀ {A B} → (c : A ↔ B) (v₁ : ⟦ A ⟧) (v₂ : ⟦ B ⟧)
          → eval c v₁ ≡ v₂ → evalᵣₑᵥ c v₂ ≡ v₁
evalIsRev c v₁ v₂ eq with ev {κ = ☐} c v₁
... | v₂' , c↦* with eq
... | refl with evᵣₑᵥ {κ = ☐} c v₂
... | v₁' , c↦*ᵣₑᵥ with deterministicᵣₑᵥ* c↦*ᵣₑᵥ (Rev↦ c↦*) (λ ()) (λ ())
... | refl = refl

-- Backward evaluator is reversible
evalᵣₑᵥIsRev : ∀ {A B} → (c : A ↔ B) (v₁ : ⟦ B ⟧) (v₂ : ⟦ A ⟧)
             → evalᵣₑᵥ c v₁ ≡ v₂ → eval c v₂ ≡ v₁
evalᵣₑᵥIsRev c v₁ v₂ eq with evᵣₑᵥ {κ = ☐} c v₁
... | v₂' , c↦ᵣₑᵥ* with eq
... | refl with ev {κ = ☐} c v₂
... | v₁' , c↦* with deterministic* c↦* (Rev↦ᵣₑᵥ c↦ᵣₑᵥ*) (λ ()) (λ ())
... | refl = refl

-- The abstract machine semantics is equivalent to the big-step semantics
eval≡interp : ∀ {A B} → (c : A ↔ B) → (v : ⟦ A ⟧) → eval c v ≡ interp c v
eval≡interp unite₊l (inj₂ y) = refl
eval≡interp uniti₊l v = refl
eval≡interp swap₊ (inj₁ x) = refl
eval≡interp swap₊ (inj₂ y) = refl
eval≡interp assocl₊ (inj₁ x) = refl
eval≡interp assocl₊ (inj₂ (inj₁ y)) = refl
eval≡interp assocl₊ (inj₂ (inj₂ z)) = refl
eval≡interp assocr₊ (inj₁ (inj₁ x)) = refl
eval≡interp assocr₊ (inj₁ (inj₂ y)) = refl
eval≡interp assocr₊ (inj₂ z) = refl
eval≡interp unite⋆l (tt , v) = refl
eval≡interp uniti⋆l v = refl
eval≡interp swap⋆ (x , y) = refl
eval≡interp assocl⋆ (x , (y , z)) = refl
eval≡interp assocr⋆ ((x , y) , z) = refl
eval≡interp dist (inj₁ x , z) = refl
eval≡interp dist (inj₂ y , z) = refl
eval≡interp factor (inj₁ (x , z)) = refl
eval≡interp factor (inj₂ (y , z)) = refl
eval≡interp id↔ v = refl
eval≡interp (c₁ ⨾ c₂) v with ev {κ = ☐} c₁ v | inspect (ev {κ = ☐} c₁) v
... | (v' , rs)   | [ eq ] with ev {κ = ☐} c₂ v' | inspect (ev {κ = ☐} c₂) v'
... | (v'' , rs') | [ eq' ] with ev {κ = ☐} (c₁ ⨾ c₂) v | inspect (ev {κ = ☐} (c₁ ⨾ c₂)) v
... | (u , rs'')  | [ refl ] rewrite (sym (eval≡interp c₁ v)) | eq | (sym (eval≡interp c₂ v')) | eq' with deterministic* ((↦₃ ∷ ◾) ++↦ appendκ↦* rs refl (☐⨾ c₂ • ☐) ++↦ (↦₇ ∷ ◾) ++↦ appendκ↦* rs' refl (c₁ ⨾☐• ☐) ++↦ (↦₁₀ ∷ ◾)) rs'' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⊕ c₂) (inj₁ x) with ev {κ = ☐} c₁ x | inspect (ev {κ = ☐} c₁) x
... | (x' , rs) | [ eq ] with ev {κ = ☐} (c₁ ⊕ c₂) (inj₁ x) | inspect (ev {κ = ☐} (c₁ ⊕ c₂)) (inj₁ x)
... | (v , rs') | [ refl ] rewrite (sym (eval≡interp c₁ x)) | eq with deterministic* ((↦₄ ∷ ◾) ++↦ appendκ↦* rs refl (☐⊕ c₂ • ☐) ++↦ (↦₁₁ ∷ ◾)) rs' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⊕ c₂) (inj₂ y) with ev {κ = ☐} c₂ y | inspect (ev {κ = ☐} c₂) y
... | (x' , rs) | [ eq ] with ev {κ = ☐} (c₁ ⊕ c₂) (inj₂ y) | inspect (ev {κ = ☐} (c₁ ⊕ c₂)) (inj₂ y)
... | (v , rs') | [ refl ] rewrite (sym (eval≡interp c₂ y)) | eq with deterministic* ((↦₅ ∷ ◾) ++↦ appendκ↦* rs refl (c₁ ⊕☐• ☐) ++↦ (↦₁₂ ∷ ◾)) rs' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⊗ c₂) (x , y) with ev {κ = ☐} c₁ x | inspect (ev {κ = ☐} c₁) x
... | (x' , rs) | [ eq ] with ev {κ = ☐} c₂ y | inspect (ev {κ = ☐} c₂) y
... | (y' , rs') | [ eq' ] with ev {κ = ☐} (c₁ ⊗ c₂) (x , y) | inspect (ev {κ = ☐} (c₁ ⊗ c₂)) (x , y)
... | (_ , rs'') | [ refl ] rewrite (sym (eval≡interp c₁ x)) | eq | (sym (eval≡interp c₂ y)) | eq' with deterministic* (((↦₆ ∷ ◾) ++↦ appendκ↦* rs refl (☐⊗[ c₂ , y ]• ☐)) ++↦ (↦₈ ∷ ◾) ++↦ appendκ↦* rs' refl ([ c₁ , x' ]⊗☐• ☐) ++↦ (↦₉ ∷ ◾)) rs'' (λ ()) (λ ())
... | refl = refl

c⨾!c≡id↔ : ∀ {A B} (c : A ↔ B) → (x : ⟦ A ⟧) → interp (c ⨾ ! c) x ≡ interp id↔ x
c⨾!c≡id↔ unite₊l (inj₂ y) = refl
c⨾!c≡id↔ uniti₊l x = refl
c⨾!c≡id↔ swap₊ (inj₁ x) = refl
c⨾!c≡id↔ swap₊ (inj₂ y) = refl
c⨾!c≡id↔ assocl₊ (inj₁ x) = refl
c⨾!c≡id↔ assocl₊ (inj₂ (inj₁ y)) = refl
c⨾!c≡id↔ assocl₊ (inj₂ (inj₂ z)) = refl
c⨾!c≡id↔ assocr₊ (inj₁ (inj₁ x)) = refl
c⨾!c≡id↔ assocr₊ (inj₁ (inj₂ y)) = refl
c⨾!c≡id↔ assocr₊ (inj₂ z) = refl
c⨾!c≡id↔ unite⋆l (tt , x) = refl
c⨾!c≡id↔ uniti⋆l x = refl
c⨾!c≡id↔ swap⋆ (x , y) = refl
c⨾!c≡id↔ assocl⋆ (x , (y , z)) = refl
c⨾!c≡id↔ assocr⋆ ((x , y) , z) = refl
c⨾!c≡id↔ dist (inj₁ x , z) = refl
c⨾!c≡id↔ dist (inj₂ y , z) = refl
c⨾!c≡id↔ factor (inj₁ (x , z)) = refl
c⨾!c≡id↔ factor (inj₂ (y , z)) = refl
c⨾!c≡id↔ id↔ x = refl
c⨾!c≡id↔ (c₁ ⨾ c₂) x rewrite c⨾!c≡id↔ c₂ (interp c₁ x) = c⨾!c≡id↔ c₁ x
c⨾!c≡id↔ (c₁ ⊕ c₂) (inj₁ x) rewrite c⨾!c≡id↔ c₁ x = refl
c⨾!c≡id↔ (c₁ ⊕ c₂) (inj₂ y) rewrite c⨾!c≡id↔ c₂ y = refl
c⨾!c≡id↔ (c₁ ⊗ c₂) (x , y) rewrite c⨾!c≡id↔ c₁ x | c⨾!c≡id↔ c₂ y = refl

!!c≡c : ∀ {A B} (c : A ↔ B) → ! (! c) ≡ c
!!c≡c unite₊l = refl
!!c≡c uniti₊l = refl
!!c≡c swap₊ = refl
!!c≡c assocl₊ = refl
!!c≡c assocr₊ = refl
!!c≡c unite⋆l = refl
!!c≡c uniti⋆l = refl
!!c≡c swap⋆ = refl
!!c≡c assocl⋆ = refl
!!c≡c assocr⋆ = refl
!!c≡c absorbr = refl
!!c≡c factorzl = refl
!!c≡c dist = refl
!!c≡c factor = refl
!!c≡c id↔ = refl
!!c≡c (c₁ ⨾ c₂) rewrite !!c≡c c₁ | !!c≡c c₂ = refl
!!c≡c (c₁ ⊕ c₂) rewrite !!c≡c c₁ | !!c≡c c₂ = refl
!!c≡c (c₁ ⊗ c₂) rewrite !!c≡c c₁ | !!c≡c c₂ = refl

!c⨾c≡id↔ : ∀ {A B} (c : A ↔ B) → (x : ⟦ B ⟧) → interp (! c ⨾ c) x ≡ interp id↔ x
!c⨾c≡id↔ c x = trans (cong (λ c' → interp c' (interp (! c) x)) (sym (!!c≡c c)))
                    (c⨾!c≡id↔ (! c) x)


-- Binary products
{-# OPTIONS --safe #-}

module Cubical.Categories.Limits.BinProduct where

open import Cubical.Categories.Category.Base
open import Cubical.Data.Sigma.Base
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.HITs.PropositionalTruncation.Base

private
  variable
    ℓ ℓ' : Level

module _ (C : Category ℓ ℓ') where
  open Category C

  module _ {x y x×y : ob}
           (π₁ : Hom[ x×y , x ])
           (π₂ : Hom[ x×y , y ]) where

    isBinProduct : Type (ℓ-max ℓ ℓ')
    isBinProduct = ∀ {z : ob} (f₁ : Hom[ z , x ]) (f₂ : Hom[ z , y ]) →
        ∃![ f ∈ Hom[ z , x×y ] ] (f ⋆ π₁ ≡ f₁) × (f ⋆ π₂ ≡ f₂)

    isPropIsBinProduct : isProp (isBinProduct)
    isPropIsBinProduct = isPropImplicitΠ (λ _ → isPropΠ2 (λ _ _ → isPropIsContr))

  record BinProduct (x y : ob) : Type (ℓ-max ℓ ℓ') where
    field
      binProdOb : ob
      binProdPr₁ : Hom[ binProdOb , x ]
      binProdPr₂ : Hom[ binProdOb , y ]
      univProp : isBinProduct binProdPr₁ binProdPr₂

  BinProducts : Type (ℓ-max ℓ ℓ')
  BinProducts = (x y : ob) → BinProduct x y

  hasBinProducts : Type (ℓ-max ℓ ℓ')
  hasBinProducts = ∥ BinProducts ∥₁


{-# OPTIONS --without-K #-}
module function where

open import function.core public
open import function.overloading public
open import function.isomorphism public
open import function.extensionality public
open import function.fibration public


{- NEW TRANSLATION: notation change to avoid exponential increase in term size during translation -}

open import Preliminaries
open import Source
open import Complexity

module Translation-WithLet where

  mutual
    ⟨⟨_⟩⟩ : Tp → Complexity.CTp
    ⟨⟨ unit ⟩⟩ = unit
    ⟨⟨ nat ⟩⟩ = nat
    ⟨⟨ susp A ⟩⟩ = || A ||
    ⟨⟨ A ->s B ⟩⟩ = ⟨⟨ A ⟩⟩ ->c || B ||
    ⟨⟨ A ×s B ⟩⟩ = ⟨⟨ A ⟩⟩ ×c ⟨⟨ B ⟩⟩
    ⟨⟨ list A ⟩⟩ = list ⟨⟨ A ⟩⟩
    ⟨⟨ bool ⟩⟩ = bool

    ||_|| : Tp → Complexity.CTp
    || τ || = C ×c ⟨⟨ τ ⟩⟩

  ⟨⟨_⟩⟩c : Source.Ctx → Complexity.Ctx
  ⟨⟨ [] ⟩⟩c = []
  ⟨⟨ x :: Γ ⟩⟩c = ⟨⟨ x ⟩⟩ :: ⟨⟨ Γ ⟩⟩c

  interp-Cost : ∀{Γ} → Cost → Γ Complexity.|- C
  interp-Cost 0c = 0C
  interp-Cost 1c = 1C
  interp-Cost (m +c n) = plusC (interp-Cost m) (interp-Cost n)

  lookup : ∀{Γ τ} → τ Source.∈ Γ → ⟨⟨ τ ⟩⟩ Complexity.∈ ⟨⟨ Γ ⟩⟩c
  lookup i0 = i0
  lookup (iS x) = iS (lookup x)

  throw-s : ∀ {Γ Γ' τ} → Complexity.sctx Γ (τ :: Γ') → Complexity.sctx Γ Γ'
  throw-s Θ x = Θ (iS x)

  _+C_ : ∀ {Γ τ} → Γ Complexity.|- C  → Γ Complexity.|- (C ×c τ)→ Γ Complexity.|- (C ×c τ)
  c +C e = letc (prod (l-proj (var i0)) (r-proj (var i0))) e

  -- translation from source expressions to complexity expressions
  ||_||e : ∀{Γ τ} → Γ Source.|- τ → ⟨⟨ Γ ⟩⟩c Complexity.|- || τ ||
  || unit ||e = prod 0C unit
  || var x ||e = prod 0C (var (lookup x))
  || z ||e = prod 0C z
  || suc e ||e = (letc (prod (l-proj (var i0)) (s (r-proj (var i0)))) || e ||e)
  || rec e e0 e1 ||e =
      letc (l-proj (var i0) +C rec (r-proj (var i0))
           (Complexity.wkn (1C +C || e0 ||e)) (Complexity.subst (1C +C || e1 ||e) (Complexity.s-extend (Complexity.s-extend (throw-s Complexity.ids))))) || e ||e
  || lam e ||e = prod 0C (lam || e ||e)
  || app e1 e2 ||e = letc (letc (prod (plusC (plusC (l-proj (var (iS i0))) (l-proj (var i0))) (l-proj (app (r-proj (var (iS i0))) (r-proj (var i0)))))
                            (r-proj (app (r-proj (var (iS i0))) (r-proj (var i0))))) (Complexity.wkn || e2 ||e)) || e1 ||e
  || prod e1 e2 ||e = letc (letc (prod (plusC (l-proj (var (iS i0))) (l-proj (var i0))) (prod (r-proj (var (iS i0))) (r-proj (var i0)))) (Complexity.wkn || e2 ||e)) || e1 ||e
  || delay e ||e = prod 0C || e ||e
  || force e ||e = letc (prod (plusC (l-proj (var i0)) (l-proj (r-proj (var i0)))) (r-proj (r-proj (var i0)))) || e ||e
  || split e0 e1 ||e = letc (prod (plusC (Complexity.wkn (l-proj || e0 ||e)) (l-proj (var i0))) (r-proj (var i0))) E1
       where E1 = letc (Complexity.subst || e1 ||e (Complexity.lem4 (l-proj (r-proj (var i0))) (r-proj (r-proj (var i0))) Complexity.ss Complexity.s-extend (Complexity.s-extend (throw-s Complexity.ids)))) || e0 ||e
  || nil ||e = prod 0C nil
  || e ::s e₁ ||e = letc (letc (prod (plusC (l-proj (var (iS i0))) (l-proj (var i0))) (r-proj (var (iS i0)) ::c r-proj (var i0))) (Complexity.wkn || e₁ ||e)) || e ||e
  || listrec e e₁ e₂ ||e =
      letc (l-proj (var i0) +C listrec (r-proj (var i0))
        (Complexity.wkn (1C +C || e₁ ||e)) (Complexity.subst (1C +C || e₂ ||e) (Complexity.s-extend (Complexity.s-extend (Complexity.s-extend (throw-s Complexity.ids)))))) || e ||e
  || true ||e = prod 0C true
  || false ||e = prod 0C false

{-
  module Proofs where
    open NewTranslation renaming (||_||e to ||_||new)
    open import Translation renaming (||_||e to ||_||old)

    convert-type : Complexity-WithLet.CTp → Complexity.CTp
    convert-type unit = unit
    convert-type nat = nat
    convert-type (τ ->c τ₁) = convert-type τ ->c convert-type τ₁
    convert-type (τ ×c τ₁) = convert-type τ ×c convert-type τ₁
    convert-type (list τ) = list (convert-type τ)
    convert-type bool = bool
    convert-type C = C
    convert-type rnat = rnat

    convert-ctx : Complexity-WithLet.Ctx → Complexity.Ctx
    convert-ctx [] = []
    convert-ctx (x :: Γ) = convert-type x :: convert-ctx Γ

    convert-var : ∀ {Γ τ} → τ Complexity-WithLet.∈ Γ → convert-type τ Complexity.∈ convert-ctx Γ
    convert-var i0 = i0
    convert-var (iS x) = iS (convert-var x)

    convert-exp : ∀{Γ τ} → (e : Γ Complexity-WithLet.|- τ) → convert-ctx Γ Complexity.|- convert-type τ
    convert-exp unit = unit
    convert-exp 0C = 0C
    convert-exp 1C = 1C
    convert-exp (plusC e e₁) = plusC (convert-exp e) (convert-exp e₁)
    convert-exp (var x) = var (convert-var x)
    convert-exp z = z
    convert-exp (s e) = s (convert-exp e)
    convert-exp (rec e e₁ e₂) = rec (convert-exp e) (convert-exp e₁) (convert-exp e₂)
    convert-exp (lam e) = lam (convert-exp e)
    convert-exp (app e e₁) = app (convert-exp e) (convert-exp e₁)
    convert-exp (prod e e₁) = {!!}
    convert-exp (l-proj e) = {!!}
    convert-exp (r-proj e) = {!!}
    convert-exp nil = {!!}
    convert-exp (e ::c e₁) = {!!}
    convert-exp (listrec e e₁ e₂) = {!!}
    convert-exp true = true
    convert-exp false = false
    convert-exp (max x e e₁) = max {!!} {!!} {!!}
    convert-exp (letc e e₁) = app (lam (convert-exp e)) (convert-exp e₁)

    trans-eq : ∀{Γ τ} → (e : Γ Source.|- τ)
                      → (t1 : convert-exp ?) --((NewTranslation.⟨⟨ Γ ⟩⟩c) Complexity-WithLet.|- NewTranslation.|| τ ||))
                      → (t2 : Translation.⟨⟨ Γ ⟩⟩c Complexity.|- Translation.|| τ ||)
                      → {!convert-exp t1!} == t2
    trans-eq e = {!!}
-}


{-# OPTIONS --cubical #-}

open import Agda.Builtin.Equality

data Unit : Set where
  unit : Unit

f : (x : Unit) → _ -- x ≡ x
g : (x : Unit) → x ≡ x

f unit = refl
g x = f x