open import Data.Bool as Bool using (Bool; false; true; if_then_else_; not)
open import Data.String using (String)
open import Data.Nat using (ℕ; _+_; _≟_; suc; _>_; _<_; _∸_)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Data.List as l using (List; filter; map; take; foldl; length; []; _∷_)
open import Data.List.Properties
-- open import Data.List.Extrema using (max)
open import Data.Maybe using (to-witness)
open import Data.Fin using (fromℕ; _-_; zero; Fin)
open import Data.Fin.Properties using (≤-totalOrder)
open import Data.Product as Prod using (∃; ∃₂; _×_; _,_; Σ)
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open Eq.≡-Reasoning
open import Level using (Level)
open import Data.Vec as v using (Vec; fromList; toList; last; length; []; _∷_; [_]; _∷ʳ_; _++_; lookup; head; initLast; filter; map)
open import Data.Vec.Bounded as vb using ([]; _∷_; fromVec; filter; Vec≤)
open import Agda.Builtin.Nat public
  using () renaming (_==_ to _≡ᵇ_)
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≢_; refl; _≗_; cong₂; inspect; [_])
open import Data.Nat.Properties using (+-comm)
open import Relation.Unary using (Pred; Decidable)
open import Relation.Nullary using (does)
open import Data.Vec.Bounded.Base using (padRight; ≤-cast)
import Data.Nat.Properties as ℕₚ
open import Relation.Nullary.Decidable.Core using (dec-false)
open import Function using (_∘_)
open import Data.List.Extrema ℕₚ.≤-totalOrder
open import Data.Empty using (⊥)

-- TODO add to std-lib
open import Relation.Nullary

dec-¬ : ∀ {a} {P : Set a} → Dec P → Dec (¬ P)
dec-¬ (yes p) = no λ prf → prf p
dec-¬ (no ¬p) = yes ¬p

-- TODO switch to Vec init?
allButLast : ∀ {a} {A : Set a} → List A → List A
allButLast []           = l.[]
allButLast (_ ∷ [])     = l.[]
allButLast (x ∷ x₁ ∷ l) = x l.∷ (allButLast (x₁ l.∷ l))

allButLast-∷ʳ : ∀ {a} {A : Set a} {l : List A} {x} → allButLast (l l.∷ʳ x) ≡ l
allButLast-∷ʳ {l = []}         = refl
allButLast-∷ʳ {l = _ ∷ []}     = refl
allButLast-∷ʳ {l = x ∷ x₁ ∷ l} = cong (x l.∷_) (allButLast-∷ʳ {l = x₁ l.∷ l})

filter' : {A : Set} → (A → Bool) → List A → List A
filter' p []               = l.[]
filter' p (x ∷ xs) with (p x)
...                | true  = x l.∷ filter' p xs
...                | false = filter' p xs

record Todo : Set where
  field
    text      : String
    completed : Bool
    id        : ℕ

-- can't define this for (List any) since (last []) must be defined for each carrier type
TodoListLast : List Todo → Todo
TodoListLast []          = record {}
TodoListLast (x ∷ [])    = x
TodoListLast (_ ∷ y ∷ l) = TodoListLast (y l.∷ l)

AddTodo : List Todo → String → List Todo
AddTodo todos text =
  todos l.∷ʳ
  record
    { id        = 1
    ; completed = false
    ; text      = text
    }

-- AddTodo is well-defined
AddTodoAddsNewListItem :
  (todos : List Todo) (text : String) →
    l.length (AddTodo todos text) ≡ l.length todos + 1
AddTodoAddsNewListItem todos text = length-++ todos

AddTodoSetsNewCompletedToFalse :
  (todos : List Todo) (text : String) →
    Todo.completed (TodoListLast (AddTodo todos text)) ≡ false
AddTodoSetsNewCompletedToFalse []          text = refl
AddTodoSetsNewCompletedToFalse (_ ∷ [])    text = refl
AddTodoSetsNewCompletedToFalse (_ ∷ _ ∷ l) text = AddTodoSetsNewCompletedToFalse (_ l.∷ l) text

-- TODO can't prove this until AddTodo definition changed
AddTodoSetsNewIdToNonExistingId :
  (todos : List Todo) (text : String) →
    l.length (l.filter (λ todo → dec-¬ (Todo.id todo ≟ Todo.id (TodoListLast (AddTodo todos text)))) (AddTodo todos text)) ≡ 1
AddTodoSetsNewIdToNonExistingId todos text = {!   !}

AddTodoSetsNewTextToText :
  (todos : List Todo) (text : String) →
    Todo.text (TodoListLast (AddTodo todos text)) ≡ text
AddTodoSetsNewTextToText []          text = refl
AddTodoSetsNewTextToText (_ ∷ [])    text = refl
AddTodoSetsNewTextToText (_ ∷ _ ∷ l) text = AddTodoSetsNewTextToText (_ l.∷ l) text

AddTodoDoesntChangeOtherTodos :
  (todos : List Todo) (text : String) →
    l.length todos > 0 →
      allButLast (AddTodo todos text) ≡ todos
AddTodoDoesntChangeOtherTodos (x l.∷ xs) text _<_ = allButLast-∷ʳ
-- END AddTodo is well-defined

-- TODO text1 ≠ text2
AddTodo-not-comm :
  (todos : List Todo) →
    (text1 : String) →
      (text2 : String) →
  (AddTodo (AddTodo todos text1) text2 ≢ AddTodo (AddTodo todos text2) text1)
AddTodo-not-comm todos text1 text2 = {!   !}

-- {-# COMPILE JS AddTodo =
--   function (todos) {
--     return function (text) {
--       return [
--         ...todos,
--         {
--           id: todos.reduce((maxId, todo) => Math.max(todo.id, maxId), -1) + 1,
--           completed: false,
--           text: text
--         }
--       ]
--     }
--   }
-- #-}

DeleteTodo : (List Todo) → ℕ → (List Todo)
DeleteTodo todos id = l.filter (λ todo → dec-¬ (Todo.id todo ≟ id)) todos

DeleteTodo' : (List Todo) → ℕ → (List Todo)
DeleteTodo' todos id = filter' (λ todo → not (Todo.id todo ≡ᵇ id)) todos

DeleteTodo'RemoveTodoWithId :
  (todos : List Todo) (id : ℕ) →
    filter' (λ todo → Todo.id todo ≡ᵇ id) (DeleteTodo' todos id) ≡ l.[]
DeleteTodo'RemoveTodoWithId []       id = refl
DeleteTodo'RemoveTodoWithId (x ∷ xs) id with (Todo.id x ≡ᵇ id) | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ]                  = DeleteTodo'RemoveTodoWithId xs id
... | false | P.[ eq ] rewrite eq       = DeleteTodo'RemoveTodoWithId xs id

