Atlas: finish deriving the primitives `zip` and `update`

Primitives to add: lookup, fold

Old-commit-hash: 7de6fdc8217beb1c74bd1b71c9e60ef1132c3ec9

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

open import Syntax.Language.Calculus

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

data Atlas-const : Set where

  true  : Atlas-const
  false : Atlas-const
  xor   : Atlas-const

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
  update : ∀ {κ ι : Atlas-type} → Atlas-const
  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const

Atlas-lookup : Atlas-const → Type Atlas-type

Atlas-lookup true  = base Bool
Atlas-lookup false = base Bool
Atlas-lookup xor   = base Bool ⇒ base Bool ⇒ base Bool

Atlas-lookup (empty {κ} {ι}) = base (Map κ ι)

-- `update key val my-map` would
-- - insert if `key` is not present in `my-map`
-- - delete if `val` is the neutral element
-- - make an update otherwise
Atlas-lookup (update {κ} {ι}) =
  base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι)

-- Model of zip = Haskell Data.List.zipWith
-- zipWith :: (a → b → c) → [a] → [b] → [c]
Atlas-lookup (zip {κ} {a} {b} {c}) =
  (base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
  base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c)

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type Atlas-type → Type Atlas-type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

Atlas-context : Set
Atlas-context = Context {Type Atlas-type}

Atlas-term : Atlas-context → Type Atlas-type → Set
Atlas-term = Term {Atlas-type} {Atlas-const} {Atlas-lookup}

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Atlas-term Γ (base ι)
neutral-term {Bool}   = const (neutral {Bool})
neutral-term {Map κ ι} = const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Atlas-term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Shorthands of constants
--
-- There's probably a uniform way to lift constants
-- into term constructors.
--
-- TODO: write this and call it Syntax.Term.Plotkin.lift-term

zip! : ∀ {κ a b c Γ} →
  Atlas-term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Atlas-term Γ (base (Map κ a)) → Atlas-term Γ (base (Map κ b)) →
  Atlas-term Γ (base (Map κ c))

zip! f m₁ m₂ = app (app (app (const zip) f) m₁) m₂

lookup! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base ι)

lookup! = {!!} -- TODO: add constant `lookup`

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Atlas-term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = const xor
Atlas-diff {Map κ ι} = app (const zip) (abs Atlas-diff)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Atlas-term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = const xor
Atlas-apply {Map κ ι} = app (const zip) (abs Atlas-apply)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Atlas-term Γ τ → Atlas-term Γ τ →
  Atlas-term Γ (Atlas-Δtype τ)
diff s t = app (app (lift-diff Atlas-diff Atlas-apply) s) t

apply : ∀ {τ Γ} →
  Atlas-term Γ (Atlas-Δtype τ) → Atlas-term Γ τ →
  Atlas-term Γ τ
apply s t = app (app (lift-apply Atlas-diff Atlas-apply) s) t

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

update! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base (Map κ ι))

update! k v m = app (app (app (const update) k) v) m

insert : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  -- last argument is the change accumulator
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- The binary operator with which all base-type values
-- form a group

union : ∀ {ι Γ} →
  Atlas-term Γ (base ι) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base ι)
union {Bool} s t = app (app (const xor) s) t
union {Map κ ι} s t =
  let
    union-term = abs (abs (union (var (that this)) (var this)))
  in
    zip! (abs union-term) s t

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Atlas-term Γ (base ι)
  in
    Atlas-term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

zip4! f m₁ m₂ m₃ m₄ =
  let
    v₁ = var (that this)
    v₂ = var this
    v₃ = var (that this)
    v₄ = var this
    k₁₂ = var (that (that this))
    k₃₄ = var (that (that this))
    f₁₂ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₁₂) v₁) v₂)
      (lookup! k₁₂ (weaken₃ m₃))) (lookup! k₁₂ (weaken₃ m₄)))))
    f₃₄ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₃₄)
      (lookup! k₃₄ (weaken₃ m₁)))
      (lookup! k₃₄ (weaken₃ m₂))) v₃) v₄)))
  in
    -- A correct but inefficient implementation.
    -- May want to speed it up after constants are finalized.
    union (zip! f₁₂ m₁ m₂) (zip! f₃₄ m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ} → (c : Atlas-const) →
  Atlas-term Γ (Atlas-Δtype (Atlas-lookup c))

Atlas-Δconst true  = const false
Atlas-Δconst false = const false

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (app (app (const xor) Δx) Δy))))

Atlas-Δconst empty = const empty

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app (app (weaken₁ Δf) (var this)) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-lookup
  Atlas-Δtype
  Atlas-Δconst

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

open import Syntax.Language.Calculus

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

data Atlas-const : Set where

  true  : Atlas-const
  false : Atlas-const
  xor   : Atlas-const

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
  update : ∀ {κ ι : Atlas-type} → Atlas-const
  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const

Atlas-lookup : Atlas-const → Type Atlas-type

Atlas-lookup true  = base Bool
Atlas-lookup false = base Bool
Atlas-lookup xor   = base Bool ⇒ base Bool ⇒ base Bool

Atlas-lookup (empty {κ} {ι}) = base (Map κ ι)

-- `update key val my-map` would
-- - insert if `key` is not present in `my-map`
-- - delete if `val` is the neutral element
-- - make an update otherwise
Atlas-lookup (update {κ} {ι}) =
  base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι)

-- Model of zip = Haskell Data.List.zipWith
-- zipWith :: (a → b → c) → [a] → [b] → [c]
Atlas-lookup (zip {κ} {a} {b} {c}) =
  (base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
  base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c)

Atlas-Δtype : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δtype Bool = Bool
-- change to a map is change to its values
Atlas-Δtype (Map key val) = (Map key (Atlas-Δtype val))

Atlas-context : Set
Atlas-context = Context {Type Atlas-type}

Atlas-term : Atlas-context → Type Atlas-type → Set
Atlas-term = Term {Atlas-type} {Atlas-const} {Atlas-lookup}

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

nil-const : ∀ {ι : Atlas-type} → Atlas-const
nil-const {ι} = neutral {Atlas-Δtype ι}

nil-term : ∀ {ι Γ} → Atlas-term Γ (base (Atlas-Δtype ι))
nil-term {Bool} = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ} → (c : Atlas-const) →
      Atlas-term Γ (lift-Δtype₀ Atlas-Δtype (Atlas-lookup c))

Atlas-Δconst true  = const false
Atlas-Δconst false = const false

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (app (app (const xor) Δx) Δy))))

Atlas-Δconst empty = const empty

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- otherwise it is a deletion followed by insertion.
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- TODO: diff-term, apply-term
Atlas-Δconst update = {!!}

Atlas-Δconst zip = {!!}

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-lookup
  (lift-Δtype₀ Atlas-Δtype)
  Atlas-Δconst


Updated thesis' examples.

Updated thesis' examples.

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

module AgdaIntroduction where

infixr 5 _∷_ _++_
infix  4 _≡_

-- Dependent function types
id : (A : Set) → A → A
id A x = x

-- λ-notation
id₂ : (A : Set) → A → A
id₂ = λ A → λ x → x

id₃ : (A : Set) → A → A
id₃ = λ A x → x

-- Implicit arguments
id₄ : {A : Set} → A → A
id₄ x = x

id₅ : {A : Set} → A → A
id₅ = λ x → x