-- TODO this one needs Todo to specify that it can only have one unique id
DeleteTodo'Removes1Element :
  (todos : List Todo) (id : ℕ) →
    l.length (DeleteTodo' todos id) ≡ l.length todos ∸ 1
DeleteTodo'Removes1Element []       id = refl
DeleteTodo'Removes1Element (x ∷ xs) id with (Todo.id x ≡ᵇ id) | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ] rewrite eq = {!   !} -- DeleteTodo'Removes1Element xs id
... | false | P.[ eq ] rewrite eq = {!   !}

DeleteTodoDoesntChangeOtherTodos :
  (todos : List Todo) (id : ℕ) →
    DeleteTodo todos id ≡ l.filter (λ todo → dec-¬ (Todo.id todo ≟ id)) todos
DeleteTodoDoesntChangeOtherTodos todos id = refl
-- END DeleteTodo is well-defined

DeleteTodo-idem :
  (todos : List Todo) (id : ℕ) →
    DeleteTodo (DeleteTodo todos id) id ≡ DeleteTodo todos id
DeleteTodo-idem todos id = filter-idem (λ e → dec-¬ (Todo.id e ≟ id)) todos

-- {-# COMPILE JS DeleteTodo =
--   function (todos) {
--     return function (id) {
--       return todos.filter(function (todo) {
--         return todo.id !== id
--       });
--     }
--   }
-- #-}

-- EditTodo: can't use updateAt since id doesn't necessarily correspond to Vec index
EditTodo : (List Todo) → ℕ → String → (List Todo)
EditTodo todos id text =
  l.map (λ todo →
    if (⌊ Todo.id todo ≟ id ⌋)
    then record todo { text = text }
    else todo)
    todos

EditTodo' : (List Todo) → ℕ → String → (List Todo)
EditTodo' todos id text =
  l.map (λ todo →
    if (Todo.id todo ≡ᵇ id)
    then record todo { text = text }
    else todo)
    todos

-- EditTodo is well-defined
-- EditTodoChangesText :
--   (todos : List Todo) (id : ℕ) (text : String) →
--     l.map Todo.text (l.filter (λ todo → Todo.id todo ≟ id) (EditTodo todos id text)) ≡ l.[ text ]
-- EditTodoChangesText todos id text = {!   !}

-- -- TODO not necessarily true
-- EditTodo'ChangesText :
--   (todos : List Todo) (id : ℕ) (text : String) →
--     l.map Todo.text (EditTodo' (filter' (λ todo → Todo.id todo ≡ᵇ id) todos) id text) ≡ l.map Todo.text (filter' (λ todo → Todo.id todo ≡ᵇ id) todos)
-- EditTodo'ChangesText []       id text = refl
-- EditTodo'ChangesText (x ∷ xs) id text with (Todo.id x ≡ᵇ id) | inspect (_≡ᵇ id) (Todo.id x)
-- ... | true  | P.[ eq ] rewrite eq = {!   !} -- cong (Todo.text x l.∷_) (EditTodo'ChangesText xs id text)
-- ... | false | P.[ eq ] rewrite eq = EditTodo'ChangesText xs id text

EditTodo'DoesntChangeId :
  (todos : List Todo) (id : ℕ) (text : String) →
    l.map Todo.id (EditTodo' todos id text) ≡ l.map Todo.id todos
EditTodo'DoesntChangeId []       id text = refl
EditTodo'DoesntChangeId (x ∷ xs) id text with (Todo.id x ≡ᵇ id)
... | true  = cong ((Todo.id x) l.∷_) (EditTodo'DoesntChangeId xs id text)
... | false = cong ((Todo.id x) l.∷_) (EditTodo'DoesntChangeId xs id text)

EditTodo'DoesntChangeCompleted :
  (todos : List Todo) (id : ℕ) (text : String) →
    l.map Todo.completed (EditTodo' todos id text) ≡ l.map Todo.completed todos
EditTodo'DoesntChangeCompleted []       id text = refl
EditTodo'DoesntChangeCompleted (x ∷ xs) id text with (Todo.id x ≡ᵇ id)
... | true  = cong ((Todo.completed x) l.∷_) (EditTodo'DoesntChangeCompleted xs id text)
... | false = cong ((Todo.completed x) l.∷_) (EditTodo'DoesntChangeCompleted xs id text)

EditTodo'DoesntChangeOtherTodos :
  (todos : List Todo) (id : ℕ) (text : String) →
    filter' (λ todo → not (Todo.id todo ≡ᵇ id)) (EditTodo' todos id text) ≡ filter' (λ todo → not (Todo.id todo ≡ᵇ id)) todos
EditTodo'DoesntChangeOtherTodos []       id text = refl
EditTodo'DoesntChangeOtherTodos (x ∷ xs) id text with (Todo.id x ≡ᵇ id) | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ] rewrite eq = EditTodo'DoesntChangeOtherTodos xs id text
... | false | P.[ eq ] rewrite eq = cong (x l.∷_) (EditTodo'DoesntChangeOtherTodos xs id text)

EditTodoLengthUnchanged :
  (todos : List Todo) (id' : ℕ) (text : String) →
    l.length (EditTodo todos id' text) ≡ l.length todos
EditTodoLengthUnchanged todos id' text = length-map (λ todo → if (⌊ Todo.id todo ≟ id' ⌋) then record todo { text = text } else todo) todos
-- END EditTodo is well-defined

EditTodo'-idem :
  (todos : List Todo) (id : ℕ) (text : String) →
    EditTodo' (EditTodo' todos id text) id text ≡ EditTodo' todos id text
EditTodo'-idem []       id text = refl
EditTodo'-idem (x ∷ xs) id text with (Todo.id x ≡ᵇ id) | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ] rewrite eq = cong (record x { text = text } List.∷_) (EditTodo'-idem xs id text)
... | false | P.[ eq ] rewrite eq = cong (x List.∷_) (EditTodo'-idem xs id text)

-- {-# COMPILE JS EditTodo =
--   function (todos) {
--     return function (id) {
--       return function (text) {
--         return todos.map(function (todo) {
--           if (todo.id === id) {
--             todo.text = text;
--           }

--           return todo;
--         });
--       }
--     }
--   }
-- #-}

CompleteTodo : (List Todo) → ℕ → (List Todo)
CompleteTodo todos id =
  l.map (λ todo →
    if (⌊ Todo.id todo ≟ id ⌋)
    then record todo { completed = true }
    else todo)
    todos

CompleteTodo' : (List Todo) → ℕ → (List Todo)
CompleteTodo' todos id =
  l.map (λ todo →
    if (Todo.id todo ≡ᵇ id)
    then record todo { completed = true }
    else todo)
    todos

-- CompleteTodo is well-defined
-- TODO don't know if there is only one instance of Todo with that id
CompleteTodo'ChangesCompleted :
  (todos : List Todo) (id : ℕ) →
    l.map Todo.completed (filter' (λ todo → Todo.id todo ≡ᵇ id) (CompleteTodo' todos id)) ≡ l.map (λ todo → true) (filter' (λ todo → Todo.id todo ≡ᵇ id) todos)
CompleteTodo'ChangesCompleted []       id = refl
CompleteTodo'ChangesCompleted (x ∷ xs) id with Todo.id x ≡ᵇ id | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ] rewrite eq = cong (true l.∷_) (CompleteTodo'ChangesCompleted xs id)
... | false | P.[ eq ] rewrite eq = CompleteTodo'ChangesCompleted xs id

CompleteTodoDoesntChangeIds :
  (todos : List Todo) (id : ℕ) →
    l.map Todo.id (CompleteTodo todos id) ≡ l.map Todo.id todos
CompleteTodoDoesntChangeIds []       id = refl
CompleteTodoDoesntChangeIds (x ∷ []) id = cong (l._∷ l.[]) (helper x id)
  where
    helper :
      (x : Todo) (id : ℕ) →
        Todo.id (if ⌊ Todo.id x ≟ id ⌋ then record { text = Todo.text x ; completed = true ; id = Todo.id x } else x) ≡ Todo.id x
    helper x id with (⌊ Todo.id x ≟ id ⌋)
    ...         | true  = refl
    ...         | false = refl
CompleteTodoDoesntChangeIds (x ∷ xs) id =
  begin
    l.map Todo.id (CompleteTodo (x l.∷ xs) id)
  ≡⟨⟩
    (l.map Todo.id (CompleteTodo l.[ x ] id)) l.++ l.map Todo.id (CompleteTodo xs id)
  ≡⟨ cong (l._++ l.map Todo.id (CompleteTodo xs id)) (CompleteTodoDoesntChangeIds (x l.∷ l.[]) id) ⟩
    l.map Todo.id (l.[ x ]) l.++ l.map Todo.id (CompleteTodo xs id)
  ≡⟨⟩
    l.[ Todo.id x ] l.++ l.map Todo.id (CompleteTodo xs id)
  ≡⟨⟩
    Todo.id x l.∷ l.map Todo.id (CompleteTodo xs id)
  ≡⟨ cong (Todo.id x l.∷_) (CompleteTodoDoesntChangeIds xs id) ⟩
    Todo.id x l.∷ l.map Todo.id xs
  ≡⟨⟩
    l.map Todo.id (x l.∷ xs)
  ∎

CompleteTodoDoesntChangeText :
  (todos : List Todo) (id : ℕ) →
    l.map Todo.text (CompleteTodo todos id) ≡ l.map Todo.text todos
CompleteTodoDoesntChangeText []       id = refl
CompleteTodoDoesntChangeText (x ∷ []) id = cong (l._∷ l.[]) (helper x id)
  where
    helper :
      (x : Todo) (id : ℕ) →
        Todo.text (if ⌊ Todo.id x ≟ id ⌋ then record { text = Todo.text x ; completed = true ; id = Todo.id x } else x) ≡ Todo.text x
    helper x id with (⌊ Todo.id x ≟ id ⌋)
    ...         | true  = refl
    ...         | false = refl
CompleteTodoDoesntChangeText (x ∷ xs) id =
  begin
    l.map Todo.text (CompleteTodo (x l.∷ xs) id)
  ≡⟨⟩
    (l.map Todo.text (CompleteTodo l.[ x ] id)) l.++ l.map Todo.text (CompleteTodo xs id)
  ≡⟨ cong (l._++ l.map Todo.text (CompleteTodo xs id)) (CompleteTodoDoesntChangeText (x l.∷ l.[]) id) ⟩
    l.map Todo.text (l.[ x ]) l.++ l.map Todo.text (CompleteTodo xs id)
  ≡⟨⟩
    l.[ Todo.text x ] l.++ l.map Todo.text (CompleteTodo xs id)
  ≡⟨⟩
    Todo.text x l.∷ l.map Todo.text (CompleteTodo xs id)
  ≡⟨ cong (Todo.text x l.∷_) (CompleteTodoDoesntChangeText xs id) ⟩
    Todo.text x l.∷ l.map Todo.text xs
  ≡⟨⟩
    l.map Todo.text (x l.∷ xs)
  ∎

CompleteTodo'DoesntChangeOthersCompleted :
  (todos : List Todo) (id : ℕ) →
    l.map Todo.completed (CompleteTodo' (filter' (λ todo → not (Todo.id todo ≡ᵇ id)) todos) id) ≡ l.map Todo.completed (filter' (λ todo → not (Todo.id todo ≡ᵇ id)) todos)
CompleteTodo'DoesntChangeOthersCompleted []       id = refl
CompleteTodo'DoesntChangeOthersCompleted (x ∷ xs) id with Todo.id x ≡ᵇ id | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ] rewrite eq = CompleteTodo'DoesntChangeOthersCompleted xs id --
... | false | P.[ eq ] rewrite eq = cong (Todo.completed x l.∷_) (CompleteTodo'DoesntChangeOthersCompleted xs id)

CompleteTodoLengthUnchanged :
  (todos : List Todo) (id : ℕ) →
    l.length (CompleteTodo todos id) ≡ l.length todos
CompleteTodoLengthUnchanged todos id = length-map (λ todo → if (⌊ Todo.id todo ≟ id ⌋) then record todo { completed = true } else todo) todos
-- END CompleteTodo is well-defined

CompleteTodo'-idem :
  (todos : List Todo) (id : ℕ) →
    CompleteTodo' (CompleteTodo' todos id) id ≡ CompleteTodo' todos id
CompleteTodo'-idem []       id = refl
CompleteTodo'-idem (x ∷ xs) id with Todo.id x ≡ᵇ id | inspect (_≡ᵇ id) (Todo.id x)
... | true  | P.[ eq ] rewrite eq = cong (record x { completed = true } l.∷_) (CompleteTodo'-idem xs id)
... | false | P.[ eq ] rewrite eq = cong (x l.∷_) (CompleteTodo'-idem xs id)

-- {-# COMPILE JS CompleteTodo =
--   function (todos) {
--     return function (id) {
--       return todos.map(function (todo) {
--         if (todo.id === id) {
--           todo.completed = true;
--         }

--         return todo;
--       });
--     }
--   }
-- #-}

CompleteAllTodos : List Todo → List Todo
CompleteAllTodos todos =
  l.map (λ todo →
    record todo { completed = true })
    todos

-- CompleteAllTodos is well-defined
CompleteAllTodosAllCompleted :
  (todos : List Todo) →
    l.filter (λ todo → (Todo.completed todo) Bool.≟ false) (CompleteAllTodos todos) ≡ l.[]
CompleteAllTodosAllCompleted []       = refl
CompleteAllTodosAllCompleted (x ∷ xs) = CompleteAllTodosAllCompleted xs

CompleteAllTodosDoesntChangeIds :
  (todos : List Todo) →
    l.map Todo.id (CompleteAllTodos todos) ≡ l.map Todo.id todos
CompleteAllTodosDoesntChangeIds []       = refl
CompleteAllTodosDoesntChangeIds (x ∷ []) = cong (l._∷ l.[]) (helper x)
  where
    helper :
      (x : Todo) →
        Todo.id (record x { completed = true }) ≡ Todo.id x
    helper x = refl
CompleteAllTodosDoesntChangeIds (x ∷ xs) =
  begin
    l.map Todo.id (CompleteAllTodos (x l.∷ xs))
  ≡⟨⟩
    (l.map Todo.id (CompleteAllTodos l.[ x ])) l.++ l.map Todo.id (CompleteAllTodos xs)
  ≡⟨ cong (l._++ l.map Todo.id (CompleteAllTodos xs)) (CompleteAllTodosDoesntChangeIds (x l.∷ l.[])) ⟩
    l.map Todo.id (l.[ x ]) l.++ l.map Todo.id (CompleteAllTodos xs)
  ≡⟨⟩
    l.[ Todo.id x ] l.++ l.map Todo.id (CompleteAllTodos xs)
  ≡⟨⟩
    Todo.id x l.∷ l.map Todo.id (CompleteAllTodos xs)
  ≡⟨ cong (Todo.id x l.∷_) (CompleteAllTodosDoesntChangeIds xs) ⟩
    Todo.id x l.∷ l.map Todo.id xs
  ≡⟨⟩
    l.map Todo.id (x l.∷ xs)
  ∎

CompleteAllTodosDoesntChangeText :
  (todos : List Todo) →
    l.map Todo.text (CompleteAllTodos todos) ≡ l.map Todo.text todos
CompleteAllTodosDoesntChangeText []       = refl
CompleteAllTodosDoesntChangeText (x ∷ []) = cong (l._∷ l.[]) (helper x)
  where
    helper :
      (x : Todo) →
        Todo.text (record x { completed = true }) ≡ Todo.text x
    helper x = refl
CompleteAllTodosDoesntChangeText (x ∷ xs) =
  begin
    l.map Todo.text (CompleteAllTodos (x l.∷ xs))
  ≡⟨⟩
    (l.map Todo.text (CompleteAllTodos l.[ x ])) l.++ l.map Todo.text (CompleteAllTodos xs)
  ≡⟨ cong (l._++ l.map Todo.text (CompleteAllTodos xs)) (CompleteAllTodosDoesntChangeText (x l.∷ l.[])) ⟩
    l.map Todo.text (l.[ x ]) l.++ l.map Todo.text (CompleteAllTodos xs)
  ≡⟨⟩
    l.[ Todo.text x ] l.++ l.map Todo.text (CompleteAllTodos xs)
  ≡⟨⟩
    Todo.text x l.∷ l.map Todo.text (CompleteAllTodos xs)
  ≡⟨ cong (Todo.text x l.∷_) (CompleteAllTodosDoesntChangeText xs) ⟩
    Todo.text x l.∷ l.map Todo.text xs
  ≡⟨⟩
    l.map Todo.text (x l.∷ xs)
  ∎

CompleteAllTodosLengthUnchanged :
  (todos : List Todo) →
    l.length (CompleteAllTodos todos) ≡ l.length todos
CompleteAllTodosLengthUnchanged todos = length-map (λ todo → record todo { completed = true }) todos
-- END CompleteAllTodos is well-defined

-- CompleteAllTodos-idem

-- {-# COMPILE JS CompleteAllTodos =
--   function (todos) {
--     return todos.map(function(todo) {
--       todo.completed = true;
--       return todo;
--     });
--   }
-- #-}

ClearCompleted : (List Todo) → (List Todo)
ClearCompleted todos =
  (l.filter (λ todo → dec-¬ ((Todo.completed todo) Bool.≟ true)) todos)

-- ClearCompleted is well-defined
ClearCompletedRemovesOnlyCompleted :
  (todos : List Todo) →
    l.map Todo.completed (ClearCompleted todos) ≡ l.map Todo.completed (l.filter (λ todo → dec-¬ ((Todo.completed todo) Bool.≟ true)) todos)
ClearCompletedRemovesOnlyCompleted todos = refl

ClearCompletedDoesntChangeCompleted :
  (todos : List Todo) →
    l.map Todo.completed (ClearCompleted todos) ≡ l.map Todo.completed (l.filter (λ todo → dec-¬ ((Todo.completed todo) Bool.≟ true)) todos)
ClearCompletedDoesntChangeCompleted todos = refl

ClearCompletedDoesntChangeIds :
  (todos : List Todo) →
    l.map Todo.id (ClearCompleted todos) ≡ l.map Todo.id (l.filter (λ todo → dec-¬ ((Todo.completed todo) Bool.≟ true)) todos)
ClearCompletedDoesntChangeIds todos = refl

ClearCompletedDoesntChangeText :
  (todos : List Todo) →
    l.map Todo.text (ClearCompleted todos) ≡ l.map Todo.text (l.filter (λ todo → dec-¬ ((Todo.completed todo) Bool.≟ true)) todos)
ClearCompletedDoesntChangeText todos = refl
-- END ClearCompleted is well-defined

ClearCompleted-idem :
  (todos : List Todo) →
    ClearCompleted (ClearCompleted todos) ≡ ClearCompleted todos
ClearCompleted-idem todos = filter-idem (λ e → dec-¬ (Todo.completed e Bool.≟ true)) todos

-- {-# COMPILE JS ClearCompleted =
--   function (todos) {
--     return todos.filter(function(todo) {
--       return !todo.completed;
--     });
--   }
-- #-}

-- interactions
-- AddTodo-AddTodo
-- DeleteTodo-DeleteTodo
-- AddTodo-DeleteTodo
-- DeleteTodo-AddTodo
-- EditTodo-EditTodo
-- AddTodo-EditTodo
-- EditTodo-AddTodo
-- ...


-- 2010-09-07 Andreas
-- 2011-10-04 may not work even in the presence of experimental irr.
{-# OPTIONS --experimental-irrelevance #-}
module SplitOnIrrelevant where

data Bool : Set where
  true false : Bool

not : .Bool -> Bool
not true = false  -- needs to fail
not false = true


------------------------------------------------------------------------
-- A small library of derived parser combinators
------------------------------------------------------------------------

module TotalParserCombinators.Lib where

open import Category.Monad
open import Codata.Musical.Notation
open import Function.Base
open import Function.Equality using (_⟶_; _⟨$⟩_)
open import Function.Injection using (Injection; Injective)
open import Function.Inverse using (_↔_; module Inverse)
open import Data.Bool hiding (_≤?_)
open import Data.Char as Char using (Char; _==_)
open import Data.List as List
import Data.List.Categorical
open import Data.List.Membership.Propositional
import Data.List.Membership.Propositional.Properties as ∈
open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_)
open import Data.List.Relation.Unary.Any
open import Data.Maybe hiding (_>>=_)
open import Data.Nat hiding (_^_)
open import Data.Product as Prod
open import Data.Unit using (⊤)
open import Data.Vec as Vec using (Vec; []; _∷_)
import Level
open import Relation.Binary
open import Relation.Binary.HeterogeneousEquality as H using (_≅_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
import Relation.Binary.PropositionalEquality.WithK as P
open import Relation.Nullary
open import Relation.Nullary.Decidable

private
  open module ListMonad =
         RawMonad {f = Level.zero} Data.List.Categorical.monad
         using ()
         renaming (_<$>_ to _<$>′_; _⊛_ to _⊛′_; _>>=_ to _>>=′_)

import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics as S
  hiding (_≅_; return; token)

------------------------------------------------------------------------
-- Kleene star

-- The intended semantics of the Kleene star.

infixr 5 _∷_
infix  4 _∈[_]⋆·_

data _∈[_]⋆·_ {Tok R xs} :
              List R → Parser Tok R xs → List Tok → Set₁ where
  []  : ∀ {p} → [] ∈[ p ]⋆· []
  _∷_ : ∀ {x xs s₁ s₂ p} →
        (x∈p : x ∈ p · s₁) (xs∈p⋆ : xs ∈[ p ]⋆· s₂) →
        x ∷ xs ∈[ p ]⋆· s₁ ++ s₂

-- An implementation which requires that the argument parser is not
-- nullable.

infix 55 _⋆ _+

mutual

  _⋆ : ∀ {Tok R} →
       Parser Tok R        [] →
       Parser Tok (List R) [ [] ]
  p ⋆ = return [] ∣ p +

  _+ : ∀ {Tok R} →
       Parser Tok R        [] →
       Parser Tok (List R) []
  p + = _∷_ <$> p ⊛ ♯ (p ⋆)

module KleeneStar where

  -- The implementation is correct.

  sound : ∀ {Tok R xs s} {p : Parser Tok R []} →
          xs ∈ p ⋆ · s → xs ∈[ p ]⋆· s
  sound (∣-left S.return)              = []
  sound (∣-right ._ (<$> x∈p ⊛ xs∈p⋆)) = x∈p ∷ sound xs∈p⋆

  complete : ∀ {Tok R xs s} {p : Parser Tok R []} →
             xs ∈[ p ]⋆· s → xs ∈ p ⋆ · s
  complete []                           = ∣-left S.return
  complete (_∷_ {s₁ = []}    x∈p xs∈p⋆) with I.complete x∈p
  ... | ()
  complete (_∷_ {s₁ = _ ∷ _} x∈p xs∈p⋆) =
    ∣-right [ [] ] ([ ○ - ◌ ] <$> x∈p ⊛ complete xs∈p⋆)

  complete∘sound :
    ∀ {Tok R xs s} {p : Parser Tok R []} (xs∈ : xs ∈ p ⋆ · s) →
    complete (sound xs∈) ≡ xs∈
  complete∘sound (∣-left S.return) = P.refl
  complete∘sound (∣-right ._ (_⊛_ {s₁ = _ ∷ _} (<$> x∈p) xs∈p⋆))
    rewrite complete∘sound xs∈p⋆ = P.refl
  complete∘sound (∣-right ._ (_⊛_ {s₁ = []}    (<$> x∈p) xs∈p⋆))
    with I.complete x∈p
  ... | ()

  sound∘complete : ∀ {Tok R xs s} {p : Parser Tok R []}
                   (xs∈ : xs ∈[ p ]⋆· s) →
                   sound (complete xs∈) ≡ xs∈
  sound∘complete []                           = P.refl
  sound∘complete (_∷_ {s₁ = []}    x∈p xs∈p⋆) with I.complete x∈p
  ... | ()
  sound∘complete (_∷_ {s₁ = _ ∷ _} x∈p xs∈p⋆) =
    P.cong (_∷_ x∈p) $ sound∘complete xs∈p⋆

  correct : ∀ {Tok R xs s} {p : Parser Tok R []} →
            xs ∈ p ⋆ · s ↔ xs ∈[ p ]⋆· s
  correct = record
    { to         = P.→-to-⟶ sound
    ; from       = P.→-to-⟶ complete
    ; inverse-of = record
      { left-inverse-of  = complete∘sound
      ; right-inverse-of = sound∘complete
      }
    }

  -- The definition of _⋆ is restricted to non-nullable parsers. This
  -- restriction cannot be removed: an unrestricted Kleene star
  -- operator would be incomplete because, in the present framework, a
  -- parser can only return a finite number of results.

  unrestricted-incomplete :
    ∀ {R Tok} →
    R →
    (f : ∀ {xs} → Parser Tok R xs → List (List R)) →
    (_⋆′ : ∀ {xs} (p : Parser Tok R xs) → Parser Tok (List R) (f p)) →
    ¬ (∀ {xs ys s} {p : Parser Tok R ys} →
         xs ∈[ p ]⋆· s → xs ∈ p ⋆′ · s)
  unrestricted-incomplete {R} x f _⋆′ complete =
    ∈.finite (record { to = to; injective = injective })
             (f (return x)) (I.complete ∘ complete ∘ lemma)
    where
    to : P.setoid ℕ ⟶ P.setoid (List R)
    to = P.→-to-⟶ (flip replicate x)

    helper : ∀ {xs ys} → _≡_ {A = List R} (x ∷ xs) (x ∷ ys) → xs ≡ ys
    helper P.refl = P.refl

    injective : Injective to
    injective {zero}  {zero}  _  = P.refl
    injective {suc m} {suc n} eq = P.cong suc $
                                     injective $ helper eq
    injective {zero}  {suc n} ()
    injective {suc m} {zero}  ()

    lemma : ∀ i → replicate i x ∈[ return x ]⋆· []
    lemma zero    = []
    lemma (suc i) = S.return ∷ lemma i

------------------------------------------------------------------------
-- A combinator for recognising a string a fixed number of times

infixl 55 _^_ _↑_

^-initial : ∀ {R} → List R → (n : ℕ) → List (Vec R n)
^-initial xs zero    = [ [] ]
^-initial xs (suc n) = List.map _∷_ xs ⊛′ ^-initial xs n

_^_ : ∀ {Tok R xs} →
      Parser Tok R xs → (n : ℕ) → Parser Tok (Vec R n) (^-initial xs n)
p ^ 0     = return []
p ^ suc n = _∷_ <$> p ⊛ p ^ n

mutual

  -- A variant.

  -- The two functions below are not actually mutually recursive, but
  -- are placed in a mutual block to ensure that the constraints
  -- generated by the second function can be used to instantiate the
  -- underscores in the body of the first.

  ↑-initial : ∀ {R} → List R → ℕ → List (List R)
  ↑-initial _ _ = _

  _↑_ : ∀ {Tok R xs} →
        Parser Tok R xs → (n : ℕ) → Parser Tok (List R) (↑-initial xs n)
  p ↑ n = Vec.toList <$> p ^ n

-- Some lemmas relating _↑_ to _⋆.

module Exactly where

  ↑≲⋆ : ∀ {Tok R} {p : Parser Tok R []} n → p ↑ n ≲ p ⋆
  ↑≲⋆ {R = R} {p} n (<$> ∈pⁿ) = KleeneStar.complete $ helper n ∈pⁿ
    where
    helper : ∀ n {xs s} → xs ∈ p ^ n · s → Vec.toList xs ∈[ p ]⋆· s
    helper zero    S.return       = []
    helper (suc n) (<$> ∈p ⊛ ∈pⁿ) = ∈p ∷ helper n ∈pⁿ

  ⋆≲∃↑ : ∀ {Tok R} {p : Parser Tok R []} {xs s} →
         xs ∈ p ⋆ · s → ∃ λ i → xs ∈ p ↑ i · s
  ⋆≲∃↑ {R = R} {p} ∈p⋆ with helper $ KleeneStar.sound ∈p⋆
    where
    helper : ∀ {xs s} → xs ∈[ p ]⋆· s →
             ∃₂ λ i (ys : Vec R i) →
                  xs ≡ Vec.toList ys × ys ∈ p ^ i · s
    helper []         = (0 , [] , P.refl , S.return)
    helper (∈p ∷ ∈p⋆) =
      Prod.map suc (λ {i} →
        Prod.map (_∷_ _) (
          Prod.map (P.cong (_∷_ _))
                   (λ ∈pⁱ → [ ○ - ○ ] <$> ∈p ⊛ ∈pⁱ)))
       (helper ∈p⋆)
  ... | (i , ys , P.refl , ∈pⁱ) = (i , <$> ∈pⁱ)

------------------------------------------------------------------------
-- A parser which returns any element in a given list

return⋆ : ∀ {Tok R} (xs : List R) → Parser Tok R xs
return⋆ []       = fail
return⋆ (x ∷ xs) = return x ∣ return⋆ xs

module Return⋆ where

  sound : ∀ {Tok R x} {s : List Tok}
          (xs : List R) → x ∈ return⋆ xs · s → s ≡ [] × x ∈ xs
  sound []       ()
  sound (y ∷ ys) (∣-left S.return)       = (P.refl , here P.refl)
  sound (y ∷ ys) (∣-right .([ y ]) x∈ys) =
    Prod.map id there $ sound ys x∈ys

  complete : ∀ {Tok R x} {xs : List R} →
             x ∈ xs → x ∈ return⋆ {Tok} xs · []
  complete (here P.refl) = ∣-left S.return
  complete (there x∈xs)  =
    ∣-right [ _ ] (complete x∈xs)

  complete∘sound : ∀ {Tok R x} {s : List Tok}
                   (xs : List R) (x∈xs : x ∈ return⋆ xs · s) →
                   complete {Tok = Tok} (proj₂ $ sound xs x∈xs) ≅ x∈xs
  complete∘sound []       ()
  complete∘sound (y ∷ ys) (∣-left S.return)       = H.refl
  complete∘sound (y ∷ ys) (∣-right .([ y ]) x∈ys)
    with sound ys x∈ys | complete∘sound ys x∈ys
  complete∘sound (y ∷ ys) (∣-right .([ y ]) .(complete p))
    | (P.refl , p) | H.refl = H.refl

  sound∘complete : ∀ {Tok R x} {xs : List R} (x∈xs : x ∈ xs) →
                   sound {Tok = Tok} {s = []} xs (complete x∈xs) ≡
                   (P.refl , x∈xs)
  sound∘complete       (here P.refl)          = P.refl
  sound∘complete {Tok} (there {xs = xs} x∈xs)
    with sound {Tok = Tok} xs (complete x∈xs)
       | sound∘complete {Tok} {xs = xs} x∈xs
  sound∘complete (there x∈xs) | .(P.refl , x∈xs) | P.refl = P.refl

  correct : ∀ {Tok R} {xs : List R} {x s} →
            (s ≡ [] × x ∈ xs) ↔ x ∈ return⋆ {Tok} xs · s
  correct {xs = xs} {x} = record
    { to         = P.→-to-⟶ complete′
    ; from       = P.→-to-⟶ $ sound xs
    ; inverse-of = record
      { left-inverse-of  = sound∘complete′
      ; right-inverse-of = complete′∘sound xs
      }
    }
    where
    complete′ : ∀ {Tok R x} {xs : List R} {s : List Tok} →
                s ≡ [] × x ∈ xs → x ∈ return⋆ xs · s
    complete′ (P.refl , x∈xs) = complete x∈xs

    sound∘complete′ : ∀ {Tok R x} {xs : List R} {s : List Tok}
                      (p : s ≡ [] × x ∈ xs) → sound xs (complete′ p) ≡ p
    sound∘complete′ (P.refl , x∈xs) = sound∘complete x∈xs

    complete′∘sound : ∀ {Tok R x} {s : List Tok}
                      (xs : List R) (x∈xs : x ∈ return⋆ xs · s) →
                      complete′ (sound xs x∈xs) ≡ x∈xs
    complete′∘sound xs x∈ with sound xs x∈ | complete∘sound xs x∈
    complete′∘sound xs .(complete x∈xs) | (P.refl , x∈xs) | H.refl =
      P.refl

------------------------------------------------------------------------
-- The sat parser

module Sat where

  -- Helper functions for sat.

  mutual

    ok-bag : {R : Set} → Maybe R → List R
    ok-bag nothing  = _
    ok-bag (just _) = _

    ok : {Tok R : Set} → (x : Maybe R) → Parser Tok R (ok-bag x)
    ok nothing  = fail
    ok (just x) = return x

  ok-correct : ∀ {Tok R x s} (m : Maybe R) →
               (s ≡ [] × m ≡ just x) ↔ x ∈ ok {Tok} m · s
  ok-correct {Tok} {x = x} m = record
    { to         = P.→-to-⟶ (to m)
    ; from       = P.→-to-⟶ (from m)
    ; inverse-of = record
      { left-inverse-of  = from∘to m
      ; right-inverse-of = to∘from m
      }
    }
    where
    to : ∀ {s} m → (s ≡ [] × m ≡ just x) → x ∈ ok {Tok} m · s
    to (just .x) (P.refl , P.refl) = S.return
    to nothing   (P.refl , ())

    from : ∀ {s} m → x ∈ ok {Tok} m · s → s ≡ [] × m ≡ just x
    from (just .x) S.return = (P.refl , P.refl)
    from nothing   ()

    from∘to : ∀ {s} m (eqs : s ≡ [] × m ≡ just x) →
              from m (to m eqs) ≡ eqs
    from∘to (just .x) (P.refl , P.refl) = P.refl
    from∘to nothing   (P.refl , ())

    to∘from : ∀ {s} m (x∈ : x ∈ ok {Tok} m · s) →
              to m (from m x∈) ≡ x∈
    to∘from (just .x) S.return = P.refl
    to∘from nothing   ()

  -- sat p accepts a single token t iff p t ≡ just x for some x. The
  -- returned value is x.

  sat : ∀ {Tok R} → (Tok → Maybe R) → Parser Tok R _
  sat p = token >>= (ok ∘ p)

  correct : ∀ {Tok R x s} (p : Tok → Maybe R) →
            (∃ λ t → s ≡ [ t ] × p t ≡ just x) ↔ x ∈ sat p · s
  correct {x = x} p = record
    { to         = P.→-to-⟶ to
    ; from       = P.→-to-⟶ from
    ; inverse-of = record
      { left-inverse-of  = from∘to
      ; right-inverse-of = to∘from
      }
    }
    where
    to : ∀ {s} → (∃ λ t → s ≡ [ t ] × p t ≡ just x) → x ∈ sat p · s
    to (t , P.refl , p-t≡just-x) =
      [ ○ - ○ ] S.token >>=
                (Inverse.to (ok-correct (p t)) ⟨$⟩ (P.refl , p-t≡just-x))

    from : ∀ {s} → x ∈ sat p · s → ∃ λ t → s ≡ [ t ] × p t ≡ just x
    from (S.token {x = t} >>= x∈ok-p-t) =
      (t , Prod.map (P.cong (_∷_ t)) id
             (Inverse.from (ok-correct (p t)) ⟨$⟩ x∈ok-p-t))

    from∘to : ∀ {s} (eqs : ∃ λ t → s ≡ [ t ] × p t ≡ just x) →
              from (to eqs) ≡ eqs
    from∘to (t , P.refl , p-t≡just-x) =
      P.cong₂ (λ eq₁ eq₂ → (t , eq₁ , eq₂))
              (P.≡-irrelevant _ _)
              (P.≡-irrelevant _ _)

    to∘from : ∀ {s} (x∈ : x ∈ sat p · s) → to (from x∈) ≡ x∈
    to∘from (S.token {x = t} >>= x∈ok-p-t)
      with Inverse.from (ok-correct (p t)) ⟨$⟩ x∈ok-p-t
         | Inverse.right-inverse-of (ok-correct (p t)) x∈ok-p-t
    to∘from (S.token {x = t} >>= .(Inverse.to (ok-correct (p t)) ⟨$⟩
                                     (P.refl , p-t≡just-x)))
      | (P.refl , p-t≡just-x) | P.refl = P.refl

open Sat public using (sat)

-- A simplified variant of sat. Does not return anything interesting.

sat′ : ∀ {Tok} → (Tok → Bool) → Parser Tok ⊤ _
sat′ p = sat (boolToMaybe ∘ p)

-- Accepts a single whitespace character (from a limited set of such
-- characters).

whitespace : Parser Char ⊤ _
whitespace = sat′ isSpace
  where
  isSpace = λ c →
    (c == ' ') ∨ (c == '\t') ∨ (c == '\n') ∨ (c == '\r')

------------------------------------------------------------------------
-- A parser for a given token

module Token
         (Tok : Set)
         (_≟_ : Decidable (_≡_ {A = Tok}))
         where

  private
    p : Tok → Tok → Maybe Tok
    p t t′ = if ⌊ t ≟ t′ ⌋ then just t′ else nothing

  tok : Tok → Parser Tok Tok []
  tok t = sat (p t)

  sound : ∀ t {t′ s} →
          t′ ∈ tok t · s → t ≡ t′ × s ≡ [ t′ ]
  sound t t′∈ with Inverse.from (Sat.correct (p t)) ⟨$⟩ t′∈
  sound t t′∈ | (t″ , P.refl , p-t-t″≡just-t′) with t ≟ t″
  sound t t∈  | (.t , P.refl , P.refl) | yes P.refl = (P.refl , P.refl)
  sound t t′∈ | (t″ , P.refl , ())     | no  _

  private
    p-lemma : ∀ t → p t t ≡ just t
    p-lemma t with t ≟ t
    ... | yes P.refl = P.refl
    ... | no  t≢t    with t≢t P.refl
    ...   | ()

  complete : ∀ {t} → t ∈ tok t · [ t ]
  complete {t} =
    Inverse.to (Sat.correct (p t)) ⟨$⟩ (t , P.refl , p-lemma t)

  η : ∀ {t} (t∈ : t ∈ tok t · [ t ]) → t∈ ≡ complete {t = t}
  η {t = t} t∈ = H.≅-to-≡ $ helper t∈ P.refl
    where
    helper₂ : (t∈ : t ∈ Sat.ok {Tok = Tok} (p t t) · []) →
              t∈ ≡ Inverse.to (Sat.ok-correct (p t t)) ⟨$⟩
                     (P.refl , p-lemma t)
    helper₂ t∈       with t ≟ t
    helper₂ S.return | yes P.refl = P.refl
    helper₂ t∈       | no  t≢t  with t≢t P.refl
    helper₂ t∈       | no  t≢t  | ()

    helper : ∀ {s} (t∈ : t ∈ tok t · s) → s ≡ [ t ] →
             t∈ ≅ complete {t = t}
    helper (S.token >>= t∈) P.refl rewrite helper₂ t∈ = H.refl

------------------------------------------------------------------------
-- Map then choice

-- y ∈ ⋁ f xs · s  iff  ∃ x ∈ xs. y ∈ f x · s.

⋁ : ∀ {Tok R₁ R₂} {f : R₁ → List R₂} →
    ((x : R₁) → Parser Tok R₂ (f x)) → (xs : List R₁) →
    Parser Tok R₂ (xs >>=′ f)
⋁ f xs = return⋆ xs >>= f

module ⋁ where

  sound : ∀ {Tok R₁ R₂ y s} {i : R₁ → List R₂} →
          (f : (x : R₁) → Parser Tok R₂ (i x)) (xs : List R₁) →
          y ∈ ⋁ f xs · s → ∃ λ x → (x ∈ xs) × (y ∈ f x · s)
  sound f xs (∈ret⋆ >>= y∈fx) with Return⋆.sound xs ∈ret⋆
  ...   | (P.refl , x∈xs) = (_ , x∈xs , y∈fx)

  complete : ∀ {Tok R₁ R₂ x y s} {i : R₁ → List R₂} →
             (f : (x : R₁) → Parser Tok R₂ (i x)) {xs : List R₁} →
             x ∈ xs → y ∈ f x · s → y ∈ ⋁ f xs · s
  complete f x∈xs y∈fx =
    [ ○ - ○ ] Return⋆.complete x∈xs >>= y∈fx

  complete∘sound : ∀ {Tok R₁ R₂ y s} {i : R₁ → List R₂} →
                   (f : (x : R₁) → Parser Tok R₂ (i x)) (xs : List R₁)
                   (y∈⋁fxs : y ∈ ⋁ f xs · s) →
                   let p = proj₂ $ sound f xs y∈⋁fxs in
                   complete f (proj₁ p) (proj₂ p) ≡ y∈⋁fxs
  complete∘sound f xs (∈ret⋆ >>= y∈fx)
    with Return⋆.sound xs ∈ret⋆
       | Inverse.right-inverse-of Return⋆.correct ∈ret⋆
  complete∘sound f xs (.(Return⋆.complete x∈xs) >>= y∈fx)
    | (P.refl , x∈xs) | P.refl = P.refl

  sound∘complete :
    ∀ {Tok R₁ R₂ x y s} {i : R₁ → List R₂} →
    (f : (x : R₁) → Parser Tok R₂ (i x)) {xs : List R₁} →
    (x∈xs : x ∈ xs) (y∈fx : y ∈ f x · s) →
    sound f xs (complete f x∈xs y∈fx) ≡ (x , x∈xs , y∈fx)
  sound∘complete {Tok} f {xs} x∈xs y∈fx
    with Return⋆.sound {Tok = Tok} xs (Return⋆.complete x∈xs)
       | Inverse.left-inverse-of (Return⋆.correct {Tok = Tok})
                                 (P.refl , x∈xs)
  ... | (P.refl , .x∈xs) | P.refl = P.refl

------------------------------------------------------------------------
-- Digits and numbers

-- Digits.

digit = sat (λ t → if in-range t then just (to-number t) else nothing)
  where
  in-range : Char → Bool
  in-range t = ⌊ Char.toℕ '0' ≤? Char.toℕ  t  ⌋ ∧
               ⌊ Char.toℕ  t  ≤? Char.toℕ '9' ⌋

  to-number : Char → ℕ
  to-number t = Char.toℕ t ∸ Char.toℕ '0'

-- Numbers.

number : Parser Char ℕ _
number = digit + >>= (return ∘ foldl (λ n d → 10 * n + d) 0)


{-# OPTIONS --rewriting #-}

-- Normalization by Evaluation for Graded Call-By-Push-Value.

module GradedCBPV where

-- Imports from the Agda standard library.

open import Library hiding (_×̇_)
pattern here! = here refl

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

open import ProMonoid as _

-- We postulate an effect algebra, a pre-ordered monoid

postulate
  effAlg : ProMonoid lzero lzero lzero

open ProMonoid effAlg public
  renaming
    ( Carrier to Eff
    ; _∙_     to infixl 6 _+_
    ; ε       to ∅
    ; _≼_     to _≤_
    ; _≈_     to _=E_
    )

-- postulate
--   +-unitˡ : ∅ + e ≡ e
--   +-unitʳ : e + ∅ ≡ e
--   +-assoc : (e₁ + e₂) + e₃ ≡ e₁ + (e₂ + e₃)
--   +-supʳ  : sup es + e ≡ sup λ i → es i + e
--   sup-k   : sup {I = I} (λ _ → e) ≡ e

-- {-# REWRITE +-unitˡ +-unitʳ +-assoc +-supʳ sup-k #-}

-- We postulate a set of generic value types.
-- There are no operations defined on these types, thus,
-- they play the type of (universal) type variables.

postulate
  Base : Set

variable
  o : Base

-- Variants (Σ) (and records (Π), resp.) can in principle have any number of
-- constructors (fields, resp.), including infinitely one.
-- In general, the constructor (field, resp.) names are given by a set I.
-- However, I : Set would make syntax already a big type, living in Set₁.
-- To keep it in Set₀, we only consider variants (records) with finitely
-- many constructors (fields), thus, I : ℕ.
-- Branching over I is then realized as functions out of El I, where
-- El I = { i | i < I} = Fin I.

set = ℕ
El  = Fin

-- Let I range over arities (constructor/field sets) and i over
-- constructor/field names.

variable
  I : set
  i : El I

variable
  e e' e₁ e₂ e₃ : Eff
  es : El I → Eff

-- The types of CBPV are classified into value types P : Ty⁺ which we
-- refer to as positive types, and computation types N : Ty⁻ which we
-- refer to as negative types.

mutual

  -- Value types

  data Ty⁺ : Set where
    base  : (o : Base) → Ty⁺                   -- Base type.
    _×̇_   : (P₁ P₂ : Ty⁺) → Ty⁺                -- Finite product (tensor).
    Σ̇     : (I : set) (Ps : El I → Ty⁺) → Ty⁺  -- Variant (sum).
    [_]   : (e : Eff) (N : Ty⁻) → Ty⁺          -- Thunk (U).
                                               -- Remembers effects.

  -- Computation types

  data Ty⁻ : Set where
    ◇̇    : (P : Ty⁺) → Ty⁻                     -- Comp (F).
    Π̇    : (I : set) (Ns : El I → Ty⁻) → Ty⁻   -- Record (lazy product).
    _⇒̇_  : (P : Ty⁺) (N : Ty⁻) → Ty⁻           -- Function type.

-- In CBPV, a variable stands for a value.
-- Thus, environments only contain values,
-- and typing contexts only value types.

-- We use introduce syntax in an intrinsically well-typed way
-- with variables being de Bruijn indices into the typing context.
-- Thus, contexts are just lists of types.

Cxt = List Ty⁺

variable
  Γ Δ Φ            : Cxt
  J                : Cxt → Set
  P P₁ P₂ P' P′ Q  : Ty⁺
  N N₁ N₂ N' N′    : Ty⁻
  Ps               : El I → Ty⁺
  Ns               : El I → Ty⁻

-- Generic values

module _ (Var : Ty⁺ → Cxt → Set) (Comp : Eff → Ty⁻ → Cxt → Set) where

  -- Right non-invertible

  data Val' : (P : Ty⁺) (Γ : Cxt) → Set where
    var    : (x : Var P Γ)                      → Val' P Γ
    pair   : (v₁ : Val' P₁ Γ) (v₂ : Val' P₂ Γ)  → Val' (P₁ ×̇ P₂) Γ
    inj    : (i : _) (v : Val' (Ps i) Γ)        → Val' (Σ̇ I Ps) Γ
    thunk  : (t : Comp e N Γ)                   → Val' ([ e ] N) Γ

-- Terms

mutual

  Val = Val' _∈_ Comp

  data Comp (e : Eff) : (N : Ty⁻) (Γ : Cxt) → Set where
    -- introductions
    ret    : (∅≤ : ∅ ≤ e)
             (v : Val P Γ)                → Comp e (◇̇ P)    Γ
    rec    : (t : ∀ i → Comp e (Ns i) Γ)  → Comp e (Π̇ I Ns) Γ
    abs    : (t : Comp e N (P ∷ Γ))       → Comp e (P ⇒̇ N)  Γ
    -- positive eliminations
    split  : (v : Val (P₁ ×̇ P₂) Γ)  (t : Comp e N (P₂ ∷ P₁ ∷ Γ))      → Comp e N Γ
    case   : (v : Val (Σ̇ I Ps) Γ)   (t : ∀ i → Comp e N (Ps i ∷ Γ))   → Comp e N Γ
    bind   : (+≤ : e₁ + e₂ ≤ e)
             (u : Comp e₁ (◇̇ P) Γ)  (t : Comp e₂ N (P ∷ Γ))           → Comp e N Γ
    -- cut
    letv   : (v : Val P Γ)          (t : Comp e N (P ∷ Γ))            → Comp e N Γ
    -- negative eliminations
    force  : (v : Val  ([ e ] N)  Γ)                  → Comp e N      Γ
    prj    : (i : _) (t : Comp e (Π̇ I Ns) Γ)          → Comp e (Ns i) Γ
    app    : (t : Comp e (P ⇒̇ N)  Γ)   (v : Val P Γ)  → Comp e N      Γ

-- Normal forms
------------------------------------------------------------------------

-- Normal values only reference variables of base type

NVar : (P : Ty⁺) (Γ : Cxt) → Set
NVar (base o) Γ = base o ∈ Γ
NVar _ _ = ⊥

-- Negative neutrals

module _ (Val : Ty⁺ → Cxt → Set) where

  -- Right non-invertible
  -- Propagates the effect from the head variable, a thunk.

  data Ne' (e : Eff) : (N : Ty⁻) (Γ : Cxt) → Set where
    force  : (x : [ e ] N ∈ Γ)                    → Ne' e N Γ
    prj    : (i : El I) (t : Ne' e (Π̇ I Ns) Γ)    → Ne' e (Ns i) Γ
    app    : (t : Ne' e (P ⇒̇ N) Γ) (v : Val P Γ)  → Ne' e N Γ

mutual

  NVal = Val' NVar Nf
  Ne   = Ne' NVal

  -- Cover monad (generalized case tree).
  -- Collects effects from all bind nodes.

  data ⟨_⟩ (e : Eff) (J : Cxt → Set) (Γ : Cxt) : Set where
    return  : (∅≤ : ∅ ≤ e)         (j : J Γ)                          → ⟨ e ⟩ J Γ
    bind    : (+≤ : e₁ + e₂ ≤ e)
              (u : Ne e₁ (◇̇ P) Γ)  (t :      ⟨ e₂ ⟩ J       (P ∷ Γ))  → ⟨ e ⟩ J Γ
    case    : (x : Σ̇ I Ps ∈ Γ)     (t : ∀ i → ⟨ e ⟩ J    (Ps i ∷ Γ))  → ⟨ e ⟩ J Γ
    split   : (x : (P₁ ×̇ P₂) ∈ Γ)  (t :       ⟨ e ⟩ J (P₂ ∷ P₁ ∷ Γ))  → ⟨ e ⟩ J Γ

  ◇ : ∀ J e Γ → Set
  ◇ J e = ⟨ e ⟩ J

  -- syntax ◇ J e = ⟨ e ⟩ J

  -- Right invertible.

  data Nf (e : Eff) : (N : Ty⁻) (Γ : Cxt) → Set where
    -- ne only needed for negative base types
    -- ne    : let N = ◇̇ (base o) in (n : ⟨ e ⟩ (Ne e N) Γ)  → Nf e N       Γ
    -- ne    : let N = ◇̇ (base o) in
    --         (+≤ : e₁ + e₂ ≤ e) (n : ⟨ e₂ ⟩ (Ne e₁ N) Γ)  → Nf e N Γ
    ret   : (v : ⟨ e ⟩ (NVal P) Γ)                        → Nf e (◇̇ P)   Γ   -- Invoke RFoc
    rec   : (ts : ∀ i → Nf e (Ns i) Γ)                    → Nf e (Π̇ I Ns) Γ
    abs   : (t : Nf e N (P ∷ Γ))                          → Nf e (P ⇒̇ N)  Γ

-- Context-indexed sets
------------------------------------------------------------------------

PSet = (Γ : Cxt) → Set
NSet = (e : Eff) (Γ : Cxt) → Set

variable
  C A A' A₁ A₂ : PSet
  B B' B₁ B₂ : NSet
  F G As : (i : El I) → PSet
  Bs Bs' Bs₁ Bs₂ : (i : El I) → NSet

-- Constructions on PSet

1̂ : PSet
1̂ Γ = ⊤

_×̂_ : (A₁ A₂ : PSet) → PSet
(A₁ ×̂ A₂) Γ = A₁ Γ × A₂ Γ

Σ̂ : (I : set) (As : El I → PSet) → PSet
(Σ̂ I F) Γ = ∃ λ i → F i Γ

_⇒̂_ : (A₁ A₂ : PSet) → PSet
(A₁ ⇒̂ A₂) Γ = A₁ Γ → A₂ Γ

Π̂ : (I : set) (As : El I → PSet) → PSet
(Π̂ I As) Γ = ∀ i → As i Γ

⟪_⟫ : (P : Ty⁺) (A : PSet) → PSet
⟪ P ⟫ A Γ = A (P ∷ Γ)

-- Constructions on NSet

_⇒ⁿ_ : (A : PSet) (B : NSet) → NSet
(A ⇒ⁿ B) e Γ = A Γ → B e Γ

Πⁿ : (I : set) (Bs : El I → NSet) → NSet
(Πⁿ I Bs) e Γ = ∀ i → Bs i e Γ

-- Morphisms between ISets

_→̇_ : (A₁ A₂ : PSet) → Set
A₁ →̇ A₂ = ∀{Γ} → A₁ Γ → A₂ Γ

_→̈_ : (B₁ B₂ : NSet) → Set
B₁ →̈ B₂ = ∀{e Γ} → B₁ e Γ → B₂ e Γ

⟨_⊙_⟩→̇_ : (P Q R : PSet) → Set
⟨ P ⊙ Q ⟩→̇ R = ∀{Γ} → P Γ → Q Γ → R Γ

⟨_⊙_⊙_⟩→̇_ : (P Q R S : PSet) → Set
⟨ P ⊙ Q ⊙ R ⟩→̇ S = ∀{Γ} → P Γ → Q Γ → R Γ → S Γ

Map : (F : (PSet) → PSet) → Set₁
Map F = ∀{A B : PSet} (f : A →̇ B) → F A →̇ F B

Π-map : (∀ i {e} → Bs i e →̇ Bs' i e) → ∀{e} → Πⁿ I Bs e →̇ Πⁿ I Bs' e
Π-map f r i = f i (r i)

-- -- Introductions and eliminations for ×̂

-- p̂air : ⟨ A ⊙ B ⟩→̇ (A ×̂ B)
-- p̂air a b = λ

-- Monotonicity
------------------------------------------------------------------------

-- Monotonization □ is a monoidal comonad

□ : (A : PSet) → PSet
□ A Γ = ∀{Δ} (τ : Γ ⊆ Δ) → A Δ

extract : □ A →̇ A
extract a = a ⊆-refl

duplicate : □ A →̇ □ (□ A)
duplicate a τ τ′ = a (⊆-trans τ τ′)

□-map : Map □
□-map f a τ = f (a τ)

extend : (□ A →̇ C) → □ A →̇ □ C
extend f = □-map f ∘ duplicate

□-weak : □ A →̇ ⟪ P ⟫ (□ A)
□-weak a τ = a (⊆-trans (_ ∷ʳ ⊆-refl) τ)

□-weak' : □ A →̇ □ (⟪ P ⟫ A)
□-weak' a τ = a (_ ∷ʳ τ)

□-sum : Σ̂ I (□ ∘ F) →̇ □ (Σ̂ I F)
□-sum (i , a) τ = i , a τ

-- Monoidality:

□-unit : 1̂ →̇ □ 1̂
□-unit = _

□-pair : ⟨ □ A₁ ⊙ □ A₂ ⟩→̇ □ (A₁ ×̂ A₂)
□-pair a b τ = (a τ , b τ)

-- -- Strong functoriality

Map! : (F : PSet → PSet) → Set₁
Map! F = ∀{A C} → ⟨ □ (λ Γ → A Γ → C Γ) ⊙ F A ⟩→̇ F C

-- Monotonicity

Mon : (A : PSet) → Set
Mon A = A →̇ □ A

monVar : Mon (P ∈_)
monVar x τ = ⊆-lookup τ x

-- Positive ISets are monotone

□-mon : Mon (□ A)
□-mon = duplicate

1-mon : Mon 1̂
1-mon = □-unit

×-mon : Mon A₁ → Mon A₂ → Mon (A₁ ×̂ A₂)
×-mon mA mB (a , b) = □-pair (mA a) (mB b)

Σ-mon : ((i : El I) → Mon (F i)) → Mon (Σ̂ I F)
Σ-mon m (i , a) = □-sum (i , m i a)

□-intro : Mon A → (A →̇ C) → (A →̇ □ C)
□-intro mA f = □-map f ∘ mA

-- Cover monad: a strong graded monad
------------------------------------------------------------------------

join : ⟨ e₁ ⟩ (⟨ e₂ ⟩ A) →̇ ⟨ e₁ + e₂ ⟩ A
join (return ∅≤e c)  = {!c !}
join (bind ≤e u c)  = {!bind u (join c) !}
join (case x t)  = case x (join ∘ t)
join (split x c) = split x (join c)

{-
◇-map : Map ⟨ e ⟩
◇-map f (return  j) = return  (f j)
◇-map f (bind  u a) = bind  u (◇-map f a)
◇-map f (case  x t) = case  x (λ i → ◇-map f (t i))
◇-map f (split x a) = split x (◇-map f a)

◇-map! : Map! ⟨ e ⟩
◇-map! f (return  j) = return  (extract f j)
◇-map! f (bind  u a) = bind  u (◇-map! (□-weak f) a)
◇-map! f (case  x t) = case  x (λ i → ◇-map! (□-weak f) (t i))
◇-map! f (split x a) = split x (◇-map! (□-weak (□-weak f)) a)

◇-bind : A →̇ ⟨ e₂ ⟩ C → ⟨ e₁ ⟩ A →̇ ⟨ e₁ + e₂ ⟩ C
◇-bind f = join ∘ ◇-map f

◇-record : (⟨ e ⟩ ∘ Πⁿ I Bs) →̈ Πⁿ I (λ i → ⟨ e ⟩ ∘ Bs i)
◇-record c i = ◇-map (_$ i) c

◇-fun : Mon A → (⟨ e ⟩ ∘ A ⇒ⁿ B) →̈ (A ⇒ⁿ (⟨ e ⟩ ∘ B))
◇-fun mA c a = ◇-map! (λ τ f → f (mA a τ)) c

-- Monoidal functoriality

◇-pair : ⟨ □ (⟨ e₁ ⟩ A₁) ⊙ ⟨ e₂ ⟩ (□ A₂) ⟩→̇ ⟨ e₂ + e₁ ⟩ (A₁ ×̂ A₂)
◇-pair ca = join ∘ ◇-map! λ τ b → ◇-map! (λ τ′ a → a , b τ′) (ca τ)

_⋉_ = ◇-pair

□◇-pair' : ⟨ □ (⟨ e₁ ⟩ A₁) ⊙ □ (⟨ e₂ ⟩ (□ A₂)) ⟩→̇ □ (⟨ e₂ + e₁ ⟩ (A₁ ×̂ A₂))
□◇-pair' ca cb τ = ◇-pair (□-mon ca τ) (cb τ)

□◇-pair : Mon A₂ → ⟨ □ (⟨ e₁ ⟩ A₁) ⊙ □ (⟨ e₂ ⟩ A₂) ⟩→̇ □ (⟨ e₂ + e₁ ⟩ (A₁ ×̂ A₂))
□◇-pair mB ca cb τ = join $
  ◇-map! (λ τ₁ b → ◇-map! (λ τ₂ a → a , mB b τ₂) (ca (⊆-trans τ τ₁))) (cb τ)

◇□-pair' : ⟨ ⟨ e₁ ⟩ (□ A₁) ⊙ □ (⟨ e₂ ⟩ (□ A₂)) ⟩→̇ ⟨ e₁ + e₂ ⟩ (□ (A₁ ×̂ A₂))
◇□-pair' ca cb = join (◇-map! (λ τ a → ◇-map! (λ τ₁ b {_} τ₂ → a (⊆-trans τ₁ τ₂) , b τ₂) (cb τ)) ca)
  -- Without the abstraction over {_}, there is an incomprehensible error.

◇□-pair : ⟨ □ (⟨ e₁ ⟩ (□ A₁)) ⊙ ⟨ e₂ ⟩ (□ A₂) ⟩→̇ ⟨ e₂ + e₁ ⟩ (□ (A₁ ×̂ A₂))
◇□-pair ca cb = join (◇-map! (λ τ b → ◇-map! (λ τ₁ a {_} τ₂ → a τ₂ , b (⊆-trans τ₁ τ₂)) (ca τ)) cb)
  -- Without the abstraction over {_}, there is an incomprehensible error.

-- Runnability

Run : (B : NSet) → Set
Run B = ∀{e₁ e₂} → ⟨ e₁ ⟩ (B e₂) →̇ B (e₁ + e₂)

-- Negative ISets are runnable

◇-run : Run (◇ A)
◇-run = join

Π-run : (∀ i → Run (Bs i)) → Run (Πⁿ I Bs)
Π-run f c i = f i (◇-map (_$ i) c)
-- Π-run f x i = Π-map {!λ j → f j!} {!!} {!!}
-- Π-run f = {!Π-map f!} ∘ ◇-record

⇒-run : Mon A → Run B → Run (A ⇒ⁿ B)
⇒-run {B = B} mA rB f = rB ∘ ◇-fun {B = B} mA f

-- Bind for the ◇ monad

◇-elim : Run B → (A →̇ B e₂) → ⟨ e₁ ⟩ A →̇ B (e₁ + e₂)
◇-elim rB f = rB ∘ ◇-map f

◇-elim! : Run B → ⟨ □ (A ⇒̂ B e₂) ⊙ ⟨ e₁ ⟩ A ⟩→̇ B (e₁ + e₂)
◇-elim! rB f = rB ∘ ◇-map! f

◇-elim-□ : Run B → ⟨ □ (A ⇒̂ B e₂) ⊙ □ (⟨ e₁ ⟩ A) ⟩→̇ □ (B (e₁ + e₂))
◇-elim-□ {B = B} rB f c = □-map (uncurry (◇-elim! {B = B} rB)) (□-pair (□-mon f) c)

◇-elim-□-alt : Run B → ⟨ □ (A ⇒̂ B e₂) ⊙ □ (⟨ e₁ ⟩ A) ⟩→̇ □ (B (e₁ + e₂))
◇-elim-□-alt {B = B} rB f c τ = ◇-elim! {B = B} rB (□-mon f τ) (c τ)

bind! : Mon C → Run B → (C →̇ ⟨ e₁ ⟩ A) → (C →̇ (A ⇒̂ B e₂)) → C →̇ B (e₁ + e₂)
bind! {B = B} mC rB f k γ = ◇-elim! {B = B} rB (λ τ a → k (mC γ τ) a) (f γ)

-- Type interpretation
------------------------------------------------------------------------

mutual
  ⟦_⟧⁺ : Ty⁺ → PSet
  ⟦ base o  ⟧⁺ = base o ∈_
  ⟦ P₁ ×̇ P₂ ⟧⁺ = ⟦ P₁ ⟧⁺ ×̂ ⟦ P₂ ⟧⁺
  ⟦ Σ̇ I P   ⟧⁺ = Σ̂ I λ i → ⟦ P i ⟧⁺
  ⟦ [ e ] N ⟧⁺ = □ (⟦ N ⟧⁻ e)

  ⟦_⟧⁻ : Ty⁻ → NSet
  ⟦ ◇̇ P   ⟧⁻ = ◇ ⟦ P ⟧⁺
  ⟦ Π̇ I N ⟧⁻ = Πⁿ I λ i → ⟦ N i ⟧⁻
  ⟦ P ⇒̇ N ⟧⁻ = ⟦ P ⟧⁺ ⇒ⁿ ⟦ N ⟧⁻

⟦_⟧ᶜ : Cxt → PSet
⟦_⟧ᶜ Γ Δ = All (λ P → ⟦ P ⟧⁺ Δ) Γ

-- ⟦ []    ⟧ᶜ = 1̂
-- ⟦ P ∷ Γ ⟧ᶜ = ⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺

-- Positive types are monotone.

mon⁺ : (P : Ty⁺) → Mon ⟦ P ⟧⁺
mon⁺ (base o)  = monVar
mon⁺ (P₁ ×̇ P₂) = ×-mon (mon⁺ P₁) (mon⁺ P₂)
mon⁺ (Σ̇ I P)   = Σ-mon (mon⁺ ∘ P)
mon⁺ ([ e ] N) = □-mon

monᶜ : (Γ : Cxt) → Mon ⟦ Γ ⟧ᶜ
monᶜ Γ γ τ = All.map (λ {P} v → mon⁺ P v τ) γ

-- Negative types are runnable.

run⁻ : (N : Ty⁻) → Run ⟦ N ⟧⁻
run⁻ (◇̇ P)   = ◇-run
run⁻ (Π̇ I N) = Π-run (run⁻ ∘ N)
run⁻ (P ⇒̇ N) = ⇒-run {B = ⟦ N ⟧⁻} (mon⁺ P) (run⁻ N)

-- monᶜ []      = 1-mon
-- monᶜ (P ∷ Γ) = ×-mon (monᶜ Γ) (mon⁺ P)

-- Interpretation
------------------------------------------------------------------------

mutual

  ⦅_⦆⁺ : Val P Γ → ⟦ Γ ⟧ᶜ →̇ ⟦ P ⟧⁺
  ⦅ var x ⦆⁺      = λ γ → All.lookup γ x
  ⦅ pair v₁ v₂ ⦆⁺ = < ⦅ v₁ ⦆⁺ , ⦅ v₂ ⦆⁺ >
  ⦅ inj i v ⦆⁺    = (i ,_) ∘ ⦅ v ⦆⁺
  ⦅ thunk t ⦆⁺    = □-intro (monᶜ _) ⦅ t ⦆⁻

  λ⦅_⦆⁻ : Comp e N (P ∷ Γ) → ⟦ Γ ⟧ᶜ →̇ ⟦ P ⇒̇ N ⟧⁻ e
  λ⦅ t ⦆⁻ γ a = ⦅ t ⦆⁻ (a ∷ γ)

  ⦅_⦆⁻ : Comp e N Γ → ⟦ Γ ⟧ᶜ →̇ ⟦ N ⟧⁻ e
  ⦅ ret v ⦆⁻ = return ∘ ⦅ v ⦆⁺
  ⦅ rec t ⦆⁻ = flip λ i → {! ⦅ t i ⦆⁻ !}  -- need effect subsumption es i ≤ sup es
  ⦅ abs t ⦆⁻ = λ⦅ t ⦆⁻
  ⦅ split v t ⦆⁻ γ = let (a₁ , a₂) = ⦅ v ⦆⁺ γ in ⦅ t ⦆⁻ (a₂ ∷ (a₁ ∷ γ))
  ⦅ case v t ⦆⁻  γ = let (i , a) = ⦅ v ⦆⁺ γ in  {! ⦅ t i ⦆⁻ (a ∷ γ) !}  -- eff sub
  ⦅ bind {Γ = Γ} {N = N} t t₁ ⦆⁻ = bind! {B = ⟦ N ⟧⁻} (monᶜ Γ) (run⁻ N) ⦅ t ⦆⁻ λ⦅ t₁ ⦆⁻
  ⦅ force v ⦆⁻  = extract ∘ ⦅ v ⦆⁺
  ⦅ prj i t ⦆⁻  = (_$ i) ∘ ⦅ t ⦆⁻
  ⦅ app t v ⦆⁻  = ⦅ t ⦆⁻  ˢ ⦅ v ⦆⁺
  ⦅ letv v t ⦆⁻ = λ⦅ t ⦆⁻ ˢ ⦅ v ⦆⁺

-- Reflection and reification

mutual

  fresh□◇□ : ∀ P {Γ} → ⟪ P ⟫ (□ (⟨ ∅ ⟩ (□ ⟦ P ⟧⁺))) Γ
  fresh□◇□ P = reflect⁺□ P ∘ monVar here!

  fresh□ : ∀ P {Γ} → ⟪ P ⟫ (□ (⟨ ∅ ⟩ ⟦ P ⟧⁺)) Γ
  fresh□ P = ◇-map extract ∘ reflect⁺□ P ∘ monVar here!
  fresh□ P = reflect⁺ P ∘ monVar here!

  fresh : ∀ {P Γ} → ⟪ P ⟫ (⟨ ∅ ⟩ ⟦ P ⟧⁺) Γ
  fresh {P} = ◇-map extract (reflect⁺□ P here!)
  fresh {P} = reflect⁺ P here!

  fresh◇ : ∀ {P Γ} → ⟪ P ⟫ (⟨ ∅ ⟩ (□ ⟦ P ⟧⁺)) Γ
  fresh◇ {P} = reflect⁺□ P here!
  fresh◇ {P} = ◇-map (mon⁺ P) fresh

  -- saves us use of Mon P in freshᶜ
  reflect⁺□ : (P : Ty⁺) → (P ∈_) →̇ (⟨ ∅ ⟩ (□ ⟦ P ⟧⁺))
  reflect⁺□ (base o)  x = return (monVar x)
  reflect⁺□ (P₁ ×̇ P₂) x = split x (◇□-pair (reflect⁺□ P₁ ∘ monVar (there here!)) fresh◇)
  reflect⁺□ (Σ̇ I Ps)  x = case x λ i → ◇-map (□-map (i ,_)) fresh◇
  reflect⁺□ ([ e ] N) x = return (□-mon (reflect⁻ N ∘ force ∘ monVar x))

  reflect⁺ : (P : Ty⁺) → (P ∈_) →̇ (⟨ ∅ ⟩ ⟦ P ⟧⁺)
  reflect⁺ (base o)  x = return x
  reflect⁺ (P₁ ×̇ P₂) x = split x (□-weak (fresh□ P₁) ⋉ fresh◇)
  reflect⁺ (Σ̇ I Ps)  x = case x λ i → ◇-map (i ,_) fresh
  reflect⁺ ([ e ] N) x = return λ τ → reflect⁻ N (force (monVar x τ))

  reflect⁻ : (N : Ty⁻) → Ne e N →̇ ⟦ N ⟧⁻ e
  reflect⁻ (◇̇ P)    u = bind u fresh
  reflect⁻ (Π̇ I Ns) u = λ i → reflect⁻ (Ns i) (prj i u)
  reflect⁻ (P ⇒̇ N)  u = λ a → reflect⁻ N (app u (reify⁺ P a))

  reify⁺ : (P : Ty⁺) → ⟦ P ⟧⁺ →̇ NVal P
  reify⁺ (base o) = var
  reify⁺ (P₁ ×̇ P₂) (a₁ , a₂) = pair (reify⁺ P₁ a₁) (reify⁺ P₂ a₂)
  reify⁺ (Σ̇ I Ps)  (i  , a ) = inj i (reify⁺ (Ps i) a)
  reify⁺ ([ e ] N) a = thunk (reify⁻ N a)

  reify⁻ : (N : Ty⁻) → □ (⟦ N ⟧⁻ e) →̇ Nf e N
  reify⁻         (◇̇ P)    f = ret (◇-map (reify⁺ P) (extract f))
  reify⁻ {e = e} (Π̇ I Ns) f = rec {es = λ i → e} λ i → reify⁻ (Ns i) (□-map (_$ i) f)
  reify⁻         (P ⇒̇ N)  f = abs $ reify⁻ N $ ◇-elim-□ {B = ⟦ N ⟧⁻} (run⁻ N) (□-weak f) $ fresh□ P

ext : (⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺) →̇ ⟦ P ∷ Γ ⟧ᶜ
ext (γ , a) = a ∷ γ

◇-ext : ⟨ e ⟩ (⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺) →̇ ⟨ e ⟩ ⟦ P ∷ Γ ⟧ᶜ
◇-ext = ◇-map ext

-- Without the use of ◇-mon!

freshᶜ : (Γ : Cxt) → □ (⟨ ∅ ⟩ ⟦ Γ ⟧ᶜ) Γ
freshᶜ []      = λ τ → return []
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair' (□-weak (freshᶜ Γ)) (fresh□◇□ P)
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair (mon⁺ P) (□-weak (freshᶜ Γ)) (fresh□ P)
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair' (□-weak (freshᶜ Γ)) (◇-map (mon⁺ P) ∘ (fresh□ P))
freshᶜ (P ∷ Γ) = ◇-ext ∘ λ τ →
  (□-weak (□-mon (freshᶜ Γ)) τ)
  ⋉ ◇-map (mon⁺ P) (fresh□ P τ)

norm : Comp e N →̇ Nf e N
norm {N = N} {Γ = Γ} t = reify⁻ N $ □-map (run⁻ N ∘ ◇-map ⦅ t ⦆⁻) $ freshᶜ Γ
norm {N = N} {Γ = Γ} t = reify⁻ N $ run⁻ N ∘ ◇-map ⦅ t ⦆⁻ ∘ freshᶜ Γ

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


open import FRP.JS.Nat using ( ℕ ; suc ; _+_ )
open import FRP.JS.DOM
open import FRP.JS.RSet
open import FRP.JS.Time using ( Time ; epoch )
open import FRP.JS.Delay using ( _ms )
open import FRP.JS.Behaviour
open import FRP.JS.Bool using ( Bool ; not ; true )
open import FRP.JS.QUnit using ( TestSuite ; ok◇ ; test ; _,_ ; ε )

module FRP.JS.Test.DOM where

withDOW : {A : Set} → ((w : DOW) → A) → A
withDOW f = f unattached

tests : TestSuite
tests =
  ( test "≟*"
    ( ok◇ "[] ≟* []"
      (withDOW λ w → [] {w} ≟* [])
    , ok◇ "[] ++ [] ≟* []"
      (withDOW λ w → [] {left w} ++ [] ≟* []) )
  , test "attr"
    ( ok◇ "attr class [ alpha ] ≟* attr class [ alpha ]"
      (withDOW λ w → attr {w} "class" [ "alpha" ] ≟* attr "class" [ "alpha" ])
    , ok◇ "attr foo [ alpha ] ≟* attr foo [ alpha ]"
      (withDOW λ w → attr {w} "foo" [ "alpha" ] ≟* attr "foo" [ "alpha" ])
    , ok◇ "attr foo [ alpha ] ++ attr bar [ alpha ] ≟* attr foo [ alpha ] ++ attr bar [ alpha ]"
      (withDOW λ w → attr {left w} "foo" [ "alpha" ] ++ attr "bar" [ "alpha" ] ≟* attr "foo" [ "alpha" ] ++ attr "bar" [ "alpha" ])
    , ok◇ "attr class [ beta ] ≟* attr class [ alpha ]"
      (withDOW λ w → not* (attr {w} "class" [ "beta" ] ≟* attr "class" [ "alpha" ]))
    , ok◇ "attr foo [ alpha ] ≟* attr class [ alpha ]"
      (withDOW λ w → not* (attr {w} "foo" [ "alpha" ] ≟* attr "class" [ "alpha" ]))
    , ok◇ "attr foo [ alpha ] ++ attr bar [ alpha ] ≟* attr foo [ alpha ]"
      (withDOW λ w → not* (attr {left w} "foo" [ "alpha" ] ++ attr "bar" [ "alpha" ] ≟* attr "foo" [ "alpha" ])) )
  , test "text"
    ( ok◇ "text [ abc ] ≟* text [ abc ]"
      (withDOW λ w → text {w} [ "abc" ] ≟* text [ "abc" ])
    , ok◇ "text [ a ] ≟* text [ abc ]"
      (withDOW λ w → not* (text {w} [ "a" ] ≟* text [ "abc" ]))
    , ok◇ "[] ≟* text [ abc ]"
      (withDOW λ w → not* ([] ≟* text {w} [ "abc" ]))
    , ok◇ "text [ abc ] ++ [] ≟* text [ abc ]"
      (withDOW λ w → text {left w} [ "abc" ] ++ [] ≟* (text [ "abc" ]))
    , ok◇ "[] ++ text [ abc ] ≟* text [ abc ]"
      (withDOW λ w → [] ++ text {right w} [ "abc" ] ≟* (text [ "abc" ])) )
  , test "element"
    ( ok◇ "element p (text [ abc ]) ≟* element p (text [ abc ])"
      (withDOW λ w → element "p" {w} (text [ "abc" ]) ≟* element "p" (text [ "abc" ]))
    , ok◇ "element p (text [ a ]) ≟* element p (text [ abc ])"
      (withDOW λ w → not* (element "p" {w} (text [ "a" ]) ≟* element "p" (text [ "abc" ])))
    , ok◇ "element div (attr class [ alpha ] ++ text [ abc ]) ≟* element div (attr class [ alpha ] ++ text [ abc ])"
      (withDOW λ w → element "div" {w} (attr "class" [ "alpha" ] ++ text [ "abc" ]) ≟* element "div" {w} (attr "class" [ "alpha" ] ++ text [ "abc" ]))
    , ok◇ "element div (attr class [ beta ] ++ text [ abc ]) ≟* element div (attr class [ alpha ] ++ text [ abc ])"
      (withDOW λ w → not* (element "div" {w} (attr "class" [ "beta" ] ++ text [ "abc" ]) ≟* element "div" {w} (attr "class" [ "alpha" ] ++ text [ "abc" ])))
    , ok◇ "element p (text [ abc ]) ≟* element p (text [ abc ])"
      (withDOW λ w → element "p" {w} (text [ "abc" ]) ≟* element "p" (text [ "abc" ]))
    , ok◇ "element p (text [ a ]) ++ element p (text [ b ]) ≟* element p (text [ a ])"
      (withDOW λ w → not* (element "p" {left w} (text [ "a" ]) ++ element "p" (text [ "b" ]) ≟* element "p" (text [ "a" ])))
      )
  , test "join"
    ( ok◇ "text (join (map [ x ] [ abc ])) ≟* text [ abc ]"
      (withDOW λ w → text {w} (join (map (λ s → [ s ]) [ "abc" ])) ≟* text [ "abc" ])
    , ok◇ "join (map (text [ x ]) [ abc ]) ≟* text [ abc ]"
      (withDOW λ w → join (map (λ s → text {w} [ s ]) [ "abc" ]) ≟* text [ "abc" ])
   , ok◇ "element p (join (map (attr foo [ x ]) [ alpha ]) ++ join (map (attr bar [ x ]) [ alpha ])) ≟* element p (attr foo [ alpha ] ++ attr bar [ alpha ])"
      (withDOW λ w → element "p" {w} (join (map (λ s → attr "foo" [ s ]) [ "alpha" ]) ++ join (map (λ s → attr "bar" [ s ]) [ "alpha" ])) ≟* element "p" (attr "foo" [ "alpha" ] ++ attr "bar" [ "alpha" ]))
   , ok◇ "element p (join (map (attr foo [ x ]) [ beta ]) ++ join (map (attr bar [ x ]) [ alpha ])) ≟* element p (attr foo [ alpha ] ++ attr bar [ alpha ])"
      (withDOW λ w → not* (element "p" {w} (join (map (λ s → attr "foo" [ s ]) [ "beta" ]) ++ join (map (λ s → attr "bar" [ s ]) [ "alpha" ])) ≟* element "p" (attr "foo" [ "alpha" ] ++ attr "bar" [ "alpha" ])))
    , ok◇ "text (join (map [ x ] [ a ])) ≟* text [ abc ]"
      (withDOW λ w → not* (text {w} (join (map (λ s → [ s ]) [ "a" ])) ≟* text [ "abc" ]))
    , ok◇ "join (map (text [ x ]) [ a ]) ≟* text [ abc ]"
      (withDOW λ w → not* (join (map (λ s → text {w} [ s ]) [ "a" ]) ≟* text [ "abc" ])) ) )


{-# OPTIONS --warning=error #-}

A : Set₁
A = Set

{-# POLARITY A #-}


-- Andreas, 2015-07-13  Better parse errors for illegal type signatures

A rewrite B : Set


module Duploid where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; cong)
open Eq.≡-Reasoning

open import Level

open import Preduploid

private
  variable p q r s : Polarity

record Duploid o ℓ : Set (suc (o ⊔ ℓ)) where
  field
    𝒟 : Preduploid o ℓ

  open Preduploid.Preduploid 𝒟 public

  field
    ⇓ : Ob ⊝ -> Ob +
    ⇑ : Ob + -> Ob ⊝

    delay : forall {P : Ob +} -> P ⇒ ⇑ P
    force : forall {P : Ob +} -> ⇑ P ⇒ P

    wrap : forall {N : Ob ⊝} -> N ⇒ ⇓ N
    unwrap : forall {N : Ob ⊝} -> ⇓ N ⇒ N

    force∘delay∙ : forall {A : Ob p} {P : Ob +} {f : A ⇒ P} -> force ∘ (delay ∙ f) ≡ f
    ∘unwrap∙wrap : forall {N : Ob ⊝} {A : Ob p} {f : N ⇒ A} -> (f ∘ unwrap) ∙ wrap ≡ f
    delay∙force : forall {P : Ob +} -> delay ∙ force ≡ id {A = ⇑ P}
    wrap∘unwrap : forall {N : Ob ⊝} -> wrap ∘ unwrap ≡ id {A = ⇓ N}

  ∙force∘delay : forall {P : Ob +} {A : Ob p} {g : P ⇒ A} -> (g ∙ force) ∘ delay ≡ g
  ∙force∘delay {g = g} =
    begin
      (g ∙ force) ∘ delay
    ≡⟨ assoc∙∘ ⟩
      g ∙ (force ∘ delay)
    ≡˘⟨ cong (g ∙_) (cong (force ∘_) identity∙ʳ) ⟩
      g ∙ (force ∘ (delay ∙ id))
    ≡⟨ cong (g ∙_) force∘delay∙ ⟩
      g ∙ id
    ≡⟨ identity∙ʳ ⟩
     g
    ∎

  unwrap∙wrap∘ : forall {A : Ob p} {N : Ob ⊝} {g : A ⇒ N} -> unwrap ∙ (wrap ∘ g) ≡ g
  unwrap∙wrap∘ {g = g} =
    begin
      unwrap ∙ (wrap ∘ g)
    ≡˘⟨ assoc∙∘ ⟩
      (unwrap ∙ wrap) ∘ g
    ≡˘⟨ cong (_∘ g) (cong (_∙ wrap) identity∘ˡ) ⟩
      ((id ∘ unwrap) ∙ wrap) ∘ g
    ≡⟨ cong (_∘ g) ∘unwrap∙wrap ⟩
      id ∘ g
    ≡⟨ identity∘ˡ ⟩
      g
    ∎

  wrap-Thunkable : forall {N : Ob ⊝} -> Thunkable (wrap {N = N})
  wrap-Thunkable {r = +} = sym assoc∙∙
  wrap-Thunkable {r = ⊝} {g = g} {h = h} =
    begin
      h ∘ (g ∙ wrap)
    ≡˘⟨ ∘unwrap∙wrap ⟩
      ((h ∘ (g ∙ wrap)) ∘ unwrap) ∙ wrap
    ≡⟨ cong (_∙ wrap) assoc∘∘ ⟩
      (h ∘ ((g ∙ wrap) ∘ unwrap)) ∙ wrap
    ≡⟨ cong (_∙ wrap) (cong (h ∘_) assoc∙∘) ⟩
      (h ∘ (g ∙ (wrap ∘ unwrap))) ∙ wrap
    ≡⟨ cong (_∙ wrap) (cong (h ∘_) (cong (g ∙_) wrap∘unwrap)) ⟩
      (h ∘ (g ∙ id)) ∙ wrap
    ≡⟨ cong (_∙ wrap) (cong (h ∘_) identity∙ʳ) ⟩
      (h ∘ g) ∙ wrap
    ∎

  force-Linear : forall {P : Ob +} -> Linear (force {P = P})
  force-Linear {q = +} {g = g} {h = h} = sym (
    begin
      (force ∘ g) ∙ h
    ≡˘⟨ force∘delay∙ ⟩
      force ∘ (delay ∙ ((force ∘ g) ∙ h))
    ≡˘⟨ cong (force ∘_) assoc∙∙ ⟩
      force ∘ ((delay ∙ (force ∘ g)) ∙ h)
    ≡˘⟨ cong (force ∘_) (cong (_∙ h) assoc∙∘) ⟩
      force ∘ (((delay ∙ force) ∘ g) ∙ h)
    ≡⟨ cong (force ∘_) (cong (_∙ h) (cong (_∘ g) delay∙force)) ⟩
      force ∘ ((id ∘ g) ∙ h)
    ≡⟨ cong (force ∘_) (cong (_∙ h) identity∘ˡ) ⟩
      force ∘ (g ∙ h)
    ∎)
  force-Linear {q = ⊝} = sym assoc∘∘

  helper1 : forall {A : Ob p} {P : Ob +} {f : A ⇒ P}
    -> (wrap ∘ delay) ∙ f ≡ wrap ∘ (delay ∙ f)
    -> forall {B : Ob q} {h : ⇑ P ⇒ B} -> (h ∘ delay) ∙ f ≡ h ∘ (delay ∙ f)
  helper1 {f = f} e {h = h} =
    begin
      (h ∘ delay) ∙ f
    ≡˘⟨ cong (_∙ f) (cong (_∘ delay) ∘unwrap∙wrap) ⟩
      (((h ∘ unwrap) ∙ wrap) ∘ delay) ∙ f
    ≡⟨ cong (_∙ f) assoc∙∘ ⟩
      ((h ∘ unwrap) ∙ (wrap ∘ delay)) ∙ f
    ≡⟨ assoc∙∙ ⟩
      (h ∘ unwrap) ∙ ((wrap ∘ delay) ∙ f)
    ≡⟨ cong ((h ∘ unwrap) ∙_) e ⟩
      (h ∘ unwrap) ∙ (wrap ∘ (delay ∙ f))
    ≡˘⟨ assoc∙∘ ⟩
      ((h ∘ unwrap) ∙ wrap) ∘ (delay ∙ f)
    ≡⟨ cong (_∘ _) ∘unwrap∙wrap ⟩
      h ∘ (delay ∙ f)
    ∎

  assoc-wrap∘delay∙→Thunkable : forall {A : Ob p} {P : Ob +} {f : A ⇒ P}
    -> (wrap ∘ delay) ∙ f ≡ wrap ∘ (delay ∙ f)
    -> Thunkable f
  assoc-wrap∘delay∙→Thunkable e {r = +} = sym assoc∙∙
  assoc-wrap∘delay∙→Thunkable {f = f} e {r = ⊝} {g = g} {h = h} =
    begin
      h ∘ (g ∙ f)
    ≡˘⟨ cong (h ∘_) (cong (_∙ f) ∙force∘delay) ⟩
      h ∘ (((g ∙ force) ∘ delay) ∙ f)
    ≡⟨ cong (h ∘_) (helper1 e) ⟩
      h ∘ ((g ∙ force) ∘ (delay ∙ f))
    ≡˘⟨ assoc∘∘ ⟩
      (h ∘ (g ∙ force)) ∘ (delay ∙ f)
    ≡˘⟨ helper1 e ⟩
      ((h ∘ (g ∙ force)) ∘ delay) ∙ f
    ≡⟨ cong (_∙ f) assoc∘∘ ⟩
      (h ∘ ((g ∙ force) ∘ delay)) ∙ f
    ≡⟨ cong (_∙ f) (cong (h ∘_) ∙force∘delay) ⟩
      (h ∘ g) ∙ f
    ∎

  helper2 : forall {N : Ob ⊝} {A : Ob p} {f : N ⇒ A}
    -> f ∘ (unwrap ∙ force) ≡ (f ∘ unwrap) ∙ force
    -> forall {B : Ob q} {h : B ⇒ ⇓ N} -> f ∘ (unwrap ∙ h) ≡ (f ∘ unwrap) ∙ h
  helper2 {f = f} e {h = h} =
    begin
      f ∘ (unwrap ∙ h)
    ≡˘⟨ cong (f ∘_) (cong (unwrap ∙_) force∘delay∙) ⟩
      f ∘ (unwrap ∙ (force ∘ (delay ∙ h)))
    ≡˘⟨ cong (f ∘_) assoc∙∘ ⟩
      f ∘ ((unwrap ∙ force) ∘ (delay ∙ h))
    ≡˘⟨ assoc∘∘ ⟩
      (f ∘ (unwrap ∙ force)) ∘ (delay ∙ h)
    ≡⟨ cong (_∘ (delay ∙ h)) e ⟩
      ((f ∘ unwrap) ∙ force) ∘ (delay ∙ h)
    ≡⟨ assoc∙∘ ⟩
      (f ∘ unwrap) ∙ (force ∘ (delay ∙ h))
    ≡⟨ cong ((f ∘ unwrap) ∙_) force∘delay∙ ⟩
      (f ∘ unwrap) ∙ h
    ∎

  assoc-∘unwrap∙force→Linear : forall {N : Ob ⊝} {A : Ob p} {f : N ⇒ A}
    -> f ∘ (unwrap ∙ force) ≡ (f ∘ unwrap) ∙ force
    -> Linear f
  assoc-∘unwrap∙force→Linear {f = f} e {q = +} {g = g} {h = h} =
    begin
      f ∘ (g ∙ h)
    ≡˘⟨ cong (f ∘_) (cong (_∙ h) unwrap∙wrap∘) ⟩
      f ∘ ((unwrap ∙ (wrap ∘ g)) ∙ h)
    ≡⟨ cong (f ∘_) assoc∙∙ ⟩
      f ∘ (unwrap ∙ ((wrap ∘ g) ∙ h))
    ≡⟨ helper2 e ⟩
      (f ∘ unwrap) ∙ ((wrap ∘ g) ∙ h)
    ≡˘⟨ assoc∙∙ ⟩
      ((f ∘ unwrap) ∙ (wrap ∘ g)) ∙ h
    ≡˘⟨ cong (_∙ h) assoc∙∘ ⟩
      (((f ∘ unwrap) ∙ wrap) ∘ g) ∙ h
    ≡⟨ cong (_∙ h) (cong (_∘ g) ∘unwrap∙wrap) ⟩
      (f ∘ g) ∙ h
    ∎
  assoc-∘unwrap∙force→Linear e {q = ⊝} = sym assoc∘∘


-- Interacting with the real world ---Compilation, Haskell, and IO
-- :PROPERTIES:
-- :header-args: :tangle "CompilingAgda.agda" :comments org
-- :CUSTOM_ID: agda-interacting-with-the-real-world
-- :END:

-- # C-c C-v C-t tangles the following code into CompilingAgda.agda.
-- # Then we may compile the result using:
-- # (shell-command "NAME=CompilingAgda; time agda --compile $NAME.agda; ./$NAME")
-- #
-- # Btw: (find-file "./MAlonzo/Code/CompilingAgda.hs")

-- #+latex: {\color{white}.} \vspace{-1em}
-- #+begin_quote org
-- /Let's demonstrate how we can reach into Haskell, thereby subverting Agda!/
-- #+end_quote

-- An Agda program module containing a ~main~ function is compiled into a standalone executable
-- with ~agda --compile myfile.agda~. If the module has no main file, use the flag ~--no-main~.
-- If you only want the resulting Haskell, not necessarily an executable program, then use the flag
-- ~--ghc-dont-call-ghc~.

-- The type of ~main~ should be ~Agda.Builtin.IO.IO A~, for some ~A~;
-- this is just a proxy to Haskell's ~IO~.
-- We may ~open import IO.Primitive~ to get /this/ ~IO~, but
-- this one works with costrings, which are a bit awkward.
-- Instead, we use the standard library's wrapper type, also named ~IO~.
-- Then we use ~run~ to move from ~IO~ to ~Primitive.IO~; conversely one uses ~lift~.

-- #+latex: \begin{minipage}[c]{0.55\linewidth}
-- #+latex: \begin{tiny}

open import Data.Nat                 using (ℕ; suc)
open import Data.Nat.Show            using (show)
open import Data.Char                using (Char)
open import Data.List as L           using (map; sum; upTo)
open import Function                 using (_$_; const; _∘_)
open import Data.String as S         using (String; _++_; fromList)
open import Agda.Builtin.Unit        using (⊤)
open import Codata.Musical.Colist    using (take)
open import Codata.Musical.Costring  using (Costring)
open import Data.BoundedVec.Inefficient as B using (toList)
open import Agda.Builtin.Coinduction using (♯_)
open import IO as IO                 using (run ; putStrLn ; IO)
import IO.Primitive as Primitive

-- #+latex: \end{tiny}
-- #+latex: \end{minipage} % no space if you would like to put them side by side
-- #+latex: \begin{minipage}[c]{0.5\linewidth}
-- #+begin_quote org
-- /Agda has *no* primitives for side-effects, instead it allows arbitrary/
-- /Haskell functions to be imported as axioms, whose definitions are only/
-- /used at run-time./
-- #+end_quote
-- #+latex: \end{minipage}

-- Agda lets us use “do”-notation as in Haskell.
-- To do so, methods named ~_>>_~ and ~_>>=_~ need to be in scope ---that is all.
-- The type of ~IO._>>_~ takes two “lazy” IO actions and yield a non-lazy IO action.
-- The one below is a homogeneously typed version.

infixr 1 _>>=_ _>>_

_>>=_ : ∀ {ℓ} {α β : Set ℓ} → IO α → (α → IO β) → IO β
this >>= f = ♯ this IO.>>= λ x → ♯ f x

_>>_ : ∀{ℓ} {α β : Set ℓ} → IO α → IO β → IO β
x >> y = x >>= const y

-- Oddly, Agda's standard library comes with ~readFile~ and
-- ~writeFile~, but the symmetry ends there since it provides ~putStrLn~
-- but not [[https://hackage.haskell.org/package/base-4.12.0.0/docs/Prelude.html#v:getLine][~getLine~]]. Mimicking the ~IO.Primitive~ module, we define /two/
-- versions ourselves as proxies for Haskell's ~getLine~ ---the second one
-- below is bounded by 100 characters, whereas the first is not.

postulate
  getLine∞ : Primitive.IO Costring

{-# FOREIGN GHC
  toColist :: [a] -> MAlonzo.Code.Codata.Musical.Colist.AgdaColist a
  toColist []       = MAlonzo.Code.Codata.Musical.Colist.Nil
  toColist (x : xs) =
    MAlonzo.Code.Codata.Musical.Colist.Cons x (MAlonzo.RTE.Sharp (toColist xs))
#-}

{- Haskell's prelude is implicitly available; this is for demonstration. -}
{-# FOREIGN GHC import Prelude as Haskell #-}
{-# COMPILE GHC getLine∞  = fmap toColist Haskell.getLine #-}

-- (1)
-- getLine : IO Costring
-- getLine = IO.lift getLine∞

getLine : IO String
getLine = IO.lift
  $ getLine∞ Primitive.>>= (Primitive.return ∘ S.fromList ∘ B.toList ∘ take 100)

-- We obtain ~MAlonzo~ strings, then convert those to colists, then
-- eventually lift those to the wrapper ~IO~ type.

-- Let's also give ourselves Haskell's ~read~ method.

postulate readInt  : L.List Char → ℕ
{-# COMPILE GHC readInt = \x -> read x :: Integer  #-}

-- Now we write our ~main~ method.

main : Primitive.IO ⊤
main = run do putStrLn "Hello, world! I'm a compiled Agda program!"

              putStrLn "What is your name?"
              name ← getLine

              putStrLn "Please enter a number."
              num ← getLine
              let tri = show $ sum $ upTo $ suc $ readInt $ S.toList num
              putStrLn $ "The triangle number of " ++ num ++ " is " ++ tri

              putStrLn "Bye, "
              -- IO.putStrLn∞ name  {- If we use approach (1) above. -}
              putStrLn $ "\t" ++ name


{-# OPTIONS --allow-unsolved-metas #-}
module Semantics.Bind where

open import Syntax.Types
open import Syntax.Context renaming (_,_ to _,,_)
open import Syntax.Terms
open import Syntax.Substitution.Kits
open import Syntax.Substitution.Instances
open import Syntax.Substitution.Lemmas

open import Semantics.Types
open import Semantics.Terms
open import Semantics.Context
open import Semantics.Substitution.Kits
open import Semantics.Substitution.Traversal
open import Semantics.Substitution.Instances

open import CategoryTheory.Categories using (Category ; ext)
open import CategoryTheory.Functor
open import CategoryTheory.NatTrans
open import CategoryTheory.Monad
open import CategoryTheory.Comonad
open import CategoryTheory.CartesianStrength
open import CategoryTheory.Instances.Reactive renaming (top to ⊤)
open import TemporalOps.Diamond
open import TemporalOps.Delay
open import TemporalOps.Box
open import TemporalOps.OtherOps
open import TemporalOps.StrongMonad

open import Data.Sum
open import Data.Product using (_,_)
open import Relation.Binary.PropositionalEquality as ≡
    using (_≡_ ; refl ; sym ; trans ; cong ; cong₂ ; subst)

open ≡.≡-Reasoning
open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open Comonad W-□
open Monad M-◇
private module F-◇ = Functor F-◇
private module F-□ = Functor F-□
open Functor F-□ renaming (fmap to □-f)
open Functor F-◇ renaming (fmap to ◇-f)
private module ▹ᵏ-C k = CartesianFunctor (F-cart-delay k)
private module ▹ᵏ-F k = Functor (F-delay k)
private module □-▹ᵏ k = _⟹_ (□-to-▹ᵏ k)

bind-to->>= : ∀ Γ {⟦A⟧ ⟦B⟧} -> (⟦E⟧ : ⟦ Γ ⟧ₓ ⇴ ◇ ⟦A⟧) (⟦C⟧ : ⟦ Γ ˢ ⟧ₓ ⊗ ⟦A⟧ ⇴ ◇ ⟦B⟧)
        -> (n : ℕ) (⟦Γ⟧ : ⟦ Γ ⟧ₓ n)
        -> bindEvent Γ ⟦E⟧ ⟦C⟧ n ⟦Γ⟧
        ≡ (⟦E⟧ n ⟦Γ⟧ >>= λ l ⟦A⟧ → ⟦C⟧ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
bind-to->>= Γ {⟦A⟧} {⟦B⟧} ⟦E⟧ ⟦C⟧ n ⟦Γ⟧ =
    begin
        bindEvent Γ ⟦E⟧ ⟦C⟧ n ⟦Γ⟧
    ≡⟨⟩
        μ.at ⟦B⟧ n (F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n (st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ n (⟦ Γ ˢ⟧□ n ⟦Γ⟧ , ⟦E⟧ n ⟦Γ⟧)))
    ≡⟨ cong (μ.at ⟦B⟧ n) (lemma (⟦E⟧ n ⟦Γ⟧)) ⟩
        μ.at ⟦B⟧ n (F-◇.fmap (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n (⟦E⟧ n ⟦Γ⟧))
    ≡⟨⟩
        (⟦E⟧ n ⟦Γ⟧ >>= (λ l ⟦A⟧ → ⟦C⟧ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧)))
    ∎
    where
    lemma : ∀ ◇⟦A⟧
         -> F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n (st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ n (⟦ Γ ˢ⟧□ n ⟦Γ⟧ , ◇⟦A⟧))
          ≡ F-◇.fmap (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n ◇⟦A⟧
    lemma (k , a) =
        begin
            F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n (st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ n (⟦ Γ ˢ⟧□ n ⟦Γ⟧ , (k , a)))
        ≡⟨⟩
            k , ▹ᵏ-F.fmap k (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (▹ᵏ-C.m k (□ ⟦ Γ ˢ ⟧ₓ) ⟦A⟧ n (□-▹ᵏ.at k (□ ⟦ Γ ˢ ⟧ₓ) n (δ.at ⟦ Γ ˢ ⟧ₓ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧)) , a))
        ≡⟨ {!   !} ⟩
            k , ▹ᵏ-F.fmap k (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n a
        ≡⟨⟩
            F-◇.fmap (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n (k , a)
        ∎


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Abstract.Types
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Yasm.System     ConcSysParms
open import LibraBFT.Yasm.Properties ConcSysParms

-- This module collects the implementation obligations for our (fake/simple, for now)
-- "implementation" into the structure required by Concrete.Properties.

open import LibraBFT.Concrete.Obligations

module LibraBFT.Impl.Properties where

  open import LibraBFT.Impl.Properties.Aux
  open import LibraBFT.Concrete.System impl-sps-avp
  import      LibraBFT.Impl.Properties.VotesOnce   as VO
  import      LibraBFT.Impl.Properties.LockedRound as LR

  theImplObligations : ImplObligations
  theImplObligations = record { sps-cor = impl-sps-avp
                              ; vo₁     = VO.vo₁
                              ; vo₂     = VO.vo₂
                              ; lr₁     = LR.lr₁ }


-- Andreas, 2013-03-20
-- Without termination checking disabled, the positivity checker
-- will throw an error.
module NoTerminationCheckPositivity where

open import Common.Level

module M {a}{A : Set a}(K : A → A → A) where

  -- F fails the termination check
  F : A → A
  F X = K X (F X)

K : Set → Set → Set
K X Y = X

open M K

data E : Set where
  e : F E → E

-- Since F is non-terminating and hence excluded from unfolding
-- in the positivity checker, it will complain unless termination
-- checking is off.


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness #-}

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.List using ([]; _++_; _∷_; _∷ʳ_)

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; subst)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε; _◅_; _◅◅_; return)

open import Common

module FairCompliance {ℙ : Set} (message : Message ℙ)
  where

open import Trace message
open import Session message
open import SessionType message
open import Transitions message
open import HasTrace message

fair-compliance-red* : ∀{S S'} -> FairComplianceS S -> Reductions S S' -> FairComplianceS S'
fair-compliance-red* comp reds reds' = comp (reds ◅◅ reds')

fair-compliance->may-succeed : ∀{S} -> FairComplianceS S -> MaySucceed S
fair-compliance->may-succeed fcomp = fcomp ε

fc-after-output :
  ∀{f g x} ->
  FairComplianceS (out f # inp g) ->
  x ∈ dom f ->
  FairComplianceS (f x .force # g x .force)
fc-after-output comp fx reds = comp (sync (out fx) inp ◅ reds)

fc-after-input :
  ∀{f g x} ->
  FairComplianceS (inp f # out g) ->
  x ∈ dom g ->
  FairComplianceS (f x .force # g x .force)
fc-after-input comp gx reds = comp (sync inp (out gx) ◅ reds)

fc-input : ∀{R f} -> FairComplianceS (R # inp f) ->
            Win R ⊎ ∃[ g ] (R ≡ out g × Witness g × (∀{x} (!x : x ∈ dom g) -> FairComplianceS (g x .force # f x .force)))
fc-input {nil} spec with spec ε
... | _ , ε , win#def () _
... | _ , sync () _ ◅ _ , _
fc-input {inp _} spec with spec ε
... | _ , ε , win#def () _
... | _ , sync () inp ◅ _ , _
fc-input {out g} spec with Empty? g
... | inj₁ U = inj₁ (out U)
... | inj₂ W = inj₂ (g , refl , W , λ !x -> fair-compliance-red* spec (return (sync (out !x) inp)))

fc-output : ∀{R f} -> FairComplianceS (R # out f) ->
            Win R ⊎ ∃[ g ] (R ≡ inp g × Witness f × (∀{x} (!x : x ∈ dom f) -> FairComplianceS (g x .force # f x .force)))
fc-output {nil} spec with spec ε
... | _ , ε , win#def () out
... | _ , sync () _ ◅ _ , _
fc-output {inp g} {f} spec with Empty? f
... | inj₂ W = inj₂ (g , refl , W , λ !x -> fair-compliance-red* spec (return (sync inp (out !x))))
... | inj₁ U with spec ε
... | _ , ε , win#def () _
... | _ , sync inp (out !x) ◅ _ , _ = ⊥-elim (U _ !x)
fc-output {out g} spec with Empty? g
... | inj₁ U = inj₁ (out U)
... | inj₂ (_ , !x) with spec ε
... | _ , ε , win#def (out U) out = ⊥-elim (U _ !x)
... | _ , sync () (out _) ◅ _ , _

fc-transitions :
  ∀{R R' T T' φ} ->
  Transitions R (co-trace φ) R' ->
  Transitions T φ T' ->
  FairComplianceS (R # T) ->
  FairComplianceS (R' # T')
fc-transitions rr tr comp = fair-compliance-red* comp (zip-red* rr tr)

fc-trace :
  ∀{R T φ} ->
  FairComplianceS (R # T) ->
  (rφ : R HasTrace (co-trace φ))
  (tφ : T HasTrace φ) ->
  FairComplianceS (after rφ # after tφ)
fc-trace comp (_ , _ , rr) (_ , _ , tr) = fc-transitions rr tr comp

fc-output-trace :
  ∀{R T x} ->
  FairComplianceS (R # T) ->
  T HasTrace (O x ∷ []) ->
  Win R ⊎ (R HasTrace (I x ∷ []))
fc-output-trace {nil} comp tφ with comp ε
... | _ , ε , win#def () _
... | _ , sync () _ ◅ _ , _
fc-output-trace {inp f} {_} {x} comp (_ , _ , step (out gx) refl) with x ∈? f
... | yes fx = inj₂ (_ , fx , step inp refl)
... | no nfx with comp (return (sync inp (out gx)))
... | _ , ε , win#def w _ = ⊥-elim (nfx (win->defined w))
... | _ , sync r _ ◅ _ , _ = ⊥-elim (contraposition transition->defined nfx r)
fc-output-trace {out f} comp (_ , _ , step (out _) refl) with comp ε
... | _ , ε , win#def w _ = inj₁ w
... | _ , sync () (out _) ◅ _ , _

has-trace-snoc :
  ∀{T φ α} -> T HasTrace (φ ∷ʳ α) ->
  ∃ λ (tφ : T HasTrace φ) -> after tφ HasTrace (α ∷ [])
has-trace-snoc {_} {[]} tα@(_ , _ , step inp refl) = (_ , inp , refl) , tα
has-trace-snoc {_} {[]} tα@(_ , _ , step (out _) refl) = (_ , out , refl) , tα
has-trace-snoc {_} {_ ∷ φ} (_ , def , step t tr) =
  let (_ , tdef , sr) , tφ/α = has-trace-snoc (_ , def , tr) in
  (_ , tdef , step t sr) , tφ/α

client-wins-or-accepts-prefix :
  ∀{R T φ x}
  (comp : FairComplianceS (R # T))
  (rφ : R HasTrace (co-trace φ))
  (tφ : T HasTrace (φ ∷ʳ O x)) ->
  Win (after rφ) ⊎ R HasTrace (co-trace (φ ∷ʳ O x))
client-wins-or-accepts-prefix {_} {_} {φ} comp rφ tφα with has-trace-snoc tφα
... | tφ , tφ/α with fc-trace comp rφ tφ
... | comp/φ with fc-output-trace comp/φ tφ/α
... | inj₁ w = inj₁ w
... | inj₂ rφ/α =
  let rφα = join-trace rφ rφ/α in
  inj₂ (subst (_ HasTrace_) (sym (co-trace-++ φ _)) rφα)


module Issue555c where

import Common.Level

record R {a} (A : Set a) : Set

record R A where
  field f : A


-- Useless private
module Issue476a where

A : Set₁
private
  A = Set


{-# OPTIONS --allow-unsolved-metas #-}
module MGU-revised where

--open import Agda.Builtin.Nat using () renaming (Nat to ℕ)
open import Agda.Primitive
open import Agda.Builtin.Equality

open import Prelude.Product using (Σ; _,_; fst; snd; _×_; curry; uncurry)
open import Prelude.Equality using (eqReasoningStep; _∎; sym; trans; cong)
open import Prelude.Function using (_∘_)
open import Prelude.Empty using (⊥)
open import Prelude.Sum using (left; right) renaming (Either to _⊎_)
open import Prelude.Maybe using (Maybe; just; nothing)

private
  ∃ : ∀ {a b} {A : Set a} (B : A → Set b) → Set (a ⊔ b)
  ∃ = Σ _

open import Prelude using (_$_)

open import Relation.Binary

open import Prolegomenon

import Relation.Binary.Indexed as I

open import Algebra

mcbrideMonoidTransformer : MonoidTransformer lzero lzero lzero lzero
Setoid.Carrier (MonoidTransformer.base mcbrideMonoidTransformer) = {!!}
Setoid._≈_ (MonoidTransformer.base mcbrideMonoidTransformer) = {!!}
Setoid.isEquivalence (MonoidTransformer.base mcbrideMonoidTransformer) = {!!}
Monoid.Carrier (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid._≈_ (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid._∙_ (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid.ε (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid.isMonoid (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
MonoidTransformer._◃_ mcbrideMonoidTransformer = {!!}
MonoidTransformer.isMonoidTransformer mcbrideMonoidTransformer = {!!}

record Unificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  field
    monoidTransformer : MonoidTransformer ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open module MT = MonoidTransformer monoidTransformer public
{-
  open MonoidTransformer monoidTransformer public renaming
    (_≈ˢ_ to _=ᵗ_
    ;Carrierˢ to T
    ;Carrierᵐ to S
    ;_≈ᵐ_ to _=ˢ_)
-}
  Property : ∀ {ℓ} → Set (ℓˢ ⊔ lsuc ℓ)
  Property {ℓ} = E.Carrier → Set ℓ

  Nothing : ∀ {ℓ} → (P : Property {ℓ}) → Set (ℓ ⊔ ℓˢ)
  Nothing P = ∀ s → P s → ⊥

  IsUnifier : (t₁ t₂ : B.Carrier) → Property
  IsUnifier t₁ t₂ s = s ◃ t₁ B.≈ s ◃ t₂

  field
    unify : (t₁ t₂ : B.Carrier) → Nothing (IsUnifier t₁ t₂) ⊎ ∃ (IsUnifier t₁ t₂)

record MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  --infix 4 _≠ᵗ_
  field
    unificationoid : Unificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open Unificationoid unificationoid public

  _≤_ : (s₋ : E.Carrier) (s₊ : E.Carrier) → Set (ℓˢ ⊔ ℓ⁼ˢ)
  _≤_ s₋ s₊ = ∃ λ s → s E.∙ s₊ E.≈ s₋

  _≠ᵗ_ : B.Carrier → B.Carrier → Set ℓ⁼ᵗ
  _≠ᵗ_ t₁ t₂ = t₁ B.≈ t₂ → ⊥
{-
  _<_ : (s₋ : E.Carrier) (s₊ : E.Carrier) → Set (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)
  _<_ s₋ s₊ = s₋ ≤ s₊ × (∀ t → (s₊ ◃ t) ≠ᵗ t → (s₋ ◃ t) ≠ᵗ t) × ∃ λ t → (s₋ ◃ t) ≠ᵗ t × (s₊ ◃ t) B.≈ t
  --the set of T that are changed by a applying substitution is strictly less with s₊ than with s₋. That is, s₋ makes more changes than s₊.
  --that is, if s₊ makes a change to t then so does s₋, but there is some t s.t. s₋ makes a change but s₊ does not
-}
  MostGenerally : ∀ {ℓ} (P : Property {ℓ}) → Property
  MostGenerally P s₊ = P s₊ × ∀ s₋ → P s₋ → s₋ ≤ s₊

  field
    isMguIfUnifier : (t₁ t₂ : B.Carrier) → (ru : ∃ λ s → unify t₁ t₂ ≡ right s) →
      Prelude.case ru of (λ {((u , _) , _) → MostGenerally (IsUnifier t₁ t₂) u})

  mgu : (t₁ t₂ : B.Carrier) → Nothing (IsUnifier t₁ t₂) ⊎ ∃ (MostGenerally $ IsUnifier t₁ t₂)
  mgu t₁ t₂ with unify t₁ t₂ | Prelude.graphAt (unify t₁) t₂
  mgu t₁ t₂ | left x | ef = left x
  mgu t₁ t₂ | right x | Prelude.ingraph eq with isMguIfUnifier t₁ t₂ (x , eq)
  mgu t₁ t₂ | right (fst₁ , snd₁) | (Prelude.ingraph eq) | dfsd = right (fst₁ , dfsd)

record PairMostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  field
    mostGeneralUnificationoid : MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open MostGeneralUnificationoid mostGeneralUnificationoid public

  field
    separateExponents : E.Carrier → E.Carrier × E.Carrier

  IsPairUnifier : (t₁ t₂ : B.Carrier) → Property
  IsPairUnifier t₁ t₂ u = let (s₁ , s₂) = separateExponents u in s₁ ◃ t₁ B.≈ s₂ ◃ t₂

  field
    pair-mgu : (t₁ t₂ : B.Carrier)
               → Nothing (IsPairUnifier t₁ t₂) ⊎ ∃ (MostGenerally (IsPairUnifier t₁ t₂))

record MakePairFromRegular ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  field
    mostGeneralUnificationoid : MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open MostGeneralUnificationoid mostGeneralUnificationoid public

  field
    left-exponent : E.Carrier → E.Carrier
    right-exponent : E.Carrier → E.Carrier
    left-base : B.Carrier → B.Carrier
    right-base : B.Carrier → B.Carrier
    exponent-to-base : ∀ {s t₁ t₂} → left-exponent s ◃ t₁ B.≈ right-exponent s ◃ t₂ → s ◃ left-base t₁ B.≈ s ◃ right-base t₂
    base-to-exponent : ∀ {s t₁ t₂} → s ◃ left-base t₁ B.≈ s ◃ right-base t₂ → left-exponent s ◃ t₁ B.≈ right-exponent s ◃ t₂

  pairMostGeneralUnificationoid : PairMostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ
  PairMostGeneralUnificationoid.mostGeneralUnificationoid pairMostGeneralUnificationoid = mostGeneralUnificationoid
  PairMostGeneralUnificationoid.separateExponents pairMostGeneralUnificationoid x = left-exponent x , right-exponent x
  PairMostGeneralUnificationoid.pair-mgu pairMostGeneralUnificationoid t₁ t₂ with mgu (left-base t₁) (right-base t₂)
  PairMostGeneralUnificationoid.pair-mgu pairMostGeneralUnificationoid t₁ t₂ | left notunifier = left (λ s x → notunifier s (exponent-to-base x))
  PairMostGeneralUnificationoid.pair-mgu pairMostGeneralUnificationoid t₁ t₂ | right (s , x-base , unified-correct) = right (s , base-to-exponent x-base , (λ s₋ x-exponent → unified-correct s₋ (exponent-to-base x-exponent)))

  --(s , base-to-exponent x , (λ s₋ x₁ → s₋ , {!snd (snd₁ s x)!}))

-- -- open import Algebra

-- -- record PairUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
-- --   field
-- --     monoidTransformer : MonoidTransformer ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- --   open module MT = MonoidTransformer monoidTransformer public -- renaming (module E to Exponent)

-- -- {-
-- --   open MonoidTransformer monoidTransformer public renaming
-- --     (_≈ˢ_ to _=ᵗ_
-- --     ;Carrierˢ to T
-- --     ;Carrierᵐ to S
-- --     ;_≈ᵐ_ to _=ˢ_)
-- -- -}

-- --   Property : ∀ {ℓ} → Set (ℓˢ ⊔ lsuc ℓ)
-- --   Property {ℓ} = E.Carrier × E.Carrier → Set ℓ

-- --   Nothing : ∀ {ℓ} → (P : Property {ℓ}) → Set (ℓ ⊔ ℓˢ)
-- --   Nothing P = ∀ u → P u → ⊥

-- --   IsUnifier : ∀ t₁ t₂ → Property
-- --   IsUnifier t₁ t₂ u = let (s₁ , s₂) = u in s₁ ◃ t₁ B.≈ s₂ ◃ t₂

-- --   field
-- --     unify : ∀ t₁ t₂
-- --           → Nothing (IsUnifier t₁ t₂) ⊎ ∃ (IsUnifier t₁ t₂)

-- -- module MakePairUnificationoidFromUnificationoid where

-- --   postulate
-- --     ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Level
-- --     unificationoid : Unificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- --   open Unificationoid unificationoid

-- --   pairUnificationoid : PairUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ
-- --   PairUnificationoid.monoidTransformer pairUnificationoid = monoidTransformer
-- --   PairUnificationoid.unify pairUnificationoid t₁ t₂ with unify t₁ t₂
-- --   PairUnificationoid.unify pairUnificationoid t₁ t₂ | left x = left (λ {(s₁ , s₂) x₁ → x {!!} {!x₁!}})
-- --   PairUnificationoid.unify pairUnificationoid t₁ t₂ | right (s₁ , snd₁) = {!!}

-- --   {-
-- --     s ◃ swap ◃ t₁ = s ◃ t₂
-- --     swap ∙ swap = ε
-- --     want: x , y s.t. x ◃ t₁ = x ◃ t₂
-- --     easy: x = s ∙ swap, y = s

-- --     harder:
-- --     s₁ ◃ t₁ = s₂ ◃ t₂
-- --     want: x s.t. x ◃ t₁ = x ◃ t₂
-- --   -}

-- -- -- record Isomorphic {a} {A : Set a} {ℓᵃ} {_=ᵃ_ : A → A → Set ℓᵃ} (isEquivalenceᵃ : IsEquivalence _=ᵃ_)  {b} {B : Set b} {ℓᵇ} {_=ᵇ_ : B → B → Set ℓᵇ} (isEquivalenceᵇ : IsEquivalence _=ᵇ_) : Set (a ⊔ ℓᵃ ⊔ b ⊔ ℓᵇ) where
-- -- --   field
-- -- --     toA : B → A
-- -- --     toB : A → B
-- -- --     rtA : (x : A) → toA (toB x) =ᵃ x
-- -- --     rtB : (x : B) → toB (toA x) =ᵇ x
-- -- --     isoA : (x₁ x₂ : A) → x₁ =ᵃ x₂ → toB x₁ =ᵇ toB x₂
-- -- --     isoB : (x₁ x₂ : B) → x₁ =ᵇ x₂ → toA x₁ =ᵃ toA x₂

-- -- -- record Splittable ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
-- -- --   field
-- -- --     mostGeneralUnificationoid : MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- -- --   open MostGeneralUnificationoid mostGeneralUnificationoid public

-- -- --   S-independent : (t₁ t₂ : T) → Set (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)
-- -- --   S-independent t₁ t₂ = ∀ t₁s s → s ◃ t₁ =ᵗ t₁s → MostGenerally (λ s → s ◃ t₁ =ᵗ t₁s) s → s ◃ t₂ =ᵗ t₂

-- -- --   S-Invertable : Property
-- -- --   S-Invertable s = s ∙ s =ˢ ε

-- -- --   Swapifies : (t₁ t₂ : T) → Property
-- -- --   Swapifies t₁ t₂ s = s ◃ t₁ =ᵗ t₂ × s ◃ t₂ =ᵗ t₁

-- -- --   UnifiesOnLeft : (t₁ t₂ : T) → Property
-- -- --   UnifiesOnLeft t₁ t₂ s = s ◃ t₁ =ᵗ t₂

-- -- --   RelativeIdentity : T → Property
-- -- --   RelativeIdentity t s = s ◃ t =ᵗ t

-- -- --   field
-- -- --     make-S-independent :
-- -- --       (t₁ t₂ : T) →
-- -- --         ∃ λ swap₁ → S-Invertable swap₁ ×
-- -- --                     ∃ λ t₁′ → MostGenerally (Swapifies t₁ t₁′) swap₁ ×
-- -- --                               ∃ λ s₁ → MostGenerally (UnifiesOnLeft t₁ t₁′) s₁ ×
-- -- --                                        RelativeIdentity t₂ s₁

-- -- --     Tᵢ : Prelude.List Prelude.Nat → Set
-- -- --     toTᵢ : T → ∃ Tᵢ

-- -- --   pairUnification : PairMostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ
-- -- --   PairMostGeneralUnificationoid.monoidTransformer pairUnification = monoidTransformer
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ with make-S-independent t₁ t₂
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ | (swap₁ , swap₁∙swap₁=ε , t₁′ , ((swap₁◃t₁=t₁′ , swap₁◃t₁′=t₁) , mgswap) , slip₁ , (slip₁◃t₁=t₁′ , mgleft) , slip₁◃t₂=t₂) with mgu t₁′ t₂
-- -- -- --  … | (left NoT₁T₂) =
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ | (swap₁ , swap₁∙swap₁=ε , t₁′ , ((swap₁◃t₁=t₁′ , swap₁◃t₁′=t₁) , mgswap) , slip₁ , (slip₁◃t₁=t₁′ , mgleft) , slip₁◃t₂=t₂) | (left NoT₁T₂) =
-- -- --     left
-- -- --     λ {(s₁ , s₂) s₁◃t₁=s₂◃t₂ →
-- -- --     {!let (s₁′ , s₂′ , s₁′◃t₁=s₂′◃t₂ , s₁′∙swap₁◃t₂=swap₁◃t₂ , s₂′∙swap₁∙s₂′◃t₂=swap₁∙s₂′◃t₂) = helper!}}
-- -- --     {-
-- -- --     NoT₁T₂ (slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁)
-- -- --       (let t₁′▹s₂=t₁′ : {!!} -- s₂ ◃ t₁′ =ᵗ t₁′
-- -- --            t₁′▹s₂=t₁′ = {!!} in {!!})}
-- -- --     -}
-- -- --          -- ? s₂ (s₁ ◃ t₁) (symˢ t₁▹s₁=t₂▹s₂ , (λ s₁₋ t₂▹s₁₋=t₁▹s₁ → {!!} , {!!})) in {!!})}) -- mgur s₂ (t₁ ▹ s₁) (symˢ t₁▹s₁=t₂▹s₂ , ?)
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ | (swap₁ , swap₁∙swap₁=ε , t₁′ , ((swap₁◃t₁=t₁′ , swap₁◃t₁′=t₁) , mgswap) , slip₁ , (slip₁◃t₁=t₁′ , mgleft) , slip₁◃t₂=t₂) | (right (s , s◃t₁′=s◃t₂ , mgur)) = right $ (s ∙ slip₁ , s) , {!!} , (λ {(s₁′ , s₂′) s₁′◃t₁=s₂′◃t₂ → {!!}})

-- -- --   {-
-- -- --   goal
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ◃ t₁′        =ᵗ slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ◃ t₂
-- -- --   by slip₁◃t₁=t₁′
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ∙ slip₁ ◃ t₁ =ᵗ slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ◃ t₂
-- -- --   conjecture: swap₁ ∙ slip₁ ◃ t₁ = t₁
-- -- --   conjecture: s₁ ∙ swap₁ ◃ t₂ = swap₁ ◃ t₂
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ◃ t₁ =ᵗ slip₁ ∙ s₂ ∙ swap₁ ∙ swap₁ ◃ t₂
-- -- --   by swap₁∙swap₁=ε
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ◃ t₁ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   by s₁◃t₁=s₂◃t₂
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   conjecture: s₂ ∙ swap₁ ∙ s₂ ◃ t₂ = swap₁ ∙ s₂ ◃ t₂
-- -- --   slip₁ ∙ swap₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   conjecture: swap₁ ∙ s₂ ◃ t₂ = slip₁ ∙ s₂ ◃ t₂
-- -- --   slip₁ ∙ slip₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   conjecture: slip₁ ∙ slip₁ = slip₁
-- -- --   slip₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂

-- -- --   goal : ?0 ◃ t₁′ = ?0 ◃ t₂

-- -- --   e.g.
-- -- --   f(x,g(y),z) = f(g(y),x,h(z))
-- -- --   s₁ = x → g(y) , z → h(z) ; s₂ = x → g(y)
-- -- --   s = x → a ; y → b ; z → c
-- -- --   t₁′ = f(a,g(b),c)
-- -- --   S = a → g(y) , x → g(b) , c → h(z)
-- -- --   s⁻¹ = a → x , b → y , c → z
-- -- --   s₁ ∙ s⁻¹ = a → g(y) , b → y , c → h(z)
-- -- --   s₂ ∙ s₁ ∙ s⁻¹ = a → g(y) , b → y , c → h(z) , x → g(y)
-- -- --   S = s ∙ s₂ ∙ s₁ ∙ s⁻¹ = a → g(b) , b → b , c → h(c) , x → g(b) , y → b , z → c
-- -- --   t₁′ ▹ S = f(g(b),g(b),h(c))
-- -- --   t₂ ▹ S = f(g(b),g(b),h(c))

-- -- --   f(x,g(y),z) = f(g(y),x,h(z))
-- -- --   s₁ = x → g(x) , y → x , z → h(z) ; s₂ = y → x , x → g(x)
-- -- --   s = x → a ; y → b ; z → c
-- -- --   t₁′ = f(a,g(b),c)
-- -- --   s⁻¹ = a → x , b → y , c → z
-- -- --   s₁ ∙ s⁻¹ = a → g(x) , b → x , c → h(z) , x → g(x) , y → x , z → h(z)
-- -- --   s₂ ∙ s₁ ∙ s⁻¹ = a → g(g(x)) , b → g(x) , c → h(z) , x → g(g(x)) , y → g(x) , z → h(z)
-- -- --   s ∙ s₂ ∙ s₁ ∙ s⁻¹ = a → g(g(a)) , b → g(a) , c → h(c) , x → g(g(a)) , y → g(a) , z → h(c)

-- -- --   s⁻¹          = a → x    , b → y , c → z
-- -- --   s₁ ∙ s⁻¹     = a → g(x) , b → x , c → h(z) , x → g(x) , y → x , z → h(z)
-- -- --   s ∙ s₁ ∙ s⁻¹ = a → g(a) , b → a , c → h(c) , x → g(a) , y → a , z → h(c)

-- -- --   s₁′          = a → g(a) , b → a , c → h(c)
-- -- --   s₂′          = y → a , x → g(a) , z → c

-- -- --   let swap₁ = x → a , y → b , z → c , a → x , b → y , c → z -- take variables common to t₁ and t₂, and swap them for variables outside of either (and outside of s₁ or s₂?)
-- -- --         s₁ ∙ swap₁ = x → a , y → b , z → c , a → g(x) , b → x , c → h(z)
-- -- --   s₁′ = swap₁ ∙ s₁ ∙ swap₁ = a → g(a) , b → a , c → h(c)
-- -- --   s₁′ = swap₁ ∙ s₁ ∙ swap₁
-- -- --   let slip₁ = x → a , y → b , z → c
-- -- --   let s₂′ = slip₁ ∙ s₂ = y → a , x → g(a) , z → c
-- -- --   s₂′ ∙ s₁′ = a → g(a) , b → a , c → h(c) , y → a , x → g(a) , z → c
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁

-- -- --   f(g(g(a)),g(g(a)),h(c)) = f(g(g(a)),g(g(a)),h(h(c)))

-- -- --   f(x,g(y),z) = f(g(y),x,h(z))
-- -- --   -}
-- -- --   {-
-- -- --   … | (t₁' , s-independent , s , t₁'= , s⁻¹ , t₁=) with mgu t₁' t₂
-- -- --   … | (left NoT₁T₂) = left $ λ {(s₁ , s₂) t₁▹s₁=t₂▹s₂ → NoT₁T₂ {!≈ˢ-over-▹-⟶-≈ᵐ!} {!isMonoidTransformer!}}
-- -- --   … | (right x) = right {!!}
-- -- --   -}

-- -- -- {-
-- -- --   suppose t₁ ▹ s₁ = t₂ ▹ s₂
-- -- --   given:
-- -- --     t₁' ▹ * ≠ t₂ ▹ *

-- -- --   t₁ = t₁' ▹ s
-- -- --   try s = the most general such

-- -- --   t₁ = t₁' ▹ s⁻¹
-- -- --   t₁' = t₁ ▹ s
-- -- --   t₁ ▹ s₁ = t₂ ▹ s₂
-- -- --   s ∙ s⁻¹ = ε

-- -- --   t₁' ▹ s⁻¹ ▹ s₁ = t₂ ▹ s₂

-- -- --   finx x = s₁

-- -- --   t₁ ▹ x = t₂ ▹ s⁻¹ ▹ x
-- -- --   t₁' ▹ x = t₂ ▹ x
-- -- --   t₁ ▹ s ▹ x = t₂ ▹ x
-- -- --   t₁ ▹ s ▹ x = t₂ ▹ s⁻¹ ▹ s ▹ x
-- -- -- -}

-- -- -- data STerm (A : Set) : Set where
-- -- --   ι : A → STerm A
-- -- --   _fork_ : STerm A → STerm A → STerm A
-- -- --   leaf : STerm A

-- -- -- sub : {V : Set} → (V → Maybe (STerm V)) → STerm V → STerm V
-- -- -- sub σ (ι x) with σ x
-- -- -- sub σ (ι x) | nothing = ι x
-- -- -- sub σ (ι x) | just x₁ = x₁
-- -- -- sub σ (t fork t₁) = sub σ t fork sub σ t₁
-- -- -- sub σ leaf = leaf

-- -- -- {-
-- -- --   Sᵢ : List (V × T) → S
-- -- --   Tᵢ : List V → T
-- -- --   indexS : S → ∃ Sᵢ
-- -- --   indexT : T → ∃ Tᵢ
-- -- --   _▹ᵢ_ : {vs : List V} {vts : List (V × T)} → Tᵢ vs → Sᵢ vts → ∃ λ
-- -- --   (t : T) (s : S) → t ▹ s
-- -- --   (V → T) → T → T

-- -- --   getTermIndexedByAVariable : (v : V) (t : T) → T → T
-- -- --   getTermFromIndexedTerm :

-- -- --   v ∈ variables s → t ▹ s
-- -- -- -}

-- -- -- record IsSeparableInto {sx s x} (SX : Set sx) (S : Set s) (X : Set x) : Set (s ⊔ x ⊔ sx) where
-- -- --   field
-- -- --     separate : SX → S × X
-- -- --     combine : S × X → SX
-- -- --     iso : ∀ sx → combine (separate sx) ≡ sx

-- -- -- record IsSeparableInto₂ {sx s x} (SX : Set sx) (X : Set x) (S : X → Set s) : Set (s ⊔ x ⊔ sx) where
-- -- --   field
-- -- --     separate : SX → Σ X S
-- -- --     combine : Σ X S → SX
-- -- --     iso : ∀ sx → combine (separate sx) ≡ sx

-- -- -- record Separableoid sx s x : Set (lsuc (sx ⊔ s ⊔ x)) where
-- -- --   field
-- -- --     SX : Set sx
-- -- --     S : Set s
-- -- --     X : Set x
-- -- --     separable : IsSeparableInto SX S X

-- -- -- -- record FreeVariableoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ ℓᵛ ℓ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
-- -- -- --   field
-- -- -- --     monoidTransformer : MonoidTransformer ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- -- -- --   open MonoidTransformer monoidTransformer public renaming
-- -- -- --     (_≈ˢ_ to _=ᵗ_
-- -- -- --     ;Carrierˢ to T
-- -- -- --     ;Carrierᵐ to S
-- -- -- --     ;_≈ᵐ_ to _=ˢ_)

-- -- -- --   field
-- -- -- --     termVariableoid : Setoid ℓᵛ ℓ⁼ᵛ
-- -- -- --     termStructureoid :

-- -- -- --   open Setoid Variable public using () renaming
-- -- -- --     (Carrier to V
-- -- -- --     ;_≈_ to _=ᵛ_)

-- -- -- --   field
-- -- -- --     termVariables : Term → Pred Variable ℓᵛ


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use Data.Vec.Recursive.Categorical
-- instead.
------------------------------------------------------------------------

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

module Data.Product.N-ary.Categorical where

{-# WARNING_ON_IMPORT
"Data.Product.N-ary.Categorical was deprecated in v1.1.
Use Data.Vec.Recursive.Categorical instead."
#-}

open import Data.Vec.Recursive.Categorical public


{-# OPTIONS --cubical --no-sized-types --no-guardedness #-}
module Issue2487.c where

postulate admit : {A : Set} -> A


-- Compiled things must have a Haskell type given by a COMPILED_TYPE pragma

module CompiledMustHaveHaskellType where

postulate
  N : Set
  foo : N

-- It is necessary add something like
-- {-# COMPILED_TYPE N Int #-}

{-# COMPILED foo bar #-}