-- Inductively defined sets and families
data Bool : Set where
  false true : Bool

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ     #-}
{-# BUILTIN ZERO    zero  #-}
{-# BUILTIN SUC     succ  #-}

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

data Vec (A : Set) : ℕ → Set where
  []  : Vec A 0
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (succ n)

data Fin : ℕ → Set where
  fzero : {n : ℕ} → Fin (succ n)
  fsucc : {n : ℕ} → Fin n → Fin (succ n)

-- Structurally recursive functions and pattern matching
_+_ : ℕ → ℕ → ℕ
0      + n = n
succ m + n = succ (m + n)

map : {A B : Set} → (A → B) → List A → List B
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

f : ℕ → ℕ
f 0 = 0
f _ = 1

-- The absurd pattern
magic : {A : Set} → Fin 0 → A
magic ()

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

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

-- Mutual definitions
even : ℕ → Bool
odd  : ℕ → Bool

even 0        = true
even (succ n) = odd n

odd 0        = false
odd (succ n) = even n

data EvenList : Set
data OddList  : Set

data EvenList where
  []  : EvenList
  _∷_ : ℕ → OddList → EvenList

data OddList where
  _∷_ : ℕ → EvenList → OddList

-- Normalisation

data _≡_ {A : Set}: A → A → Set where
  refl : {a : A} → a ≡ a

length : {A : Set} → List A → ℕ
length []       = 0
length (x ∷ xs) = 1 + length xs

_++_ : {A : Set} → List A → List A → List A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ xs ++ ys

succCong : {m n : ℕ} → m ≡ n → succ m ≡ succ n
succCong refl = refl

thm : {A : Set}(xs ys : List A) → length (xs ++ ys) ≡ length xs + length ys
thm [] ys       = refl
thm (x ∷ xs) ys = succCong (thm xs ys)

-- Coverage and termination checkers
head : {A : Set} → List A → A
head (x ∷ xs) = x

ack : ℕ → ℕ → ℕ
ack 0        n        = succ n
ack (succ m) 0        = ack m 1
ack (succ m) (succ n) = ack m (ack (succ m) n)

-- Combinators for equational reasoning

postulate
  sym   : {A : Set}{a b : A} → a ≡ b → b ≡ a
  trans : {A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c
  subst : {A : Set}(P : A → Set){a b : A} → a ≡ b → P a → P b

postulate
  _*_             : ℕ → ℕ → ℕ
  *-comm          : ∀ m n → m * n ≡ n * m
  *-rightIdentity : ∀ n → n * 1 ≡ n

*-leftIdentity : ∀ n → 1 * n ≡ n
*-leftIdentity n =
  trans {ℕ} {1 * n} {n * 1} {n} (*-comm 1 n) (*-rightIdentity n)

module ER
  {A     : Set}
  (_∼_   : A → A → Set)
  (∼-refl  : ∀ {x} → x ∼ x)
  (∼-trans : ∀ {x y z} → x ∼ y → y ∼ z → x ∼ z)
  where

  infixr 5 _∼⟨_⟩_
  infix  5 _∎

  _∼⟨_⟩_ : ∀ x {y z} → x ∼ y → y ∼ z → x ∼ z
  _ ∼⟨ x∼y ⟩ y∼z = ∼-trans x∼y y∼z

  _∎ : ∀ x → x ∼ x
  _∎ _ = ∼-refl

open module ≡-Reasoning = ER _≡_ (refl {ℕ}) (trans {ℕ})
  renaming ( _∼⟨_⟩_ to _≡⟨_⟩_ )

*-leftIdentity' : ∀ n → 1 * n ≡ n
*-leftIdentity' n =
  1 * n ≡⟨ *-comm 1 n ⟩
  n * 1 ≡⟨ *-rightIdentity n ⟩
  n     ∎

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

module AgdaIntroduction where

infixr 5 _∷_ _++_
infix  4 _≡_

-- Dependent function types
id : (A : Set) → A → A
id A x = x

-- λ-notation
id₂ : (A : Set) → A → A
id₂ = λ A → λ x → x

id₃ : (A : Set) → A → A
id₃ = λ A x → x

-- Implicit arguments
id₄ : {A : Set} → A → A
id₄ x = x

id₅ : {A : Set} → A → A
id₅ = λ x → x

-- Inductively defined sets and families
data Bool : Set where
  false true : Bool

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ     #-}
{-# BUILTIN ZERO    zero  #-}
{-# BUILTIN SUC     succ  #-}

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

data Vec (A : Set) : ℕ → Set where
  []  : Vec A 0
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (succ n)

data Fin : ℕ → Set where
  fzero : {n : ℕ} → Fin (succ n)
  fsucc : {n : ℕ} → Fin n → Fin (succ n)

-- Structurally recursive functions and pattern matching
_+_ : ℕ → ℕ → ℕ
0      + n = n
succ m + n = succ (m + n)

map : {A B : Set} → (A → B) → List A → List B
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

-- The absurd pattern
magic : {A : Set} → Fin 0 → A
magic ()

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

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

-- Mutual definitions
even : ℕ → Bool
odd  : ℕ → Bool

even 0        = true
even (succ n) = odd n

odd 0        = false
odd (succ n) = even n

data EvenList : Set
data OddList  : Set

data EvenList where
  []  : EvenList
  _∷_ : ℕ → OddList → EvenList

data OddList where
  _∷_ : ℕ → EvenList → OddList

-- Normalisation

data _≡_ {A : Set}: A → A → Set where
  refl : {a : A} → a ≡ a

length : {A : Set} → List A → ℕ
length []       = 0
length (x ∷ xs) = 1 + length xs

_++_ : {A : Set} → List A → List A → List A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ xs ++ ys

succCong : {m n : ℕ} → m ≡ n → succ m ≡ succ n
succCong refl = refl

thm : {A : Set}(xs ys : List A) → length (xs ++ ys) ≡ length xs + length ys
thm [] ys       = refl
thm (x ∷ xs) ys = succCong (thm xs ys)

-- Coverage and termination checkers
head : {A : Set} → List A → A
head (x ∷ xs) = x

ack : ℕ → ℕ → ℕ
ack 0        n        = succ n
ack (succ m) 0        = ack m 1
ack (succ m) (succ n) = ack m (ack (succ m) n)

{-# NO_TERMINATION_CHECK #-}
f : ℕ → ℕ
f n = f n

{-# NO_TERMINATION_CHECK #-}
nest : ℕ → ℕ
nest 0        = 0
nest (succ n) = nest (nest n)

-- Combinators for equational reasoning

postulate
  sym   : {A : Set}{a b : A} → a ≡ b → b ≡ a
  trans : {A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c
  subst : {A : Set}(P : A → Set){a b : A} → a ≡ b → P a → P b

postulate
  _*_             : ℕ → ℕ → ℕ
  *-comm          : ∀ m n → m * n ≡ n * m
  *-rightIdentity : ∀ n → n * 1 ≡ n

*-leftIdentity : ∀ n → 1 * n ≡ n
*-leftIdentity n =
  trans {ℕ} {1 * n} {n * 1} {n} (*-comm 1 n) (*-rightIdentity n)

module ER
  {A     : Set}
  (_∼_   : A → A → Set)
  (refl  : ∀ {x} → x ∼ x)
  (trans : ∀ {x y z} → x ∼ y → y ∼ z → x ∼ z)
  where

  infixr 5 _∼⟨_⟩_
  infix  5 _∎

  _∼⟨_⟩_ : ∀ x {y z} → x ∼ y → y ∼ z → x ∼ z
  _ ∼⟨ x∼y ⟩ y∼z = trans x∼y y∼z

  _∎ : ∀ x → x ∼ x
  _∎ _ = refl

open module ≡-Reasoning = ER _≡_ (refl {ℕ}) (trans {ℕ})
  renaming ( _∼⟨_⟩_ to _≡⟨_⟩_ )

*-leftIdentity' : ∀ n → 1 * n ≡ n
*-leftIdentity' n =
  1 * n ≡⟨ *-comm 1 n ⟩
  n * 1 ≡⟨ *-rightIdentity n ⟩
  n     ∎


Added missing local hint.

Added missing local hint.

Ignore-this: 38c71d36e14d0bf8e8fe831d2f2baa98

darcs-hash:20110219041623-3bd4e-8e0d484d261b3040cbb34f3b7a133387fbedfae5.gz

------------------------------------------------------------------------------
-- Auxiliary properties of the McCarthy 91 function
------------------------------------------------------------------------------

module LTC.Program.McCarthy91.Properties.AuxiliaryATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesATP
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.IsN-ATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.Inequalities.PropertiesATP

open import LTC.Program.McCarthy91.ArithmeticATP
open import LTC.Program.McCarthy91.McCarthy91

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

--- Auxiliary properties

---- Case n > 100
postulate
  Nmc91>100      : ∀ {n} → N n → GT n one-hundred → N (mc91 n)
  x<mc91x+11>100 : ∀ {n} → N n → GT n one-hundred →
                           LT n (mc91 n + eleven)
{-# ATP prove Nmc91>100 N10 ∸-N #-}
{-# ATP prove x<mc91x+11>100 +-N ∸-N N10 N11 x<y→y≤z→x<z x<x+1 x+1≤x∸10+11
              +-comm #-}

-- Most of them not needed
-- Case n ≡ 100 can be proved automatically
postulate
  Nmc91≡100     : N (mc91 one-hundred)
  mc91-res-100  : mc91 one-hundred ≡ ninety-one
  mc91-res-100' : ∀ {n} → n ≡ one-hundred → mc91 n ≡ ninety-one
  mc91<mc91+11  : LT  one-hundred (mc91 one-hundred + eleven)
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10
              Nmc91>100 N111 N101
#-}
{-# ATP prove mc91-res-100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100' mc91-res-100 #-}
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 N91 #-}
{-# ATP prove mc91<mc91+11 mc91-res-100 102≡91+11 100<102 #-}

---- Case n ≤ 100

postulate
  Nmc91≤100'        : ∀ n → LE n one-hundred → N (mc91 (mc91 (n + eleven))) →
                      N (mc91 n)
  x<mc91x+11≤100'   : ∀ n → LE n one-hundred →
                      LT n (mc91 (mc91 (n + eleven)) + eleven) →
                      LT n (mc91 n + eleven)
  mc91x+11<mc91x+11 : ∀ n → LE n one-hundred →
                      LT (mc91 (n + eleven)) (mc91 (mc91 (n + eleven)) + eleven) →
                      LT (mc91 (n + eleven)) (mc91 n + eleven)
  mc91x-res≤100     : ∀ m n → LE m one-hundred →
                      mc91 (m + eleven) ≡ n → mc91 n ≡ ninety-one →
                      mc91 m ≡ ninety-one
{-# ATP prove Nmc91≤100' #-}
{-# ATP prove x<mc91x+11≤100' #-}
{-# ATP prove mc91x+11<mc91x+11 #-}
{-# ATP prove mc91x-res≤100 #-}

postulate
  mc91-res-110 : mc91 (ninety-nine + eleven)  ≡ one-hundred
  mc91-res-109 : mc91 (ninety-eight + eleven) ≡ ninety-nine
  mc91-res-108 : mc91 (ninety-seven + eleven) ≡ ninety-eight
  mc91-res-107 : mc91 (ninety-six + eleven)   ≡ ninety-seven
  mc91-res-106 : mc91 (ninety-five + eleven)  ≡ ninety-six
  mc91-res-105 : mc91 (ninety-four + eleven)  ≡ ninety-five
  mc91-res-104 : mc91 (ninety-three + eleven) ≡ ninety-four
  mc91-res-103 : mc91 (ninety-two + eleven)   ≡ ninety-three
  mc91-res-102 : mc91 (ninety-one + eleven)   ≡ ninety-two
  mc91-res-101 : mc91 (ninety + eleven)       ≡ ninety-one
{-# ATP prove mc91-res-110 99+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-109 98+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-108 97+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-107 96+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-106 95+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-105 94+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-104 93+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-103 92+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-102 91+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-101 90+11>100 x+11∸10≡Sx #-}

postulate
  mc91-res-99 : mc91 ninety-nine  ≡ ninety-one
  mc91-res-98 : mc91 ninety-eight ≡ ninety-one
  mc91-res-97 : mc91 ninety-seven ≡ ninety-one
  mc91-res-96 : mc91 ninety-six   ≡ ninety-one
  mc91-res-95 : mc91 ninety-five  ≡ ninety-one
  mc91-res-94 : mc91 ninety-four  ≡ ninety-one
  mc91-res-93 : mc91 ninety-three ≡ ninety-one
  mc91-res-92 : mc91 ninety-two   ≡ ninety-one
  mc91-res-91 : mc91 ninety-one   ≡ ninety-one
  mc91-res-90 : mc91 ninety       ≡ ninety-one
{-# ATP prove mc91-res-99 mc91x-res≤100 mc91-res-110 mc91-res-100 #-}
{-# ATP prove mc91-res-98 mc91x-res≤100 mc91-res-109 mc91-res-99 #-}
{-# ATP prove mc91-res-97 mc91x-res≤100 mc91-res-108 mc91-res-98 #-}
{-# ATP prove mc91-res-96 mc91x-res≤100 mc91-res-107 mc91-res-97 #-}
{-# ATP prove mc91-res-95 mc91x-res≤100 mc91-res-106 mc91-res-96 #-}
{-# ATP prove mc91-res-94 mc91x-res≤100 mc91-res-105 mc91-res-95 #-}
{-# ATP prove mc91-res-93 mc91x-res≤100 mc91-res-104 mc91-res-94 #-}
{-# ATP prove mc91-res-92 mc91x-res≤100 mc91-res-103 mc91-res-93 #-}
{-# ATP prove mc91-res-91 mc91x-res≤100 mc91-res-102 mc91-res-92 #-}
{-# ATP prove mc91-res-90 mc91x-res≤100 mc91-res-101 mc91-res-91 #-}

mc91-res-99' : ∀ {n} → n ≡ ninety-nine → mc91 n ≡ ninety-one
mc91-res-99' refl = mc91-res-99

mc91-res-98' : ∀ {n} → n ≡ ninety-eight → mc91 n ≡ ninety-one
mc91-res-98' refl = mc91-res-98

mc91-res-97' : ∀ {n} → n ≡ ninety-seven → mc91 n ≡ ninety-one
mc91-res-97' refl = mc91-res-97

mc91-res-96' : ∀ {n} → n ≡ ninety-six → mc91 n ≡ ninety-one
mc91-res-96' refl = mc91-res-96

mc91-res-95' : ∀ {n} → n ≡ ninety-five → mc91 n ≡ ninety-one
mc91-res-95' refl = mc91-res-95

mc91-res-94' : ∀ {n} → n ≡ ninety-four → mc91 n ≡ ninety-one
mc91-res-94' refl = mc91-res-94

mc91-res-93' : ∀ {n} → n ≡ ninety-three → mc91 n ≡ ninety-one
mc91-res-93' refl = mc91-res-93

mc91-res-92' : ∀ {n} → n ≡ ninety-two → mc91 n ≡ ninety-one
mc91-res-92' refl = mc91-res-92

mc91-res-91' : ∀ {n} → n ≡ ninety-one → mc91 n ≡ ninety-one
mc91-res-91' refl = mc91-res-91

mc91-res-90' : ∀ {n} → n ≡ ninety → mc91 n ≡ ninety-one
mc91-res-90' refl = mc91-res-90

------------------------------------------------------------------------------
-- Auxiliary properties of the McCarthy 91 function
------------------------------------------------------------------------------

module LTC.Program.McCarthy91.Properties.AuxiliaryATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesATP
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.IsN-ATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.Inequalities.PropertiesATP

open import LTC.Program.McCarthy91.ArithmeticATP
open import LTC.Program.McCarthy91.McCarthy91

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

--- Auxiliary properties

---- Case n > 100
postulate
  Nmc91>100      : ∀ {n} → N n → GT n one-hundred → N (mc91 n)
  x<mc91x+11>100 : ∀ {n} → N n → GT n one-hundred →
                           LT n (mc91 n + eleven)
{-# ATP prove Nmc91>100 N10 ∸-N #-}
{-# ATP prove x<mc91x+11>100 +-N ∸-N N10 N11 x<y→y≤z→x<z x<x+1 x+1≤x∸10+11
              +-comm #-}

-- Most of them not needed
-- Case n ≡ 100 can be proved automatically
postulate
  Nmc91≡100     : N (mc91 one-hundred)
  mc91-res-100  : mc91 one-hundred ≡ ninety-one
  mc91-res-100' : ∀ {n} → n ≡ one-hundred → mc91 n ≡ ninety-one
  mc91<mc91+11  : LT  one-hundred (mc91 one-hundred + eleven)
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10
              Nmc91>100 N111 N101
#-}
{-# ATP prove mc91-res-100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100' mc91-res-100 #-}
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 N91 #-}
-- TODO
-- {-# ATP prove mc91<mc91+11 mc91≡91 n102 100<102 #-}

---- Case n ≤ 100

postulate
  Nmc91≤100'        : ∀ n → LE n one-hundred → N (mc91 (mc91 (n + eleven))) →
                      N (mc91 n)
  x<mc91x+11≤100'   : ∀ n → LE n one-hundred →
                      LT n (mc91 (mc91 (n + eleven)) + eleven) →
                      LT n (mc91 n + eleven)
  mc91x+11<mc91x+11 : ∀ n → LE n one-hundred →
                      LT (mc91 (n + eleven)) (mc91 (mc91 (n + eleven)) + eleven) →
                      LT (mc91 (n + eleven)) (mc91 n + eleven)
  mc91x-res≤100     : ∀ m n → LE m one-hundred →
                      mc91 (m + eleven) ≡ n → mc91 n ≡ ninety-one →
                      mc91 m ≡ ninety-one
{-# ATP prove Nmc91≤100' #-}
{-# ATP prove x<mc91x+11≤100' #-}
{-# ATP prove mc91x+11<mc91x+11 #-}
{-# ATP prove mc91x-res≤100 #-}

postulate
  mc91-res-110 : mc91 (ninety-nine + eleven)  ≡ one-hundred
  mc91-res-109 : mc91 (ninety-eight + eleven) ≡ ninety-nine
  mc91-res-108 : mc91 (ninety-seven + eleven) ≡ ninety-eight
  mc91-res-107 : mc91 (ninety-six + eleven)   ≡ ninety-seven
  mc91-res-106 : mc91 (ninety-five + eleven)  ≡ ninety-six
  mc91-res-105 : mc91 (ninety-four + eleven)  ≡ ninety-five
  mc91-res-104 : mc91 (ninety-three + eleven) ≡ ninety-four
  mc91-res-103 : mc91 (ninety-two + eleven)   ≡ ninety-three
  mc91-res-102 : mc91 (ninety-one + eleven)   ≡ ninety-two
  mc91-res-101 : mc91 (ninety + eleven)       ≡ ninety-one
{-# ATP prove mc91-res-110 99+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-109 98+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-108 97+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-107 96+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-106 95+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-105 94+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-104 93+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-103 92+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-102 91+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-101 90+11>100 x+11∸10≡Sx #-}

postulate
  mc91-res-99 : mc91 ninety-nine  ≡ ninety-one
  mc91-res-98 : mc91 ninety-eight ≡ ninety-one
  mc91-res-97 : mc91 ninety-seven ≡ ninety-one
  mc91-res-96 : mc91 ninety-six   ≡ ninety-one
  mc91-res-95 : mc91 ninety-five  ≡ ninety-one
  mc91-res-94 : mc91 ninety-four  ≡ ninety-one
  mc91-res-93 : mc91 ninety-three ≡ ninety-one
  mc91-res-92 : mc91 ninety-two   ≡ ninety-one
  mc91-res-91 : mc91 ninety-one   ≡ ninety-one
  mc91-res-90 : mc91 ninety       ≡ ninety-one
{-# ATP prove mc91-res-99 mc91x-res≤100 mc91-res-110 mc91-res-100 #-}
{-# ATP prove mc91-res-98 mc91x-res≤100 mc91-res-109 mc91-res-99 #-}
{-# ATP prove mc91-res-97 mc91x-res≤100 mc91-res-108 mc91-res-98 #-}
{-# ATP prove mc91-res-96 mc91x-res≤100 mc91-res-107 mc91-res-97 #-}
{-# ATP prove mc91-res-95 mc91x-res≤100 mc91-res-106 mc91-res-96 #-}
{-# ATP prove mc91-res-94 mc91x-res≤100 mc91-res-105 mc91-res-95 #-}
{-# ATP prove mc91-res-93 mc91x-res≤100 mc91-res-104 mc91-res-94 #-}
{-# ATP prove mc91-res-92 mc91x-res≤100 mc91-res-103 mc91-res-93 #-}
{-# ATP prove mc91-res-91 mc91x-res≤100 mc91-res-102 mc91-res-92 #-}
{-# ATP prove mc91-res-90 mc91x-res≤100 mc91-res-101 mc91-res-91 #-}

mc91-res-99' : ∀ {n} → n ≡ ninety-nine → mc91 n ≡ ninety-one
mc91-res-99' refl = mc91-res-99

mc91-res-98' : ∀ {n} → n ≡ ninety-eight → mc91 n ≡ ninety-one
mc91-res-98' refl = mc91-res-98

mc91-res-97' : ∀ {n} → n ≡ ninety-seven → mc91 n ≡ ninety-one
mc91-res-97' refl = mc91-res-97

mc91-res-96' : ∀ {n} → n ≡ ninety-six → mc91 n ≡ ninety-one
mc91-res-96' refl = mc91-res-96

mc91-res-95' : ∀ {n} → n ≡ ninety-five → mc91 n ≡ ninety-one
mc91-res-95' refl = mc91-res-95

mc91-res-94' : ∀ {n} → n ≡ ninety-four → mc91 n ≡ ninety-one
mc91-res-94' refl = mc91-res-94

mc91-res-93' : ∀ {n} → n ≡ ninety-three → mc91 n ≡ ninety-one
mc91-res-93' refl = mc91-res-93

mc91-res-92' : ∀ {n} → n ≡ ninety-two → mc91 n ≡ ninety-one
mc91-res-92' refl = mc91-res-92

mc91-res-91' : ∀ {n} → n ≡ ninety-one → mc91 n ≡ ninety-one
mc91-res-91' refl = mc91-res-91

mc91-res-90' : ∀ {n} → n ≡ ninety → mc91 n ≡ ninety-one
mc91-res-90' refl = mc91-res-90


correct list of theorems

correct list of theorems

Old-commit-hash: c915c2bba4a8fd18c2b4d5af429fdedf6042ca83

module PLDI14-List-of-Theorems where

open import Function

-- List of theorems in PLDI submission
--
-- For hints about installation and execution, please refer
-- to README.agda.
--
-- Agda modules corresponding to definitions, lemmas and theorems
-- are listed here with the most important name. For example,
-- after this file type checks (C-C C-L), placing the cursor
-- on the purple "Base.Change.Algebra" and pressing M-. will
-- bring you to the file where change structures are defined.
-- The name for change structures in that file is
-- "ChangeAlgebra", given in the using-clause.

-- Definition 2.1 (Change structures)
-- (d) ChangeAlgebra.diff
-- (e) IsChangeAlgebra.update-diff
open import Base.Change.Algebra using (ChangeAlgebra)
---- Carrier in record ChangeAlgebra                        --(a)
open Base.Change.Algebra.ChangeAlgebra   using (Change)     --(b)
open Base.Change.Algebra.ChangeAlgebra   using (update)     --(c)
open Base.Change.Algebra.ChangeAlgebra   using (diff)       --(d)
open Base.Change.Algebra.IsChangeAlgebra using (update-diff)--(e)

-- Definition 2.2 (Nil change)
-- IsChangeAlgebra.nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Lemma 2.3 (Behavior of nil)
-- IsChangeAlgebra.update-nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Definition 2.4 (Derivatives)
open Base.Change.Algebra using (Derivative)

-- Definition 2.5 (Carrier set of function changes)
open Base.Change.Algebra.FunctionChanges

-- Definition 2.6 (Operations on function changes)
-- ChangeAlgebra.update FunctionChanges.changeAlgebra
-- ChangeAlgebra.diff   FunctionChanges.changeAlgebra
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Theorem 2.7 (Function changes form a change structure)
-- (In Agda, the proof of Theorem 2.7 has to be included in the
-- definition of function changes, here
-- FunctionChanges.changeAlgebra.)
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Lemma 2.8 (Incrementalization)
open Base.Change.Algebra.FunctionChanges using (incrementalization)

-- Theorem 2.9 (Nil changes are derivatives)
open Base.Change.Algebra.FunctionChanges using (nil-is-derivative)

-- For each plugin requirement, we include its definition and
-- a concrete instantiation called "Popl14" with integers and
-- bags of integers as base types.

-- Plugin Requirement 3.1 (Domains of base types)
open import Parametric.Denotation.Value using (Structure)
open import     Popl14.Denotation.Value using (⟦_⟧Base)

-- Definition 3.2 (Domains)
open Parametric.Denotation.Value.Structure using (⟦_⟧Type)

-- Plugin Requirement 3.3 (Evaluation of constants)
open import Parametric.Denotation.Evaluation using (Structure)
open import     Popl14.Denotation.Evaluation using (⟦_⟧Const)

-- Definition 3.4 (Environments)
open import Base.Denotation.Environment using (⟦_⟧Context)

-- Definition 3.5 (Evaluation)
open Parametric.Denotation.Evaluation.Structure using (⟦_⟧Term)

-- Plugin Requirement 3.6 (Changes on base types)
open import Parametric.Change.Validity using (Structure)
open import     Popl14.Change.Validity using (change-algebra-base-family)

-- Definition 3.7 (Changes)
open Parametric.Change.Validity.Structure using (change-algebra)

-- Definition 3.8 (Change environments)
open Parametric.Change.Validity.Structure using (environment-changes)

-- Plugin Requirement 3.9 (Change semantics for constants)
open import Parametric.Change.Specification using (Structure)
open import     Popl14.Change.Specification using (specification-structure)

-- Definition 3.10 (Change semantics)
open Parametric.Change.Specification.Structure using (⟦_⟧Δ)

-- Lemma 3.11 (Change semantics is the derivative of semantics)
open Parametric.Change.Specification.Structure using (correctness)

-- Definition 3.12 (Erasure)
import Parametric.Change.Implementation
open Parametric.Change.Implementation.Structure using (_≈_)
open import Popl14.Change.Implementation using (implements-base)

-- Lemma 3.13 (The erased version of a change is almost the same)
open Parametric.Change.Implementation.Structure using (carry-over)

-- Lemma 3.14 (⟦ t ⟧Δ erases to Derive(t))
import Parametric.Change.Correctness
open Parametric.Change.Correctness.Structure using (derive-correct-closed)

-- Theorem 3.15 (Correctness of differentiation)
open Parametric.Change.Correctness.Structure using (main-theorem)

module PLDI14-List-of-Theorems where

open import Function

-- List of theorems in PLDI submission
--
-- For hints about installation and execution, please refer
-- to README.agda.
--
-- Agda modules corresponding to definitions, lemmas and theorems
-- are listed here with the most important name. For example,
-- after this file type checks (C-C C-L), placing the cursor
-- on the purple "Base.Change.Algebra" and pressing M-. will
-- bring you to the file where change structures are defined.
-- The name for change structures in that file is
-- "ChangeAlgebra", given in the using-clause.

-- Definition 2.1 (Change structures)
-- (d) ChangeAlgebra.diff
-- (e) IsChangeAlgebra.update-diff
open import Base.Change.Algebra using (ChangeAlgebra)
---- Carrier in record ChangeAlgebra                        --(a)
open Base.Change.Algebra.ChangeAlgebra   using (Change)     --(b)
open Base.Change.Algebra.ChangeAlgebra   using (update)     --(c)
open Base.Change.Algebra.ChangeAlgebra   using (diff)       --(d)
open Base.Change.Algebra.IsChangeAlgebra using (update-diff)--(e)

-- Definition 2.2 (Nil change)
-- IsChangeAlgebra.nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Lemma 2.3 (Behavior of nil)
-- IsChangeAlgebra.update-nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Definition 2.4 (Derivatives)
open Base.Change.Algebra using (Derivative)

-- Definition 2.5 (Carrier set of function changes)
open Base.Change.Algebra.FunctionChanges

-- Definition 2.6 (Operations on function changes)
-- ChangeAlgebra.update FunctionChanges.changeAlgebra
-- ChangeAlgebra.diff   FunctionChanges.changeAlgebra
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Theorem 2.7 (Function changes form a change structure)
-- (In Agda, the proof of Theorem 2.7 has to be included in the
-- definition of function changes, here
-- FunctionChanges.changeAlgebra.)
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Lemma 2.8 (Incrementalization)
open Base.Change.Algebra.FunctionChanges using (incrementalization)

-- Theorem 2.9 (Nil changes are derivatives)
open Base.Change.Algebra.FunctionChanges using (nil-is-derivative)

-- For each plugin requirement, we include its definition and
-- a concrete instantiation called "Popl14" with integers and
-- bags of integers as base types.

-- Plugin Requirement 3.1 (Domains of base types)
open import Parametric.Denotation.Value using (Structure)
open import     Popl14.Denotation.Value using (⟦_⟧Base)

-- Definition 3.2 (Domains)
open Parametric.Denotation.Value.Structure using (⟦_⟧Type)

-- Plugin Requirement 3.3 (Evaluation of constants)
open import Parametric.Denotation.Evaluation using (Structure)
open import     Popl14.Denotation.Evaluation using (⟦_⟧Const)

-- Definition 3.4 (Environments)
open import Base.Denotation.Environment using (⟦_⟧Context)

-- Definition 3.5 (Evaluation)
open Parametric.Denotation.Evaluation.Structure using (⟦_⟧Term)

-- Plugin Requirement 3.6 (Changes on base types)
open import Parametric.Change.Validity using (Structure)
open import     Popl14.Change.Validity using (change-algebra-base-family)

-- Definition 3.7 (Changes)
open Parametric.Change.Validity.Structure using (change-algebra)

-- Definition 3.8 (Change environments)
open Parametric.Change.Validity.Structure using (environment-changes)

-- Plugin Requirement 3.9 (Change semantics for constants)
open import Parametric.Change.Specification using (Structure)
open import     Popl14.Change.Specification using (specification-structure)

-- Definition 3.10 (Change semantics)
open Parametric.Change.Specification.Structure using (⟦_⟧Δ)

-- Lemma 3.11 (Change semantics is the derivative of semantics)
open Parametric.Change.Specification.Structure using (correctness)

-- Definition 3.12 (Erasure)
import Parametric.Change.Implementation
open Parametric.Change.Implementation.Structure using (_≈_)
open import Popl14.Change.Implementation using (implements-base)

-- Lemma 3.13 (The erased version of a change is almost the same)
open Parametric.Change.Implementation.Structure using (carry-over)

-- Lemma 3.14 (⟦ t ⟧Δ erases to Derive(t))
import Parametric.Change.Correctness
open Parametric.Change.Correctness.Structure using (main-theorem)


Maybe: monad things

Maybe: monad things

module Data.Maybe.NP where

open import Type hiding (★)
open import Function
import Level as L
open L using (_⊔_; lift; Lift)
open import Data.Maybe public
open import Algebra
open import Algebra.Structures
open import Algebra.FunctionProperties
open import Category.Applicative
import      Category.Monad as Cat
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_;_≗_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Logical
open import Relation.Unary.Logical
open import Function using (_$_;flip;id)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; zero; suc; _+_)

Π? : ∀ {a b} (A : ★ a) (B : A → ★ b) → ★ _
Π? A B = (x : A) → Maybe (B x)

infixr 0 _→?_
_→?_ : ∀ {a b} → ★ a → ★ b → ★ _
A →? B = A → Maybe B

module M? ℓ where
  open Cat.RawMonadPlus (monadPlus {ℓ}) public
  applicative = rawIApplicative

open M? public using (applicative)

infixl 4 _⊛?_

-- More universe-polymorphic than M?._⊛_
_⊛?_ : ∀ {a b}{A : ★ a}{B : ★ b} → Maybe (A → B) → Maybe A → Maybe B
just f  ⊛? just x = just (f x)
_       ⊛? _      = nothing

infixl 1 _>>=?_

-- More universe-polymorphic than M?._>>=_
_>>=?_ : ∀ {a b} {A : ★ a} {B : ★ b} → Maybe A → (A → Maybe B) → Maybe B
mx >>=? f = maybe f nothing mx

infixr 1 _=<<?_

-- More universe-polymorphic than M?._=<<_
_=<<?_ : ∀ {a b} {A : ★ a} {B : ★ b} → (A → Maybe B) → Maybe A → Maybe B
f =<<? mx = mx >>=? f

-- More universe-polymorphic than M?._<$>_
map? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
map? f mx = mx >>=? (just ∘ f)

_<$?_ : ∀ {a b} {A : ★ a} {B : ★ b} → A → Maybe B → Maybe A
_<$?_ x = map? (const x)

⟪_·_⟫? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
⟪ f · x ⟫? = map? f x

⟪_·_·_⟫? : ∀ {a b c}
             {A : ★ a} {B : ★ b} {C : ★ c} →
             (A → B → C) → Maybe A → Maybe B → Maybe C
⟪ f · x · y ⟫? = map? f x ⊛? y

⟪_·_·_·_⟫? : ∀ {a b c d}
               {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             → (A → B → C → D)
             → Maybe A → Maybe B → Maybe C → Maybe D
⟪ f · x · y · z ⟫? = map? f x ⊛? y ⊛? z

join? : ∀ {a} {A : ★ a} → Maybe (Maybe A) → Maybe A
join? = _=<<?_ id

Maybe^ : ∀ {a} → ℕ → ★ a → ★ a
Maybe^ zero    = id
Maybe^ (suc n) = Maybe ∘ Maybe^ n

just^ : ∀ {a} {A : ★ a} n → A → Maybe^ n A
just^ zero x = x
just^ (suc n) x = just (just^ n x)

Maybe^-∘-+ : ∀ {a} m n (A : ★ a) → Maybe^ m (Maybe^ n A) ≡ Maybe^ (m + n) A
Maybe^-∘-+ zero    _ _ = ≡.refl
Maybe^-∘-+ (suc m) _ _ = ≡.cong Maybe (Maybe^-∘-+ m _ _)

just-injective : ∀ {a} {A : ★ a} {x y : A}
                 → Maybe.just x ≡ just y → x ≡ y
just-injective ≡.refl = ≡.refl

maybe-just-nothing : ∀ {a} {A : ★ a} → maybe {A = A} just nothing ≗ id
maybe-just-nothing (just _)  = ≡.refl
maybe-just-nothing nothing   = ≡.refl

_≡JAll_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAll y = All (λ y' → All (_≡_ y') y) x

_≡JAny_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAny y = Any (λ y' → Any (_≡_ y') y) x

≡JAll-refl : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡JAll x
≡JAll-refl {x = just x}  = just (just ≡.refl)
≡JAll-refl {x = nothing} = nothing

just? : ∀ {a} {A : ★ a} → Maybe A → ★₀
just? nothing  = ⊥
just? (just _) = ⊤

just?→IsJust : ∀ {a} {A : ★ a} {x : Maybe A} → just? x → IsJust x
just?→IsJust {x = just _}  p = just _
just?→IsJust {x = nothing} ()

Any→just? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → just? x
Any→just? (just _) = _

data [Maybe] {a p} {A : ★ a} (Aₚ : A → ★ p) : Maybe A → ★ (a ⊔ p) where
  nothing : [Maybe] Aₚ nothing
  just    : (Aₚ [→] [Maybe] Aₚ) just

[maybe] : ∀ {a b} → (∀⟨ Aₚ ∶ [★] a ⟩[→] (∀⟨ Bₚ ∶ [★] b ⟩[→] ((Aₚ [→] Bₚ) [→] (Bₚ [→] ([Maybe] Aₚ [→] Bₚ)))))
                     (maybe {a} {b})
[maybe] _ _ justₚ nothingₚ (just xₚ) = justₚ xₚ
[maybe] _ _ justₚ nothingₚ nothing   = nothingₚ

[map?] : ∀ {a b} → (∀⟨ Aₚ ∶ [★] a ⟩[→] ∀⟨ Bₚ ∶ [★] b ⟩[→] (Aₚ [→] Bₚ) [→] [Maybe] Aₚ [→] [Maybe] Bₚ) (map? {a} {b})
[map?] _ _ fₚ (just xₚ) = just (fₚ xₚ)
[map?] _ _ fₚ nothing   = nothing

data ⟦Maybe⟧ {a b r} {A : ★ a} {B : ★ b} (_∼_ : A → B → ★ r) : Maybe A → Maybe B → ★ (a ⊔ b ⊔ r) where
  just    : ∀ {x₁ x₂} → (xᵣ : x₁ ∼ x₂) → ⟦Maybe⟧ _∼_ (just x₁) (just x₂)
  nothing : ⟦Maybe⟧ _∼_ nothing nothing

⟦maybe⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦★⟧ a ⟩⟦→⟧ (∀⟨ Bᵣ ∶ ⟦★⟧ b ⟩⟦→⟧ ((Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Bᵣ ⟦→⟧ (⟦Maybe⟧ Aᵣ ⟦→⟧ Bᵣ)))))
                     (maybe {a} {b}) (maybe {a} {b})
⟦maybe⟧ _ _ justᵣ nothingᵣ (just xᵣ) = justᵣ xᵣ
⟦maybe⟧ _ _ justᵣ nothingᵣ nothing   = nothingᵣ

⟦map?⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦★⟧ a ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦★⟧ b ⟩⟦→⟧ (Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ ⟦Maybe⟧ Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ) (map? {a} {b}) (map? {a} {b})
⟦map?⟧ _ _ fᵣ (just xᵣ) = just (fᵣ xᵣ)
⟦map?⟧ _ _ fᵣ nothing   = nothing

⟦map?-id⟧ : ∀ {a} → (∀⟨ Aᵣ ∶ ⟦★⟧ {a} {a} a ⟩⟦→⟧ ⟦Maybe⟧ Aᵣ ⟦→⟧ ⟦Maybe⟧ Aᵣ) (map? id) id
⟦map?-id⟧ _ (just xᵣ) = just xᵣ
⟦map?-id⟧ _ nothing   = nothing

Any-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any (Any P) x → Any P (join? x)
Any-join? (just p) = p

All-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All (All P) x → All P (join? x)
All-join? (just p) = p
All-join? nothing  = nothing

Any-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P (join? x) → Any (Any P) x
Any-join?′ {x = just x}  p = just p
Any-join?′ {x = nothing} ()

All-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All P (join? x) → All (All P) x
All-join?′ {x = just x}  p       = just p
All-join?′ {x = nothing} nothing = nothing

Any→IsJust : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → IsJust x
Any→IsJust (just _) = just _

just≡→just? : ∀ {a} {A : ★ a} {x} {y : A} → x ≡ just y → just? x
just≡→just? ≡.refl = _

just?-join? : ∀ {a} {A : ★ a} {x : Maybe (Maybe A)} → just? (join? x) → just? x
just?-join? = Any→just? ∘ Any-join?′ ∘ just?→IsJust

Any-just?-join? : ∀ {A : ★₀} (x : Maybe (Maybe A)) → just? (join? x) → Any just? x
Any-just?-join? (just (just _)) _ = just _
Any-just?-join? (just nothing)  ()
Any-just?-join? nothing         ()

just?-map? : ∀ {a b} {A : ★ a} {B : ★ b} (f : A → B)
               (x : Maybe A) → just? (map? f x) → just? x
just?-map? f (just x) pf = _
just?-map? f nothing  ()

infix 4 _≗?_

_≗?_ : ∀ {a b} {A : ★ a} {B : ★ b} →
         (f g : A →? B) → ★ _
(f ≗? g) = ∀ x → f x ≡JAll g x

_∘?_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
       → B →? C → A →? B → A →? C
(f ∘? g) x = g x >>=? f

∘?-just : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → f ∘? just ≗? f
∘?-just f x = ≡JAll-refl

just-∘? : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → just ∘? f ≗? f
just-∘? f x with f x
just-∘? f x | just _  = just (just ≡.refl)
just-∘? f x | nothing = nothing

∘?-assoc : ∀ {a b c d} {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             (f : C →? D) (g : B →? C) (h : A →? B)
             → (f ∘? g) ∘? h ≗ f ∘? (g ∘? h)
∘?-assoc f g h x with h x
∘?-assoc f g h x | just _  = ≡.refl
∘?-assoc f g h x | nothing = ≡.refl

T[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T[_] {A = A} {B} f? = (x : A) → .{pf : just? (f? x)} → B

F[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T[ f? ]
F[ f? ] x {pf} with f? x
F[ f? ] x      | just r  = r
F[ f? ] x {()} | nothing

T'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T'[_] {A = A} {B} f? = (x : A) → IsJust (f? x) → B

F'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T'[ f? ]
F'[ f? ] x pf with f? x
F'[ f? ] x (just {y} _) | .(just y) = y

-- F[ f? ] ⟶ F'[ f? ]

module F[] where
    _[≗]_ : ∀ {a b} {A : ★ a} {B : ★ b}
              {f? g? : A →? B}
              (f : T[ f? ]) (g : T[ g? ]) → ★ _
    f [≗] g = ∀ x {pf1} {pf2} → f x {pf1} ≡ g x {pf2}

    [id] : ∀ {a} {A : ★ a} → T[ just {A = A} ]
    [id] = F[ just ]

    {- might actually be wrong
    []-just-≡ : ∀ {a b} {A : ★ a} {B : ★ b} {f? : A →? B} (f : T[ f? ]) {x} (pf : just? (f? x)) → just (f x {pf}) ≡ f? x
    []-just-≡ {f? = f?} f {x} pf = {!!}
    -}

    _[∘]_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
              {f? : B →? C} {g? : A →? B}
            → T[ f? ] → T[ g? ] → T[ f? ∘? g? ]
    _[∘]_ {f? = f?} {g?} f g x {pf} with g? x
    _[∘]_ f g x {pf} | just y  = f y {pf}
    _[∘]_ f g x {()} | nothing

    {-
    [id]-[∘] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (F[ just ] [∘] f) [≗] f
    [id]-[∘] {f? = f?} f x {pf1} {pf2} = just-injective {!(≡.sym (≡.trans ([]-just-≡ f pf2) ?))!}
    -}

    [∘]-[id] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (f [∘] [id]) [≗] f
    [∘]-[id] {f? = f?} f x {pf1} {pf2} = ≡.refl

_[→?]_ : ∀ {a b pa pb} → ([★] {a} pa [→] [★] {b} pb [→] [★] _) _→?_
Aₚ [→?] Bₚ = Aₚ [→] [Maybe] Bₚ

_⟦→?⟧_ : ∀ {a0 a1 ar b0 b1 br} → (⟦★⟧ {a0} {a1} ar ⟦→⟧ ⟦★⟧ {b0} {b1} br ⟦→⟧ ⟦★⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

module ⟦Maybe⟧-Properties where

  refl : ∀ {a p} {A : ★ a} {_∼_ : A → A → ★ p} (refl-A : ∀ x → x ∼ x) (mx : Maybe A) → ⟦Maybe⟧ _∼_ mx mx
  refl refl-A (just x) = just (refl-A x)
  refl refl-A nothing  = nothing

  sym : ∀ {a b r₁ r₂} {A : ★ a} {B : ★ b} {_∼₁_ : A → B → ★ r₁} {_∼₂_ : B → A → ★ r₂}
          (sym-AB : ∀ {x y} → x ∼₁ y → y ∼₂ x) {mx : Maybe A} {my : Maybe B}
        → ⟦Maybe⟧ _∼₁_ mx my → ⟦Maybe⟧ _∼₂_ my mx
  sym sym-A (just x∼₁y) = just (sym-A x∼₁y)
  sym sym-A nothing     = nothing

  trans : ∀ {a b c r₁ r₂ r₃} {A : ★ a} {B : ★ b} {C : ★ c}
            {_⟦AB⟧_ : A → B → ★ r₁}
            {_⟦BC⟧_ : B → C → ★ r₂}
            {_⟦AC⟧_ : A → C → ★ r₃}
            (trans : ∀ {x y z} → x ⟦AB⟧ y → y ⟦BC⟧ z → x ⟦AC⟧ z)
            {mx : Maybe A} {my : Maybe B} {mz : Maybe C}
          → ⟦Maybe⟧ _⟦AB⟧_ mx my → ⟦Maybe⟧ _⟦BC⟧_ my mz
          → ⟦Maybe⟧ _⟦AC⟧_ mx mz
  trans trans' (just x∼y) (just y∼z) = just (trans' x∼y y∼z)
  trans trans' nothing    nothing    = nothing

  subst-⟦AB⟧ : ∀ {a b p q r} {A : ★ a} {B : ★ b}
                 (P : Maybe A → ★ p)
                 (Q : Maybe B → ★ q)
                 (⟦AB⟧ : A → B → ★ r)
                 (subst-⟦AB⟧-just : ∀ {x y} → ⟦AB⟧ x y → P (just x) → Q (just y))
                 (Pnothing→Qnothing : P nothing → Q nothing)
                 {mx : Maybe A} {my : Maybe B}
               → (⟦Maybe⟧ ⟦AB⟧ mx my) → P mx → Q my
  subst-⟦AB⟧ _ _ _ subst-⟦AB⟧-just _ (just x∼y) Pmx = subst-⟦AB⟧-just x∼y Pmx
  subst-⟦AB⟧ _ _ _ _               f nothing    Pnothing = f Pnothing

  subst : ∀ {a p r} {A : ★ a}
            (P : Maybe A → ★ p)
            (Aᵣ : A → A → ★ r)
            (subst-Aᵣ : ∀ {x y} → Aᵣ x y → P (just x) → P (just y))
            {mx my}
          → (⟦Maybe⟧ Aᵣ mx my) → P mx → P my
  subst P Aᵣ subst-Aᵣ = subst-⟦AB⟧ P P Aᵣ subst-Aᵣ id

IsNothing'≡nothing : ∀ {a} {A : ★ a} {x : Maybe A} → IsNothing x → x ≡ nothing
IsNothing'≡nothing nothing = ≡.refl
IsNothing'≡nothing (just (lift ()))

≡nothing'IsNothing : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡ nothing → IsNothing x
≡nothing'IsNothing ≡.refl = nothing

module FunctorLemmas {a} where
  open M? a

  <$>-injective₁ : ∀ {A B}
                     {f : A → B} {x y : Maybe A}
                     (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y)
                   → f <$> x ≡ f <$> y → x ≡ y
  <$>-injective₁ {x = just _}  {just _}  f-inj eq = ≡.cong just (f-inj (just-injective eq))
  <$>-injective₁ {x = nothing} {nothing} _     _  = ≡.refl
  <$>-injective₁ {x = just _}  {nothing} _     ()
  <$>-injective₁ {x = nothing} {just _}  _     ()

  <$>-assoc : ∀ {A B C} {f : A → B} {g : C → A} (x : Maybe C) → f ∘ g <$> x ≡ f <$> (g <$> x)
  <$>-assoc (just _) = ≡.refl
  <$>-assoc nothing  = ≡.refl

module MonadLemmas {a} where

  open M? a public
 --  open RawApplicative applicative public

  cong-Maybe : ∀ {A B}
                 (f : A → B) {x y} → x ≡ pure y → f <$> x ≡ pure (f y)
  cong-Maybe f ≡.refl = ≡.refl

  cong₂-Maybe : ∀ {A B C}
                  (f : A → B → C) {x y u v} → x ≡ pure y → u ≡ pure v → pure f ⊛ x ⊛ u ≡ pure (f y v)
  cong₂-Maybe f ≡.refl ≡.refl = ≡.refl

  Maybe-comm-monad :
    ∀ {A B C} {x y} {f : A → B → Maybe C} →
      (x >>= λ x' → y >>= λ y' → f x' y')
    ≡ (y >>= λ y' → x >>= λ x' → f x' y')
  Maybe-comm-monad {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-monad {x = nothing} {just _}   = ≡.refl
  Maybe-comm-monad {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-monad {x = just _}  {just _}   = ≡.refl

  Maybe-comm-appl : ∀ {A B} {f : Maybe (A → B)} {x} → f ⊛ x ≡ (flip _$_) <$> x ⊛ f
  Maybe-comm-appl {f = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl {f = nothing} {just _}   = ≡.refl
  Maybe-comm-appl {f = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl {f = just _}  {just _}   = ≡.refl

  Maybe-comm-appl₂ : ∀ {A B C} {f : A → B → C} {x y} → f <$> x ⊛ y ≡ flip f <$> y ⊛ x
  Maybe-comm-appl₂ {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = nothing} {just _}   = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {just _}   = ≡.refl

module MonoidFromSemigroup {c ℓ} (sg   : Semigroup c ℓ)
                                 {_≈?_ : let open Semigroup sg
                                         in Maybe Carrier → Maybe Carrier → ★ ℓ}
                                 (isEquivalence : IsEquivalence _≈?_)
                                 (just-cong : let open Semigroup sg in
                                              just Preserves _≈_ ⟶ _≈?_)
                                 (just-inj  : let open Semigroup sg in
                                              (_≈?_ on just) ⇒ _≈_)
                                 (just≉nothing : ∀ {x} → ¬(just x ≈? nothing)) where
  private
    module SG = Semigroup sg
    open SG using (_≈_) renaming (Carrier to A; _∙_ to op)
    module ≈  = IsEquivalence SG.isEquivalence
    module ≈? = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    just x  ∙ just y  = just (op x y)
    just x  ∙ nothing = just x
    nothing ∙ y?      = y?

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈?_ _∙_
    assoc (just x) (just y) (just z) = just-cong (SG.assoc x y z)
    assoc (just _) (just _) nothing  = ≈?.refl
    assoc (just _) nothing  _        = ≈?.refl
    assoc nothing  _        _        = ≈?.refl

    right-identity : RightIdentity _≈?_ ε _∙_
    right-identity (just _) = ≈?.refl
    right-identity nothing  = ≈?.refl

    ∙-cong : _∙_ Preserves₂ _≈?_ ⟶ _≈?_ ⟶ _≈?_
    ∙-cong {just _}{just _}{just _}{just _}   p q
      = just-cong (SG.∙-cong (just-inj p) (just-inj q))
    ∙-cong {just _}{just _}{just _}{nothing}  p q = ⊥-elim (just≉nothing q)
    ∙-cong {just _}{just _}{nothing}{just _}  p q = ⊥-elim (just≉nothing (≈?.sym q))
    ∙-cong {just _}{just _}{nothing}{nothing} p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _}  {nothing} p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈?.sym p))

  monoid : Monoid c ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈?_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈?.refl) , right-identity } }

  open Monoid monoid public

module Monoid-≡ {a} {A : ★ a} {op : Op₂ A} (isSg : IsSemigroup _≡_ op)
  = MonoidFromSemigroup (record { isSemigroup = isSg })
                        ≡.isEquivalence (≡.cong just) just-injective

module First-≈ {a ℓ} {A : ★ a} {_≈_ : Maybe A → Maybe A → ★ ℓ}
               (isEquivalence : IsEquivalence _≈_)
               (just≉nothing : ∀ {x} → ¬(just x ≈ nothing)) where
  private
    module ≈ = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    x ∙ y = maybe just y x

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈_ _∙_
    assoc (just _) _ _ = ≈.refl
    assoc nothing  _ _ = ≈.refl

    right-identity : RightIdentity _≈_ ε _∙_
    right-identity (just _) = ≈.refl
    right-identity nothing  = ≈.refl

    ∙-cong : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
    ∙-cong {just _} {just _}   p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _} {nothing}  p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈.sym p))

  monoid : Monoid a ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈.refl) , right-identity } }

  open Monoid monoid public

module First {a} (A : ★ a) = First-≈ {A = A} ≡.isEquivalence (λ())
-- -}

module Data.Maybe.NP where

open import Type hiding (★)
open import Function
import Level as L
open L using (_⊔_; lift; Lift)
open import Data.Maybe public
open import Algebra
open import Algebra.Structures
open import Algebra.FunctionProperties
open import Category.Applicative
import      Category.Monad as Cat
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_;_≗_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Logical
open import Relation.Unary.Logical
open import Function using (_$_;flip;id)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; zero; suc; _+_)

Π? : ∀ {a b} (A : ★ a) (B : A → ★ b) → ★ _
Π? A B = (x : A) → Maybe (B x)

infixr 0 _→?_
_→?_ : ∀ {a b} → ★ a → ★ b → ★ _
A →? B = A → Maybe B

module M? ℓ where
  open Cat.RawMonadPlus (monadPlus {ℓ}) public
  applicative = rawIApplicative

open M? public using (applicative)

infixl 4 _⊛?_

-- More universe-polymorphic than M?._⊛_
_⊛?_ : ∀ {a b}{A : ★ a}{B : ★ b} → Maybe (A → B) → Maybe A → Maybe B
just f  ⊛? just x = just (f x)
_       ⊛? _      = nothing

-- More universe-polymorphic than M?._<$>_
map? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
map? f = maybe (just ∘′ f) nothing

⟪_·_⟫? : ∀ {a b} {A : ★ a} {B : ★ b} → (A → B) → Maybe A → Maybe B
⟪ f · x ⟫? = map? f x

⟪_·_·_⟫? : ∀ {a b c}
             {A : ★ a} {B : ★ b} {C : ★ c} →
             (A → B → C) → Maybe A → Maybe B → Maybe C
⟪ f · x · y ⟫? = map? f x ⊛? y

⟪_·_·_·_⟫? : ∀ {a b c d}
               {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             → (A → B → C → D)
             → Maybe A → Maybe B → Maybe C → Maybe D
⟪ f · x · y · z ⟫? = map? f x ⊛? y ⊛? z

join? : ∀ {a} {A : ★ a} → Maybe (Maybe A) → Maybe A
join? = M?.join _

Maybe^ : ∀ {a} → ℕ → ★ a → ★ a
Maybe^ zero    = id
Maybe^ (suc n) = Maybe ∘ Maybe^ n

just^ : ∀ {a} {A : ★ a} n → A → Maybe^ n A
just^ zero x = x
just^ (suc n) x = just (just^ n x)

Maybe^-∘-+ : ∀ {a} m n (A : ★ a) → Maybe^ m (Maybe^ n A) ≡ Maybe^ (m + n) A
Maybe^-∘-+ zero    _ _ = ≡.refl
Maybe^-∘-+ (suc m) _ _ = ≡.cong Maybe (Maybe^-∘-+ m _ _)

just-injective : ∀ {a} {A : ★ a} {x y : A}
                 → Maybe.just x ≡ just y → x ≡ y
just-injective ≡.refl = ≡.refl

maybe-just-nothing : ∀ {a} {A : ★ a} → maybe {A = A} just nothing ≗ id
maybe-just-nothing (just _)  = ≡.refl
maybe-just-nothing nothing   = ≡.refl

_≡JAll_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAll y = All (λ y' → All (_≡_ y') y) x

_≡JAny_ : ∀ {a} {A : ★ a} (x y : Maybe A) → ★ a
x ≡JAny y = Any (λ y' → Any (_≡_ y') y) x

≡JAll-refl : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡JAll x
≡JAll-refl {x = just x}  = just (just ≡.refl)
≡JAll-refl {x = nothing} = nothing

just? : ∀ {a} {A : ★ a} → Maybe A → ★₀
just? nothing  = ⊥
just? (just _) = ⊤

just?→IsJust : ∀ {a} {A : ★ a} {x : Maybe A} → just? x → IsJust x
just?→IsJust {x = just _}  p = just _
just?→IsJust {x = nothing} ()

Any→just? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → just? x
Any→just? (just _) = _

data [Maybe] {a p} {A : ★ a} (Aₚ : A → ★ p) : Maybe A → ★ (a ⊔ p) where
  nothing : [Maybe] Aₚ nothing
  just    : (Aₚ [→] [Maybe] Aₚ) just

[maybe] : ∀ {a b} → (∀⟨ Aₚ ∶ [★] a ⟩[→] (∀⟨ Bₚ ∶ [★] b ⟩[→] ((Aₚ [→] Bₚ) [→] (Bₚ [→] ([Maybe] Aₚ [→] Bₚ)))))
                     (maybe {a} {b})
[maybe] _ _ justₚ nothingₚ (just xₚ) = justₚ xₚ
[maybe] _ _ justₚ nothingₚ nothing   = nothingₚ

[map?] : ∀ {a b} → (∀⟨ Aₚ ∶ [★] a ⟩[→] ∀⟨ Bₚ ∶ [★] b ⟩[→] (Aₚ [→] Bₚ) [→] [Maybe] Aₚ [→] [Maybe] Bₚ) (map? {a} {b})
[map?] _ _ fₚ (just xₚ) = just (fₚ xₚ)
[map?] _ _ fₚ nothing   = nothing

data ⟦Maybe⟧ {a b r} {A : ★ a} {B : ★ b} (_∼_ : A → B → ★ r) : Maybe A → Maybe B → ★ (a ⊔ b ⊔ r) where
  just    : ∀ {x₁ x₂} → (xᵣ : x₁ ∼ x₂) → ⟦Maybe⟧ _∼_ (just x₁) (just x₂)
  nothing : ⟦Maybe⟧ _∼_ nothing nothing

⟦maybe⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦★⟧ a ⟩⟦→⟧ (∀⟨ Bᵣ ∶ ⟦★⟧ b ⟩⟦→⟧ ((Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Bᵣ ⟦→⟧ (⟦Maybe⟧ Aᵣ ⟦→⟧ Bᵣ)))))
                     (maybe {a} {b}) (maybe {a} {b})
⟦maybe⟧ _ _ justᵣ nothingᵣ (just xᵣ) = justᵣ xᵣ
⟦maybe⟧ _ _ justᵣ nothingᵣ nothing   = nothingᵣ

⟦map?⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦★⟧ a ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦★⟧ b ⟩⟦→⟧ (Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ ⟦Maybe⟧ Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ) (map? {a} {b}) (map? {a} {b})
⟦map?⟧ _ _ fᵣ (just xᵣ) = just (fᵣ xᵣ)
⟦map?⟧ _ _ fᵣ nothing   = nothing

⟦map?-id⟧ : ∀ {a} → (∀⟨ Aᵣ ∶ ⟦★⟧ {a} {a} a ⟩⟦→⟧ ⟦Maybe⟧ Aᵣ ⟦→⟧ ⟦Maybe⟧ Aᵣ) (map? id) id
⟦map?-id⟧ _ (just xᵣ) = just xᵣ
⟦map?-id⟧ _ nothing   = nothing

Any-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any (Any P) x → Any P (join? x)
Any-join? (just p) = p

All-join? : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All (All P) x → All P (join? x)
All-join? (just p) = p
All-join? nothing  = nothing

Any-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P (join? x) → Any (Any P) x
Any-join?′ {x = just x}  p = just p
Any-join?′ {x = nothing} ()

All-join?′ : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → All P (join? x) → All (All P) x
All-join?′ {x = just x}  p       = just p
All-join?′ {x = nothing} nothing = nothing

Any→IsJust : ∀ {a} {A : ★ a} {P : A → ★ a} {x} → Any P x → IsJust x
Any→IsJust (just _) = just _

just≡→just? : ∀ {a} {A : ★ a} {x} {y : A} → x ≡ just y → just? x
just≡→just? ≡.refl = _

just?-join? : ∀ {a} {A : ★ a} {x : Maybe (Maybe A)} → just? (join? x) → just? x
just?-join? = Any→just? ∘ Any-join?′ ∘ just?→IsJust

Any-just?-join? : ∀ {A : ★₀} (x : Maybe (Maybe A)) → just? (join? x) → Any just? x
Any-just?-join? (just (just _)) _ = just _
Any-just?-join? (just nothing)  ()
Any-just?-join? nothing         ()

just?-map? : ∀ {a b} {A : ★ a} {B : ★ b} (f : A → B)
               (x : Maybe A) → just? (map? f x) → just? x
just?-map? f (just x) pf = _
just?-map? f nothing  ()

infix 4 _≗?_

_≗?_ : ∀ {a b} {A : ★ a} {B : ★ b} →
         (f g : A →? B) → ★ _
(f ≗? g) = ∀ x → f x ≡JAll g x

_∘?_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
       → B →? C → A →? B → A →? C
f ∘? g = join? ∘ map? f ∘ g

∘?-just : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → f ∘? just ≗? f
∘?-just f x = ≡JAll-refl

just-∘? : ∀ {a b} {A : ★ a} {B : ★ b} →
            (f : A →? B) → just ∘? f ≗? f
just-∘? f x with f x
just-∘? f x | just _  = just (just ≡.refl)
just-∘? f x | nothing = nothing

∘?-assoc : ∀ {a b c d} {A : ★ a} {B : ★ b} {C : ★ c} {D : ★ d}
             (f : C →? D) (g : B →? C) (h : A →? B)
             → (f ∘? g) ∘? h ≗ f ∘? (g ∘? h)
∘?-assoc f g h x with h x
∘?-assoc f g h x | just _  = ≡.refl
∘?-assoc f g h x | nothing = ≡.refl

T[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T[_] {A = A} {B} f? = (x : A) → .{pf : just? (f? x)} → B

F[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T[ f? ]
F[ f? ] x {pf} with f? x
F[ f? ] x      | just r  = r
F[ f? ] x {()} | nothing

T'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → ★ (a L.⊔ b)
T'[_] {A = A} {B} f? = (x : A) → IsJust (f? x) → B

F'[_] : ∀ {a b} {A : ★ a} {B : ★ b} (f? : A →? B) → T'[ f? ]
F'[ f? ] x pf with f? x
F'[ f? ] x (just {y} _) | .(just y) = y

-- F[ f? ] ⟶ F'[ f? ]

module F[] where
    _[≗]_ : ∀ {a b} {A : ★ a} {B : ★ b}
              {f? g? : A →? B}
              (f : T[ f? ]) (g : T[ g? ]) → ★ _
    f [≗] g = ∀ x {pf1} {pf2} → f x {pf1} ≡ g x {pf2}

    [id] : ∀ {a} {A : ★ a} → T[ just {A = A} ]
    [id] = F[ just ]

    {- might actually be wrong
    []-just-≡ : ∀ {a b} {A : ★ a} {B : ★ b} {f? : A →? B} (f : T[ f? ]) {x} (pf : just? (f? x)) → just (f x {pf}) ≡ f? x
    []-just-≡ {f? = f?} f {x} pf = {!!}
    -}

    _[∘]_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
              {f? : B →? C} {g? : A →? B}
            → T[ f? ] → T[ g? ] → T[ f? ∘? g? ]
    _[∘]_ {f? = f?} {g?} f g x {pf} with g? x
    _[∘]_ f g x {pf} | just y  = f y {pf}
    _[∘]_ f g x {()} | nothing

    {-
    [id]-[∘] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (F[ just ] [∘] f) [≗] f
    [id]-[∘] {f? = f?} f x {pf1} {pf2} = just-injective {!(≡.sym (≡.trans ([]-just-≡ f pf2) ?))!}
    -}

    [∘]-[id] : ∀ {a b} {A : ★ a} {B : ★ b}
                 {f? : A →? B} (f : T[ f? ]) → (f [∘] [id]) [≗] f
    [∘]-[id] {f? = f?} f x {pf1} {pf2} = ≡.refl

_[→?]_ : ∀ {a b pa pb} → ([★] {a} pa [→] [★] {b} pb [→] [★] _) _→?_
Aₚ [→?] Bₚ = Aₚ [→] [Maybe] Bₚ

_⟦→?⟧_ : ∀ {a0 a1 ar b0 b1 br} → (⟦★⟧ {a0} {a1} ar ⟦→⟧ ⟦★⟧ {b0} {b1} br ⟦→⟧ ⟦★⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

module ⟦Maybe⟧-Properties where

  refl : ∀ {a p} {A : ★ a} {_∼_ : A → A → ★ p} (refl-A : ∀ x → x ∼ x) (mx : Maybe A) → ⟦Maybe⟧ _∼_ mx mx
  refl refl-A (just x) = just (refl-A x)
  refl refl-A nothing  = nothing

  sym : ∀ {a b r₁ r₂} {A : ★ a} {B : ★ b} {_∼₁_ : A → B → ★ r₁} {_∼₂_ : B → A → ★ r₂}
          (sym-AB : ∀ {x y} → x ∼₁ y → y ∼₂ x) {mx : Maybe A} {my : Maybe B}
        → ⟦Maybe⟧ _∼₁_ mx my → ⟦Maybe⟧ _∼₂_ my mx
  sym sym-A (just x∼₁y) = just (sym-A x∼₁y)
  sym sym-A nothing     = nothing

  trans : ∀ {a b c r₁ r₂ r₃} {A : ★ a} {B : ★ b} {C : ★ c}
            {_⟦AB⟧_ : A → B → ★ r₁}
            {_⟦BC⟧_ : B → C → ★ r₂}
            {_⟦AC⟧_ : A → C → ★ r₃}
            (trans : ∀ {x y z} → x ⟦AB⟧ y → y ⟦BC⟧ z → x ⟦AC⟧ z)
            {mx : Maybe A} {my : Maybe B} {mz : Maybe C}
          → ⟦Maybe⟧ _⟦AB⟧_ mx my → ⟦Maybe⟧ _⟦BC⟧_ my mz
          → ⟦Maybe⟧ _⟦AC⟧_ mx mz
  trans trans' (just x∼y) (just y∼z) = just (trans' x∼y y∼z)
  trans trans' nothing    nothing    = nothing

  subst-⟦AB⟧ : ∀ {a b p q r} {A : ★ a} {B : ★ b}
                 (P : Maybe A → ★ p)
                 (Q : Maybe B → ★ q)
                 (⟦AB⟧ : A → B → ★ r)
                 (subst-⟦AB⟧-just : ∀ {x y} → ⟦AB⟧ x y → P (just x) → Q (just y))
                 (Pnothing→Qnothing : P nothing → Q nothing)
                 {mx : Maybe A} {my : Maybe B}
               → (⟦Maybe⟧ ⟦AB⟧ mx my) → P mx → Q my
  subst-⟦AB⟧ _ _ _ subst-⟦AB⟧-just _ (just x∼y) Pmx = subst-⟦AB⟧-just x∼y Pmx
  subst-⟦AB⟧ _ _ _ _               f nothing    Pnothing = f Pnothing

  subst : ∀ {a p r} {A : ★ a}
            (P : Maybe A → ★ p)
            (Aᵣ : A → A → ★ r)
            (subst-Aᵣ : ∀ {x y} → Aᵣ x y → P (just x) → P (just y))
            {mx my}
          → (⟦Maybe⟧ Aᵣ mx my) → P mx → P my
  subst P Aᵣ subst-Aᵣ = subst-⟦AB⟧ P P Aᵣ subst-Aᵣ id

IsNothing'≡nothing : ∀ {a} {A : ★ a} {x : Maybe A} → IsNothing x → x ≡ nothing
IsNothing'≡nothing nothing = ≡.refl
IsNothing'≡nothing (just (lift ()))

≡nothing'IsNothing : ∀ {a} {A : ★ a} {x : Maybe A} → x ≡ nothing → IsNothing x
≡nothing'IsNothing ≡.refl = nothing

module FunctorLemmas {a} where
  open M? a

  <$>-injective₁ : ∀ {A B}
                     {f : A → B} {x y : Maybe A}
                     (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y)
                   → f <$> x ≡ f <$> y → x ≡ y
  <$>-injective₁ {x = just _}  {just _}  f-inj eq = ≡.cong just (f-inj (just-injective eq))
  <$>-injective₁ {x = nothing} {nothing} _     _  = ≡.refl
  <$>-injective₁ {x = just _}  {nothing} _     ()
  <$>-injective₁ {x = nothing} {just _}  _     ()

  <$>-assoc : ∀ {A B C} {f : A → B} {g : C → A} (x : Maybe C) → f ∘ g <$> x ≡ f <$> (g <$> x)
  <$>-assoc (just _) = ≡.refl
  <$>-assoc nothing  = ≡.refl

module MonadLemmas {a} where

  open M? a public
 --  open RawApplicative applicative public

  cong-Maybe : ∀ {A B}
                 (f : A → B) {x y} → x ≡ pure y → f <$> x ≡ pure (f y)
  cong-Maybe f ≡.refl = ≡.refl

  cong₂-Maybe : ∀ {A B C}
                  (f : A → B → C) {x y u v} → x ≡ pure y → u ≡ pure v → pure f ⊛ x ⊛ u ≡ pure (f y v)
  cong₂-Maybe f ≡.refl ≡.refl = ≡.refl

  Maybe-comm-monad :
    ∀ {A B C} {x y} {f : A → B → Maybe C} →
      (x >>= λ x' → y >>= λ y' → f x' y')
    ≡ (y >>= λ y' → x >>= λ x' → f x' y')
  Maybe-comm-monad {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-monad {x = nothing} {just _}   = ≡.refl
  Maybe-comm-monad {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-monad {x = just _}  {just _}   = ≡.refl

  Maybe-comm-appl : ∀ {A B} {f : Maybe (A → B)} {x} → f ⊛ x ≡ (flip _$_) <$> x ⊛ f
  Maybe-comm-appl {f = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl {f = nothing} {just _}   = ≡.refl
  Maybe-comm-appl {f = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl {f = just _}  {just _}   = ≡.refl

  Maybe-comm-appl₂ : ∀ {A B C} {f : A → B → C} {x y} → f <$> x ⊛ y ≡ flip f <$> y ⊛ x
  Maybe-comm-appl₂ {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = nothing} {just _}   = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {just _}   = ≡.refl

module MonoidFromSemigroup {c ℓ} (sg   : Semigroup c ℓ)
                                 {_≈?_ : let open Semigroup sg
                                         in Maybe Carrier → Maybe Carrier → ★ ℓ}
                                 (isEquivalence : IsEquivalence _≈?_)
                                 (just-cong : let open Semigroup sg in
                                              just Preserves _≈_ ⟶ _≈?_)
                                 (just-inj  : let open Semigroup sg in
                                              (_≈?_ on just) ⇒ _≈_)
                                 (just≉nothing : ∀ {x} → ¬(just x ≈? nothing)) where
  private
    module SG = Semigroup sg
    open SG using (_≈_) renaming (Carrier to A; _∙_ to op)
    module ≈  = IsEquivalence SG.isEquivalence
    module ≈? = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    just x  ∙ just y  = just (op x y)
    just x  ∙ nothing = just x
    nothing ∙ y?      = y?

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈?_ _∙_
    assoc (just x) (just y) (just z) = just-cong (SG.assoc x y z)
    assoc (just _) (just _) nothing  = ≈?.refl
    assoc (just _) nothing  _        = ≈?.refl
    assoc nothing  _        _        = ≈?.refl

    right-identity : RightIdentity _≈?_ ε _∙_
    right-identity (just _) = ≈?.refl
    right-identity nothing  = ≈?.refl

    ∙-cong : _∙_ Preserves₂ _≈?_ ⟶ _≈?_ ⟶ _≈?_
    ∙-cong {just _}{just _}{just _}{just _}   p q
      = just-cong (SG.∙-cong (just-inj p) (just-inj q))
    ∙-cong {just _}{just _}{just _}{nothing}  p q = ⊥-elim (just≉nothing q)
    ∙-cong {just _}{just _}{nothing}{just _}  p q = ⊥-elim (just≉nothing (≈?.sym q))
    ∙-cong {just _}{just _}{nothing}{nothing} p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _}  {nothing} p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈?.sym p))

  monoid : Monoid c ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈?_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈?.refl) , right-identity } }

  open Monoid monoid public

module Monoid-≡ {a} {A : ★ a} {op : Op₂ A} (isSg : IsSemigroup _≡_ op)
  = MonoidFromSemigroup (record { isSemigroup = isSg })
                        ≡.isEquivalence (≡.cong just) just-injective

module First-≈ {a ℓ} {A : ★ a} {_≈_ : Maybe A → Maybe A → ★ ℓ}
               (isEquivalence : IsEquivalence _≈_)
               (just≉nothing : ∀ {x} → ¬(just x ≈ nothing)) where
  private
    module ≈ = IsEquivalence isEquivalence
    _∙_ : Op₂ (Maybe A)
    x ∙ y = maybe just y x

    ε : Maybe A
    ε = nothing

    assoc : Associative _≈_ _∙_
    assoc (just _) _ _ = ≈.refl
    assoc nothing  _ _ = ≈.refl

    right-identity : RightIdentity _≈_ ε _∙_
    right-identity (just _) = ≈.refl
    right-identity nothing  = ≈.refl

    ∙-cong : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
    ∙-cong {just _} {just _}   p q = p
    ∙-cong {nothing} {nothing} p q = q
    ∙-cong {just _} {nothing}  p q = ⊥-elim (just≉nothing p)
    ∙-cong {nothing} {just _}  p q = ⊥-elim (just≉nothing (≈.sym p))

  monoid : Monoid a ℓ
  monoid = record { Carrier = Maybe A
                  ; _≈_ = _≈_
                  ; _∙_ = _∙_
                  ; ε = ε
                  ; isMonoid
                    = record { isSemigroup
                               = record { isEquivalence = isEquivalence
                                        ; assoc = assoc; ∙-cong = ∙-cong }
                             ; identity = (λ _ → ≈.refl) , right-identity } }

  open Monoid monoid public

module First {a} (A : ★ a) = First-≈ {A = A} ≡.isEquivalence (λ())


Added ListN-ind.

Added ListN-ind.

----------------------------------------------------------------------------
-- The FOTC lists of natural numbers type
----------------------------------------------------------------------------

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

module FOTC.Data.Nat.List.Type where

open import FOTC.Base
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- The FOTC lists of natural numbers type (inductive predicate for
-- total lists of natural numbers).
data ListN : D → Set where
  lnnil  :                             ListN []
  lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)
{-# ATP axiom lnnil lncons #-}

-- Induction principle.
ListN-ind : (A : D → Set) →
            A [] →
            (∀ {n ns} → N n → A ns → A (n ∷ ns)) →
            ∀ {ns} → ListN ns → A ns
ListN-ind A Anil h lnnil           = Anil
ListN-ind A Anil h (lncons Nn Lns) = h Nn (ListN-ind A Anil h Lns)


Added doc.

Added doc.

------------------------------------------------------------------------------
-- Induction principles for the total natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Nat.Type where

open import FOTC.Base

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

data N : D → Set where
  nzero : N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Induction principle generated by Coq when we define the data type N
-- in Prop.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- The induction principle removing the hypothesis N n from the
-- inductive step.
N-ind₂ : (A : D → Set) →
         A zero →
         (∀ {n} → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₂ A A0 h nzero      = A0
N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

-- N-ind₂ from N-ind₁.
N-ind₂' : (A : D → Set) →
          A zero →
          (∀ {n} → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₂' A A0 h = N-ind₁ A A0 (λ _ → h)

-- We cannot prove N-ind₁ from N-ind₂.
N-ind₁' : (A : D → Set) →
          A zero →
          (∀ {n} → N n → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₁' A A0 h = N-ind₂ A A0 {!!}

------------------------------------------------------------------------------
-- Induction principle for N.
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Nat.Type where

open import FOTC.Base

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

data N : D → Set where
  nzero : N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Induction principle generated by Coq when we define the data type N
-- in Prop.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- The induction principle removing the hypothesis N n from the
-- inductive step.
N-ind₂ : (A : D → Set) →
         A zero →
         (∀ {n} → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₂ A A0 h nzero      = A0
N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

-- N-ind₂ from N-ind₁.
N-ind₂' : (A : D → Set) →
          A zero →
          (∀ {n} → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₂' A A0 h = N-ind₁ A A0 (λ _ → h)

-- We cannot prove N-ind₁ from N-ind₂.
N-ind₁' : (A : D → Set) →
          A zero →
          (∀ {n} → N n → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₁' A A0 h = N-ind₂ A A0 {!!}