Added doc.

Added doc.

Ignore-this: da46b58650678e69c9a80286f1cc0110

darcs-hash:20110314164406-3bd4e-ac71ffe48514cfbaad3f2a6707d8086060d9ad1b.gz

------------------------------------------------------------------------------
-- Logical constants
------------------------------------------------------------------------------

module Common.LogicalConstants where

-- This module just exported all the logical constants.

------------------------------------------------------------------------------
-- The propositional logical connectives

-- The logical connectives are hard-coded in our translation,
-- i.e. the symbols ⊥, ⊤, ¬, ∧, ∨, →, and ↔ must be used.
-- N.B. For the implication we use the Agda function type.
open import Common.Data.Empty public using ( ⊥ ; ⊥-elim )
open import Common.Data.Product public using ( _∧_ ; _,_ ; ∧-proj₁ ; ∧-proj₂ )
open import Common.Data.Sum public using ( _∨_ ; [_,_] ; inj₁ ; inj₂ )
open import Common.Data.Unit public using ( ⊤ )
open import Common.Relation.Nullary public using ( ¬_ )

infixr 2 _↔_

_↔_ : Set → Set → Set
P ↔ Q = (P → Q) ∧ (Q → P)

------------------------------------------------------------------------------
-- The quantifiers

-- The existential quantifier
-- The existential quantifier is hard-coded in our translation,
-- i.e. the symbol ∃ must be used.

open import Common.Data.Product public using ( _,_ ; ∃ ; ∃-proj₁ ; ∃-proj₂ )

-- The universal quantifier
-- N.B. For the universal quantifier we use the Agda (dependent)
-- function type.

------------------------------------------------------------------------------
-- Logical constants
------------------------------------------------------------------------------

module Common.LogicalConstants where

-- This module just exported all the logical constants.

------------------------------------------------------------------------------
-- The logical connectives

-- The logical connectives are hard-coded in our translation,
-- i.e. the symbols ⊥, ⊤, ¬, ∧, ∨, →, and ↔ must be used.
-- For the implication we use the Agda function type.
open import Common.Data.Empty public using ( ⊥ ; ⊥-elim )
open import Common.Data.Product public using ( _∧_ ; _,_ ; ∧-proj₁ ; ∧-proj₂ )
open import Common.Data.Sum public using ( _∨_ ; [_,_] ; inj₁ ; inj₂ )
open import Common.Data.Unit public using ( ⊤ )
open import Common.Relation.Nullary public using ( ¬_ )

infixr 2 _↔_

_↔_ : Set → Set → Set
P ↔ Q = (P → Q) ∧ (Q → P)

------------------------------------------------------------------------------
-- The quantifiers

-- The existential quantifier
-- The existential quantifier is hard-coded in our translation,
-- i.e. the symbol ∃ must be used.

open import Common.Data.Product public using ( _,_ ; ∃ ; ∃-proj₁ ; ∃-proj₂ )

-- The universal quantifier
-- For the universal quantifier we use the Agda (dependent) function type.


Generalize term equivalence to arbitrary calculi.

Old-commit-hash: 239a4be82a8af884669ca62db624782bee407ca1

module Denotational.Equivalence where

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Nullary using (¬_)

open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality

open import Denotational.Notation

-- TERMS

-- Term Equivalence
--
-- This module is parametric in the syntax and semantics of types
-- and terms to make it work for different calculi.

module _ where
  open import Syntactic.Contexts
  open import Denotational.Environments

  module MakeEquivalence
      (Type : Set)
      (⟦_⟧Type : Type → Set)
      (Term : Context Type → Type → Set)
      (⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦_⟧Context Type ⟦_⟧Type Γ → ⟦ τ ⟧Type) where
    module _ {Γ} {τ} where
      data _≈_ (t₁ t₂ : Term Γ τ) : Set where
        ext-t :
          (∀ ρ → ⟦ t₁ ⟧Term ρ ≡ ⟦ t₂ ⟧Term ρ) →
          t₁ ≈ t₂

      ≈-refl : Reflexive _≈_
      ≈-refl = ext-t (λ ρ → refl)

      ≈-sym : Symmetric _≈_
      ≈-sym (ext-t ≈) = ext-t (λ ρ → sym (≈ ρ))

      ≈-trans : Transitive _≈_
      ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → trans (≈₁ ρ) (≈₂ ρ))

      ≈-isEquivalence : IsEquivalence _≈_
      ≈-isEquivalence = record
        { refl  = ≈-refl
        ; sym   = ≈-sym
        ; trans = ≈-trans
        }

    ≈-setoid : Context Type → Type → Setoid _ _
    ≈-setoid Γ τ = record
      { Carrier       = Term Γ τ
      ; _≈_           = _≈_
      ; isEquivalence = ≈-isEquivalence
      }

    module ≈-Reasoning where
      module _ {Γ : Context Type} {τ : Type} where
        open import Relation.Binary.EqReasoning (≈-setoid Γ τ) public
          hiding (_≡⟨_⟩_)

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total

open import Changes
open import ChangeContexts

-- Export a version of the equivalence for terms with total
-- derivatives

open MakeEquivalence Type ⟦_⟧ Term ⟦_⟧ public

-- Specialized congruence rules

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

-- Consistency

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()

module Denotational.Equivalence where

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Nullary using (¬_)

open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total

open import Changes
open import ChangeContexts

-- TERMS

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext-t :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext-t (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext-t ≈) = ext-t (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open import Relation.Binary.EqReasoning (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()


Added fixity to ∧.

Added fixity to ∧.

Ignore-this: c367b405b7f5f7c7031020541aca93f

darcs-hash:20100513032756-3bd4e-29d298c9e1f649bd87c5a74b424423d02d7703b4.gz

-----------------------------------------------------------------------------
-- The product data type
-----------------------------------------------------------------------------

module MyStdLib.Data.Product where

infixr 4 _,_
infixr 2 _×_

-- data Σ (A : Set) (B : A → Set) : Set where
--   _,_ : (x : A) (y : B x) → Σ A B

-- ∃ : {A : Set} → (A → Set) → Set
-- ∃ = Σ _

-- _×_ : (A B : Set) → Set
-- A × B = Σ A (λ _ → B)

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

×-proj₁ : {A B : Set} → A × B → A
×-proj₁ (x , y) = x

×-proj₂ : {A B : Set} → A × B → B
×-proj₂ (x , y) = y

-- N.B. It is not necessary to add the constructor _,_ , nor the fields
-- proj₁, proj₂ as hints, because the ATP implements them.

-- _∧_ : (A B : Set) → Set
-- A ∧ B = A × B

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

∧-proj₁ : {A B : Set} → A ∧ B → A
∧-proj₁ (x , y) = x

∧-proj₂ : {A B : Set} → A ∧ B → B
∧-proj₂ (x , y) = y

-----------------------------------------------------------------------------
-- The product data type
-----------------------------------------------------------------------------

module MyStdLib.Data.Product where

infixr 4 _,_
infixr 2 _×_

-- data Σ (A : Set) (B : A → Set) : Set where
--   _,_ : (x : A) (y : B x) → Σ A B

-- ∃ : {A : Set} → (A → Set) → Set
-- ∃ = Σ _

-- _×_ : (A B : Set) → Set
-- A × B = Σ A (λ _ → B)

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

×-proj₁ : {A B : Set} → A × B → A
×-proj₁ (x , y) = x

×-proj₂ : {A B : Set} → A × B → B
×-proj₂ (x , y) = y

-- N.B. It is not necessary to add the constructor _,_ , nor the fields
-- proj₁, proj₂ as hints, because the ATP implements them.

-- _∧_ : (A B : Set) → Set
-- A ∧ B = A × B

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

∧-proj₁ : {A B : Set} → A ∧ B → A
∧-proj₁ (x , y) = x

∧-proj₂ : {A B : Set} → A ∧ B → B
∧-proj₂ (x , y) = y


Only white spaces.

Only white spaces.

Ignore-this: f24a6175e207d3d7a282cdf79c095f9d

darcs-hash:20100703024037-3bd4e-29afaf143070ef3aad407f2f6566756f8e485c41.gz


TDDwI

TDDwI

module P236-257-predicates-hangman where

open import Agda.Builtin.Equality
open import Agda.Builtin.Unit                     using (⊤)
open import Data.Bool
open import Data.Char                             as C hiding (_==_) renaming (_≟_ to _≟C_)
open import Data.Empty
open import Data.Nat                              renaming (_≟_ to _≟N_)
open import Data.List                             as L
open import Data.Product
open import Data.Vec                              as V hiding (_>>=_)
open import Data.String                           as S hiding (_==_)
open import Data.Sum
open import Data.Vec.Membership.Propositional
open import Data.Vec.Relation.Unary.Any
open import Function.Base
open import hcio                                  as HCIO
open import IO                                    as IO hiding (_>>=_; _>>_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; cong-app; sym; subst)
open import Relation.Nullary

Nat = ℕ
_==_ = _≡_

-- ------------------------------------------------------------------------------
-- -- 'Elem' : guaranteeing a value is in a vector

removeElem : {a : Set} {n : Nat}
          -> (value : a) -> (xs : Vec a (suc n)) -> (prf : value ∈ xs)
          -> Vec a n
removeElem             value (_ ∷ ys) (here  _)     = ys
removeElem {_} {suc k} value (y ∷ ys) (there later) = y ∷ removeElem value ys later

exV : Vec Nat 3
exV = 1 ∷ 2 ∷ 3 ∷ []

twoInVector : 2 ∈ exV
twoInVector = there (here refl)

rmTwo : Vec Nat 2
rmTwo = removeElem 2 exV twoInVector

-- -- auto-implicit args - automatically constructs proofs -- TODO : NOT IN AGDA

removeElemAuto : {a : Set} {n : Nat}
              -> (value : a) -> (xs : Vec a (suc n)) -> {prf : value ∈ xs}
              -> Vec a n
removeElemAuto             value  (_ ∷ ys) {here      _} = ys
removeElemAuto {_} {suc k} value  (y ∷ ys) {there later} = y ∷ removeElemAuto value ys {later}

rmTwo' : Vec Nat 2
rmTwo' = removeElemAuto 2 exV {twoInVector}

-- ------------------------------------------------------------------------------
-- -- decidable predicates

notInNil : {A : Set} -> (value : A ∈ []) -> ⊥
notInNil ()

notInTail : {A : Set} {n : Nat} {x value : A} {xs : Vec A n}
         -> (notThere : value ∈ xs   -> ⊥)
         -> (notHere  : (value == x) -> ⊥)
         -> value ∈ (x ∷ xs)
         -> ⊥
notInTail notThere notHere (here  v==x)  = notHere  v==x
notInTail notThere notHere (there later) = notThere later

-- TODO       v - make it a Set (Generalize)
isElem : {n : Nat} (value : Nat) -> (xs : Vec Nat n) -> Dec (value ∈ xs)
isElem value      [] = no λ ()
isElem value (x ∷ xs)
  with value ≟N x
...| yes refl = yes (here refl)
...| no  notHere
  with isElem value xs
...| yes prf      = yes (there prf)
...| no  notThere = no  (notInTail notThere notHere)

elem : {n : Nat} -> Nat -> (xs : Vec Nat n) -> Bool
elem value      []  = false
elem value (x ∷ xs)
  with value ≟N x
...| no  _ = elem value xs
...| yes _ = true

exIsElem : Dec    (3 ∈ 1 ∷ 2 ∷ 3 ∷ [])
exIsElem = isElem 3   (1 ∷ 2 ∷ 3 ∷ [])

-- ------------------------------------------------------------------------------
-- -- exercises

data Last {A : Set} : (List A) -> A -> Set where
  LastOne  : {a   : A}                                    -> Last (a ∷ []) a
  LastCons : {a x : A} {xs : List A} -> (prf : Last xs a) -> Last (x ∷ xs) a

exLast123 : Last (1 ∷ 2 ∷ 3 ∷ []) 3
exLast123 = LastCons (LastCons LastOne)

exLastTTTF : Last (true ∷ true ∷ true ∷ false ∷ []) false
exLastTTTF = LastCons (LastCons (LastCons LastOne))

-- notLastInNil : Last [] value -> Void
-- notLastInNil  LastOne     impossible
-- notLastInNil (LastCons _) impossible

-- lastOneImpliesEq : Last [x] a -> x = a
-- lastOneImpliesEq  LastOne       = Refl
-- lastOneImpliesEq (LastCons prf) impossible

-- tailStillLast : Last (x :: y :: xs) a -> Last (y :: xs) a
-- tailStillLast (LastCons yxs) = yxs

-- isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
-- isLast            []  a = No notLastInNil
-- isLast      (x :: []) a =
--   case decEq x a of
--     No  xEQaToVoid => No (\LastPxPa => xEQaToVoid (lastOneImpliesEq LastPxPa))
--     Yes xEQa       => doYes xEQa
--  where
--   doYes : (x = a) -> Dec (Last [x] a)
--   doYes prf = rewrite prf in (Yes LastOne)
-- isLast (x :: y :: xs) a =
--   case isLast (y :: xs) a of
--     No  lastYXSaToVoid => No  (\LastXYXSa => void (lastYXSaToVoid (tailStillLast LastXYXSa)))
--     Yes why            => Yes (LastCons why)

-- exIsLast : Dec (Last [1, 2, 3] 3)
-- exIsLast = isLast [1,2,3] 3

-- ------------------------------------------------------------------------------
-- -- hangman

data WordState : (guesses_remaining : Nat) -> (letters : Nat) -> Set where
  MkWordState  : (guesses_remaining : Nat)
              -> {letters : Nat}
              -> (word    : String)
              -> (missing : Vec Char letters)
              -> WordState guesses_remaining letters

data Finished : Set where
  Lost : {letters : Nat} (game : WordState 0 (suc letters)) -> Finished
  Won  : {guesses : Nat} (game : WordState (suc guesses) 0) -> Finished

data ValidInput : List Char -> Set where
  Letter : (c : Char) -> ValidInput (c ∷ [])

isValidNil : ValidInput [] -> ⊥
isValidNil ()

isValidTwo : {x y : Char} {xs : List Char} -> ValidInput (x ∷ y ∷ xs) -> ⊥
isValidTwo ()

isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput           []   = no  isValidNil
isValidInput (x      ∷ [])  = yes (Letter x)
isValidInput (x ∷ (y ∷ xs)) = no  isValidTwo

isValidString : (s : String) -> Dec (ValidInput (S.toList s))
isValidString s = isValidInput (S.toList s)

{-# TERMINATING #-}
readGuess : IO (Σ (List Char) (λ lc -> ValidInput lc))
readGuess = do
  putStr "Guess:"
  x <- HCIO.getLine
  case isValidString (S.fromList (L.map C.toUpper (S.toList x))) of λ where
    (yes prf)    -> return (_ , prf)
    (no  contra) -> do putStrLn "Invalid guess"
                       readGuess

Either = _⊎_

isElemV : {n : Nat} (value : Char) -> (xs : Vec Char n) -> Dec (value ∈ xs)
isElemV value      [] = no λ ()
isElemV value (x ∷ xs)
  with value ≟C x
...| yes refl = yes (here refl)
...| no  notHere
  with isElemV value xs
...| yes prf      = yes (there prf)
...| no  notThere = no  (notInTail notThere notHere)

processGuess : {guesses letters : Nat}
            -> (letter : Char)
            ->         WordState (suc guesses) (suc letters)
            -> Either (WordState      guesses  (suc letters))
                      (WordState (suc guesses)      letters)
processGuess letter (MkWordState guesses_remaining word missing) =
  case isElemV letter missing of λ where
    (yes prf)    -> inj₂ (MkWordState  guesses_remaining      word (removeElem letter missing prf))
    (no  contra) -> inj₁ (MkWordState (guesses_remaining ∸ 1) word missing)

-- game : {guesses letters : Nat} -> WordState (suc guesses) (suc letters) -> IO Finished
-- game {guesses} {letters} st = do
--   (_ , Letter letter) <- readGuess
--   case processGuess letter st of λ where
--     (inj₁ l) -> do
--       putStrLn "Wrong!"
--       case guesses of λ where
--         zero    -> return (Lost {!!})
--         (suc k) -> game {!!}
--     (inj₂ r) -> do
--       putStrLn "Right!"
--       case letters of λ where
--         zero    -> return (Won {!!})
--         (suc k) -> game {!!}

-- main : IO ()
-- main = do
--   result <- game {guesses=2} (MkWordState "Test" ['T', 'E', 'S'])
--   case result of
--     Lost (MkWordState word missing) => putStrLn ("You lose. The word was " ++ word)
--     Won game                        => putStrLn "You win!"

-- {-
-- :exec main
-- -}

module P236-257-predicates-hangman where

open import Agda.Builtin.Equality
open import Agda.Builtin.Unit using (⊤)
open import Data.Bool
open import Data.Empty
open import Data.Nat renaming (_≟_ to _≟N_)
open import Data.List as L
open import Data.Vec as V
open import Data.Vec.Membership.Propositional
open import Data.Vec.Relation.Unary.Any
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; cong-app; sym; subst)
open import Relation.Nullary

Nat = ℕ
_==_ = _≡_

-- ------------------------------------------------------------------------------
-- -- 'Elem' : guaranteeing a value is in a vector

removeElem : {a : Set} {n : Nat}
          -> (value : a) -> (xs : Vec a (suc n)) -> (prf : value ∈ xs)
          -> Vec a n
removeElem             value (_ ∷ ys) (here  _)     = ys
removeElem {_} {suc k} value (y ∷ ys) (there later) = y ∷ removeElem value ys later

exV : Vec Nat 3
exV = 1 ∷ 2 ∷ 3 ∷ []

twoInVector : 2 ∈ exV
twoInVector = there (here refl)

rmTwo : Vec Nat 2
rmTwo = removeElem 2 exV twoInVector

-- -- auto-implicit args - automatically constructs proofs -- TODO : NOT IN AGDA

removeElemAuto : {a : Set} {n : Nat}
              -> (value : a) -> (xs : Vec a (suc n)) -> {prf : value ∈ xs}
              -> Vec a n
removeElemAuto             value  (_ ∷ ys) {here      _} = ys
removeElemAuto {_} {suc k} value  (y ∷ ys) {there later} = y ∷ removeElemAuto value ys {later}

rmTwo' : Vec Nat 2
rmTwo' = removeElemAuto 2 exV {twoInVector}

-- ------------------------------------------------------------------------------
-- -- decidable predicates

notInNil : {A : Set} -> (value : A ∈ []) -> ⊥
notInNil ()

notInTail : {A : Set} {n : Nat} {x value : A} {xs : Vec A n}
         -> (notThere : value ∈ xs   -> ⊥)
         -> (notHere  : (value == x) -> ⊥)
         -> value ∈ (x ∷ xs)
         -> ⊥
notInTail notThere notHere (here  v==x)  = notHere  v==x
notInTail notThere notHere (there later) = notThere later

-- TODO       v - make it a Set (Generalize)
isElem : {n : Nat} (value : Nat) -> (xs : Vec Nat n) -> Dec (value ∈ xs)
isElem value      [] = no λ ()
isElem value (x ∷ xs)
  with value ≟N x
...| yes refl = yes (here refl)
...| no  notHere
  with isElem value xs
...| yes prf      = yes (there prf)
...| no  notThere = no  (notInTail notThere notHere)

elem : {n : Nat} -> Nat -> (xs : Vec Nat n) -> Bool
elem value      []  = false
elem value (x ∷ xs)
  with value ≟N x
...| no  _ = elem value xs
...| yes _ = true

exIsElem : Dec    (3 ∈ 1 ∷ 2 ∷ 3 ∷ [])
exIsElem = isElem 3   (1 ∷ 2 ∷ 3 ∷ [])

-- ------------------------------------------------------------------------------
-- -- exercises

-- data ElemL : a -> List a -> Type where
--   Here  : ElemL x (x :: xs)
--   There : (later : ElemL x xs) -> ElemL x (y :: xs)

-- notInNilL : ElemL value [] -> Void
-- notInNilL  Here     impossible
-- notInNilL (There _) impossible

-- notInTailL : (notThere : ElemL value xs -> Void) -> (notHere : (value = x) -> Void)
--           -> ElemL value (x :: xs) -> Void
-- notInTailL notThere notHere  Here         = notHere  Refl
-- notInTailL notThere notHere (There later) = notThere later

-- isElemL : DecEq a => (value : a) -> (xs : List a) -> Dec (ElemL value xs)
-- isElemL value       []  = No notInNilL
-- isElemL value (x :: xs) =
--   case decEq value x of
--     Yes Refl   => Yes Here
--     No notHere =>
--       case isElemL value xs of
--         Yes prf     => Yes (There prf)
--         No notThere => No (notInTailL notThere notHere)

-- elemL : Eq ty => (value : ty) -> (xs : List ty) -> Bool
-- elemL value       []  = False
-- elemL value (x :: xs) =
--   case value == x of
--     False => elemL value xs
--     True  => True

-- exIsElemL : Dec (ElemL 3 [1,2,3])
-- exIsElemL = isElemL 3 [1,2,3]

-- -----

-- data Last : List a -> a -> Type where
--   LastOne  : Last [value] value
--   LastCons : (prf : Last xs value) -> Last (x :: xs) value

-- exLast123 : Last [1,2,3] 3
-- exLast123 = LastCons (LastCons LastOne)

-- notLastInNil : Last [] value -> Void
-- notLastInNil  LastOne     impossible
-- notLastInNil (LastCons _) impossible

-- lastOneImpliesEq : Last [x] a -> x = a
-- lastOneImpliesEq  LastOne       = Refl
-- lastOneImpliesEq (LastCons prf) impossible

-- tailStillLast : Last (x :: y :: xs) a -> Last (y :: xs) a
-- tailStillLast (LastCons yxs) = yxs

-- isLast : DecEq a => (xs : List a) -> (value : a) -> Dec (Last xs value)
-- isLast            []  a = No notLastInNil
-- isLast      (x :: []) a =
--   case decEq x a of
--     No  xEQaToVoid => No (\LastPxPa => xEQaToVoid (lastOneImpliesEq LastPxPa))
--     Yes xEQa       => doYes xEQa
--  where
--   doYes : (x = a) -> Dec (Last [x] a)
--   doYes prf = rewrite prf in (Yes LastOne)
-- isLast (x :: y :: xs) a =
--   case isLast (y :: xs) a of
--     No  lastYXSaToVoid => No  (\LastXYXSa => void (lastYXSaToVoid (tailStillLast LastXYXSa)))
--     Yes why            => Yes (LastCons why)

-- exIsLast : Dec (Last [1, 2, 3] 3)
-- exIsLast = isLast [1,2,3] 3

-- ------------------------------------------------------------------------------
-- -- hangman

-- data WordState : (guesses_remaining : Nat) -> (letters : Nat) -> Type where
--   MkWordState : (word : String) -> (missing : Vect letters Char)
--              -> WordState guesses_remaining letters

-- data Finished : Type where
--   Lost : (game : WordState 0 (S letters)) -> Finished
--   Won  : (game : WordState (S guesses) 0) -> Finished

-- data ValidInput : List Char -> Type where
--   Letter : (c : Char) -> ValidInput [c]

-- isValidNil : ValidInput [] -> Void
-- isValidNil (Letter _) impossible

-- isValidTwo : ValidInput (x :: y :: xs) -> Void
-- isValidTwo (Letter _) impossible

-- isValidInput : (cs : List Char) -> Dec (ValidInput cs)
-- isValidInput             []   = No  isValidNil
-- isValidInput (x       :: [])  = Yes (Letter x)
-- isValidInput (x :: (y :: xs)) = No  isValidTwo

-- isValidString : (s : String) -> Dec (ValidInput (unpack s))
-- isValidString s = isValidInput (unpack s)

-- readGuess : IO (x ** ValidInput x)
-- readGuess = do
--   putStr "Guess:"
--   x <- getLine
--   case isValidString (toUpper x) of
--     Yes prf    => pure (_ ** prf)
--     No  contra => do putStrLn "Invalid guess"
--                      readGuess
-- {-
-- :exec readGuess >>= \_ => putStrLn "YES"
-- -}

-- processGuess : (letter : Char)
--             ->         WordState (S guesses) (S letters)
--             -> Either (WordState    guesses  (S letters))
--                       (WordState (S guesses)    letters)
-- processGuess letter (MkWordState word missing) =
--   case V.isElem letter missing of
--     Yes prf    => Right (MkWordState word (removeElemAuto letter missing))
--     No  contra => Left  (MkWordState word missing)

-- game : WordState (S guesses) (S letters) -> IO Finished
-- game {guesses} {letters} st = do
--    (_ ** Letter letter) <- readGuess
--    case processGuess letter st of
--      Left l => do
--        putStrLn "Wrong!"
--        case guesses of
--          Z   => pure (Lost l)
--          S k => game l
--      Right r => do
--        putStrLn "Right!"
--        case letters of
--          Z   => pure (Won r)
--          S k => game r

-- main : IO ()
-- main = do
--   result <- game {guesses=2} (MkWordState "Test" ['T', 'E', 'S'])
--   case result of
--     Lost (MkWordState word missing) => putStrLn ("You lose. The word was " ++ word)
--     Won game                        => putStrLn "You win!"

-- {-
-- :exec main
-- -}


Data.Nat.NP: add 2*-spec, 2*′_, 2*′-spec, 2^-spec

{-# OPTIONS --universe-polymorphism #-}
module Data.Nat.NP where

import Algebra
open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties as Props
open import Data.Bool
open import Data.Product using (proj₁; proj₂; ∃; _,_)
open import Data.Empty using (⊥-elim)
open import Function.NP
open import Relation.Nullary
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning)

module ℕ°   = Algebra.CommutativeSemiring Props.commutativeSemiring
module ℕcmp = StrictTotalOrder Props.strictTotalOrder
module ℕ≤   = DecTotalOrder    decTotalOrder
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ ≡.refl ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → (suc n ∶ ℕ) ≡ suc m → n ≡ m
suc-injective = ≡.cong pred

fold : ∀ {a} {A : Set a} → A → Endo A → ℕ → A
fold x f n = nest n f x

_==_ : (x y : ℕ) → Bool
zero   == zero   = true
zero   == suc _  = false
suc _  == zero   = false
suc m  == suc n  = m == n

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

{-
postulate
  dist-refl  : ∀ x → dist x x ≡ 0
  dist-sym   : ∀ x y → dist x y ≡ dist y x
  dist-sum   : ∀ x y z → dist x y + dist y z ≤ dist x z
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-x+    : ∀ x y z → dist (x + y) (x + z) ≡ dist y z
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
  dist-x*  : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

2*_ : ℕ → ℕ
2* x = x + x

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite ℕ°.+-comm n 0 = ≡.refl

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = ≡.refl
2*′-spec (suc n) rewrite 2*′-spec n
                      | ℕ°.+-comm 1 (n + n)
                      | ℕ°.+-assoc n n 1
                      | ℕ°.+-comm n 1
                      = ≡.refl

2^_ : ℕ → ℕ
2^ zero  = 1
2^ suc n = 2* 2^ n

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = ≡.refl
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = ≡.refl

-- https://en.wikipedia.org/wiki/Hyper_operator
_↑⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
a ↑⟨ suc n             ⟩ (suc b) = a ↑⟨ n ⟩ (a ↑⟨ suc n ⟩ b)
a ↑⟨ 0                 ⟩ b       = suc b
a ↑⟨ 1                 ⟩ 0       = a
a ↑⟨ 2                 ⟩ 0       = 0
a ↑⟨ suc (suc (suc n)) ⟩ 0       = 1

module ↑-Props where
  ↑-fold : ∀ a n b → a ↑⟨ suc n ⟩ b ≡ fold (a ↑⟨ suc n ⟩ 0) (_↑⟨_⟩_ a n) b
  ↑-fold a n zero = ≡.refl
  ↑-fold a n (suc b) = ≡.cong (_↑⟨_⟩_ a n) (↑-fold a n b)

  ↑₀-+ : ∀ a b → a ↑⟨ 0 ⟩ b ≡ 1 + b
  ↑₀-+ a b = ≡.refl

  ↑₁-+ : ∀ a b → a ↑⟨ 1 ⟩ b ≡ b + a
  ↑₁-+ a zero    = ≡.refl
  ↑₁-+ a (suc b) = ≡.cong suc (↑₁-+ a b)

  ↑₂-* : ∀ a b → a ↑⟨ 2 ⟩ b ≡ b * a
  ↑₂-* a zero    = ≡.refl
  ↑₂-* a (suc b) rewrite ↑₂-* a b
                       | ↑₁-+ a (b * a)
                       | ℕ°.+-comm (b * a) a
                       = ≡.refl

  -- fold 1 (_*_ a) b ≡ a ^ b
  ↑₃-^ : ∀ a b → a ↑⟨ 3 ⟩ b ≡ a ^ b
  ↑₃-^ a zero = ≡.refl
  ↑₃-^ a (suc b) rewrite ↑₃-^ a b
                       | ↑₂-* a (a ^ b)
                       | ℕ°.*-comm (a ^ b) a
                       = ≡.refl

  _↑⟨_⟩0 : ℕ → ℕ → ℕ
  a ↑⟨ 0                 ⟩0 = 1
  a ↑⟨ 1                 ⟩0 = a
  a ↑⟨ 2                 ⟩0 = 0
  a ↑⟨ suc (suc (suc n)) ⟩0 = 1

  _`↑⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
  _`↑⟨_⟩_ a 0       = suc
  _`↑⟨_⟩_ a (suc n) = fold (a ↑⟨ suc n ⟩0) (_`↑⟨_⟩_ a n)

  ↑-ind-rule : ∀ a n b → a ↑⟨ suc n ⟩ (suc b) ≡ a ↑⟨ n ⟩ (a ↑⟨ suc n ⟩ b)
  ↑-ind-rule a n b = ≡.refl

  _↑′⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
  a ↑′⟨ 0 ⟩ b = suc b
  a ↑′⟨ 1 ⟩ b = a + b
  a ↑′⟨ 2 ⟩ b = a * b
  a ↑′⟨ 3 ⟩ b = a ^ b
  a ↑′⟨ suc (suc (suc (suc n))) ⟩ b = a ↑⟨ 4 + n ⟩ b

  ↑-↑′ : ∀ a n b → a ↑⟨ n ⟩ b ≡ a ↑′⟨ n ⟩ b
  ↑-↑′ a 0 b = ≡.refl
  ↑-↑′ a 1 b = ≡.trans (↑₁-+ a b) (ℕ°.+-comm b a)
  ↑-↑′ a 2 b = ≡.trans (↑₂-* a b) (ℕ°.*-comm b a)
  ↑-↑′ a 3 b = ↑₃-^ a b
  ↑-↑′ a (suc (suc (suc (suc _)))) b = ≡.refl

  _↑2+⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
  _↑2+⟨_⟩_ a = fold (_*_ a) (fold 1)

module InflModule where
  -- Inflationary functions
  Infl< : (f : ℕ → ℕ) → Set
  Infl< f = ∀ {x} → x < f x

  Infl : (f : ℕ → ℕ) → Set
  Infl f = Infl< (suc ∘ f)

  InflT< : (f : Endo (Endo ℕ)) → Set
  InflT< f = ∀ {g} → Infl< g → Infl< (f g)

{-
∀ {x} → x ≤ f x

  1 + x ≤ 1 + f x
  x < 1 + f x
  x < (suc ∘ f) x
  Infl< (suc ∘ f)

  Infl< f = ∀ {x} → 1 + x ≤ f x
  Infl< f = ∀ {x} → 1 + x ≤ f x

Infl< f → Infl f
Infl< f → Infl< (suc ∘ f)
-}

  id-infl : Infl id
  id-infl = ℕ≤.refl

  ∘-infl< : ∀ {f g} → Infl< f → Infl< g → Infl< (f ∘ g)
  ∘-infl< inflf< inflg< = <-trans inflg< inflf<

  suc-infl< : Infl< suc
  suc-infl< = ℕ≤.refl

  suc-infl : Infl suc
  suc-infl = s≤s (≤-step ℕ≤.refl)

  nest-infl : ∀ f (finfl : Infl f) n → Infl (nest n f)
  nest-infl f _ zero = ℕ≤.refl
  nest-infl f finfl (suc n) = ℕ≤.trans (nest-infl f finfl n) finfl

  nest-infl< : ∀ f (finfl< : Infl< f) n → Infl< (nest (suc n) f)
  nest-infl< f finfl< zero = finfl<
  nest-infl< f finfl< (suc n) = <-trans (nest-infl< f finfl< n) finfl<

-- See Function.NP.nest-Properties for more properties
module fold-Props where

  fold-suc : ∀ m n → fold m suc n ≡ n + m
  fold-suc m zero = ≡.refl
  fold-suc m (suc n) rewrite fold-suc m n = ≡.refl

  fold-+ : ∀ m n → fold 0 (_+_ m) n ≡ n * m
  fold-+ m zero = ≡.refl
  fold-+ m (suc n) rewrite fold-+ m n = ≡.refl

  fold-* : ∀ m n → fold 1 (_*_ m) n ≡ m ^ n
  fold-* m zero = ≡.refl
  fold-* m (suc n) rewrite fold-* m n = ≡.refl

{- TODO
  fold-^ : ∀ m n → fold 1 (flip _^_ m) n ≡ m ↑⟨ 4 ⟩ n
  fold-^ m zero = ≡.refl
  fold-^ m (suc n) rewrite fold-^ m n = ?
-}

  cong-fold : ∀ {A : Set} {f g : Endo A} (f≗g : f ≗ g) {z} → fold z f ≗ fold z g
  cong-fold eq zero = ≡.refl
  cong-fold eq {z} (suc x) rewrite cong-fold eq {z} x = eq _

  private
   open ↑-Props
   module Alt↑2 where
    alt : ℕ → ℕ → ℕ → ℕ
    alt a 0       = λ b → a ↑⟨ 2 ⟩ b
    alt a (suc n) = fold 1 (alt a n)

    alt-ok : ∀ a n → _↑2+⟨_⟩_ a n ≗ alt a n
    alt-ok a zero = ≡.sym ∘ ↑-↑′ a 2
    alt-ok a (suc n) = cong-fold (alt-ok a n)

{- TODO
    alt' : ∀ a n → _↑2+⟨_⟩_ a n ≗ _↑⟨_⟩_ a (2 + n)
    alt' a zero  b = ≡.sym (↑-↑′ a 2 _)
    alt' a (suc n) zero = ≡.refl
    alt' a (suc n) (suc x) rewrite alt' a n (_↑2+⟨_⟩_ a (suc n) x)
       = ≡.cong (_↑⟨_⟩_ a (2 + n)) { fold 1 (fold (_*_ a) (fold 1) n) x} {a ↑⟨ suc (suc (suc n)) ⟩ x} (alt' a (suc n) x)
-}

  open InflModule
{-
  fold1-infl : ∀ f → Infl f → Infl (fold 1 f)
  fold1-infl f finfl {zero} = {!z≤n!}
  fold1-infl f finfl {suc x} =
     x          <⟨ {!s≤s (fold1-infl f finfl {x})!} ⟩
     fold 1 f x <⟨ {!!} ⟩
     {- f (fold 1 f x) ≤⟨ finfl ⟩
     f (fold 1 f x) ≡⟨ ≡.refl ⟩ -}
     fold 1 f (1 + x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}

{-
  fold1+1-infl< : ∀ (f : ℕ → ℕ) → Infl< (f ∘ suc) → Infl< (fold 1 f ∘ suc)
  fold1+1-infl< f finfl< {zero} = finfl<
  fold1+1-infl< f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1+1-infl< f finfl< {x}) ⟩
     1 + f (fold 1 f x) ≤⟨ finfl< {f (fold 1 f x)} ⟩
     f (suc (f (fold 1 f x))) ≤⟨ {!!} ⟩
     fold 1 f (2 + x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
{-
  fold1+1-infl< : ∀ (f : ℕ → ℕ) → Infl< (f ∘ suc) → Infl< (fold 1 (f ∘ suc))
  fold1+1-infl< f finfl< {zero} = s≤s z≤n
  fold1+1-infl< f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1+1-infl< f finfl< {x}) ⟩
     1 + fold 1 (f ∘ suc) x ≤⟨ finfl< ⟩
     fold 1 (f ∘ suc) (suc x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
{-
  fold1+-infl< : ∀ k f → Infl< (f ∘′ _+_ k) → Infl< (fold 1 (f ∘′ _+_ k))
  fold1+-infl< k f finfl< {zero} = s≤s z≤n
  fold1+-infl< k f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1+-infl< k f finfl< {x}) ⟩
     1 + fold 1 (f ∘ _+_ k) x ≤⟨ finfl< ⟩
     fold 1 (f ∘ _+_ k) (suc x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}

{-
  fold1+-infl< : ∀ f → Infl+2< f → Infl+2< (fold 1 f)
  fold1+-infl< f finfl< {zero} _ = ℕ≤.refl
  fold1+-infl< f finfl< {suc zero} _ = {!!}
  fold1+-infl< f finfl< {suc (suc zero)} _ = {!!}
  fold1+-infl< f finfl< {suc (suc (suc x))} x>1 =
     4 + x ≤⟨ s≤s (fold1+-infl< f finfl< {suc (suc x)} (m≤m+n 2 x)) ⟩
     1 + fold 1 f (2 + x) ≤⟨ finfl< {!!} ⟩
     fold 1 f (3 + x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
{-
  fold1-infl< f finfl< {zero} = s≤s z≤n
  fold1-infl< f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1-infl< f finfl< {x}) ⟩
     1 + fold 1 f x ≤⟨ finfl< ⟩
     fold 1 f (suc x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
module ^-Props where
  open ≡-Reasoning

  ^1 : ∀ n → n ^ 1 ≡ n
  ^1 zero = ≡.refl
  ^1 (suc n) = ≡.cong suc (proj₂ ℕ°.*-identity n)

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b zero n = ≡.sym (proj₂ ℕ°.+-identity (b ^ n))
  ^-+ b (suc m) n rewrite ^-+ b m n = ≡.sym (ℕ°.*-assoc b (b ^ m) (b ^ n))

  ^-* : ∀ b m n → b ^ (m * n) ≡ (b ^ n) ^ m
  ^-* b zero    n = ≡.refl
  ^-* b (suc m) n = b ^ (n + m * n)
                  ≡⟨ ^-+ b n (m * n) ⟩
                    b ^ n * b ^ (m * n)
                  ≡⟨ ≡.cong (_*_ (b ^ n)) (^-* b m n) ⟩
                    b ^ n * (b ^ n) ^ m ∎

ack : ℕ → ℕ → ℕ
ack zero n          = suc n
ack (suc m) zero    = ack m (suc zero)
ack (suc m) (suc n) = ack m (ack (suc m) n)

module ack-Props where
  lem∸ : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n
  lem∸ z≤n = ≡.refl
  lem∸ (s≤s {m} {n} m≤n) = ≡.cong suc (lem∸ m≤n)

  -- n >= m → m + (n ∸ m) ≡ n
  -- n >= m → ∃ k → n ≡ m + k
  -- ∃ k → n ≡ m + k → m + (n ∸ m) ≡ n
  -- ∀ k → n ≡ m + k → m + (n ∸ m) ≡ n
  -- ∀ k → m + ((m + k) ∸ m) ≡ m + k
  -- ∀ k → m + k ≡ m + k

  -- 3 ≤ x → P x → ∃ λ k → P (3 + k)

  open InflModule

  fold1+-inflT< : ∀ {z} → InflT< (fold (suc z))
  fold1+-inflT<     _      {zero} = s≤s z≤n
  fold1+-inflT< {z} {f} finfl< {suc x} =
     2 + x                ≤⟨ s≤s (fold1+-inflT< {z} {f} finfl< {x}) ⟩
     1 + fold (suc z) f x ≤⟨ finfl< ⟩
     f (fold (suc z) f x) ≡⟨ ≡.refl ⟩
     fold (suc z) f (1 + x)
   ∎
     where open ≤-Reasoning

  Mon : (f : ℕ → ℕ) → Set
  Mon f = ∀ {x y} → x ≤ y → f x ≤ f y
  open InflModule

  ℕ-ind : ∀ (P : ℕ → Set) → P zero → (∀ {n} → P n → P (suc n)) → ∀ {n} → P n
  ℕ-ind P P0 PS {zero} = P0
  ℕ-ind P P0 PS {suc n} = PS (ℕ-ind P P0 PS)

  open fold-Props
  fold-infl< : ∀ {f g} → Infl< f → InflT< g → ∀ {n} → Infl< (fold f g n)
  fold-infl< {f} {g} inflf< inflTg< {n} = ℕ-ind (Infl< ∘ fold f g) inflf< inflTg< {n}

  fold-mon : ∀ {f} (fmon : Mon f) (finfl< : Infl< f) {z} → Mon (fold z f)
  fold-mon fmon finfl< {_} {y = 0} z≤n = ℕ≤.refl
  fold-mon {f} fmon finfl< {z} {y = suc n} z≤n = z ≤⟨ ≤-step ℕ≤.refl ⟩
                                              suc z ≤⟨ nest-infl< f finfl< n {z} ⟩
                                              fold z f (suc n) ≡⟨ ≡.refl ⟩
                                              fold z f (suc n) ∎
    where open ≤-Reasoning
  fold-mon fmon finfl< (s≤s m≤n) = fmon (fold-mon fmon finfl< m≤n)

  MonT : Endo (Endo ℕ) → Set
  MonT g = ∀ {f} → Mon f → Infl< f → Mon (g f)

  fold-mon' : ∀ {f g} → Mon f → Infl< f → MonT g → InflT< g → ∀ {n} → Mon (fold f g n)
  fold-mon' {f} {g} mon-f infl-f mont-g inflTg< {n} = go n where
    go : ∀ n → Mon (fold f g n)
    go zero    = mon-f
    go (suc n) = mont-g (go n) (fold-infl< infl-f inflTg< {n})

  --  +-fold : ∀ a b → a + b ≡ fold a suc b
  --  *-fold : ∀ a b → a * b ≡ fold 0 (_+_ a) b

  1≤1+a^b : ∀ a b → 1 ≤ (1 + a) ^ b
  1≤1+a^b a zero = s≤s z≤n
  1≤1+a^b a (suc b) = 1≤1+a^b a b +-mono z≤n

  1+a^-mon : ∀ {a} → Mon (_^_ (1 + a))
  1+a^-mon {a} (z≤n {b}) = 1≤1+a^b a b
  1+a^-mon {a} (s≤s {m} {n} m≤n)
     = (1 + a) ^ (1 + m)             ≡⟨ ≡.refl ⟩
       (1 + a) ^ m + a * (1 + a) ^ m ≤⟨ (1+a^-mon m≤n) +-mono ((a ∎) *-mono (1+a^-mon m≤n)) ⟩
       (1 + a) ^ n + a * (1 + a) ^ n ≡⟨ ≡.refl ⟩
       (1 + a) ^ (1 + n) ∎
    where open ≤-Reasoning

  postulate
    ↑3+ : ∀ a n b → a ↑⟨ 3 + n ⟩ b ≡ fold (_^_ a) (fold 1) n b
    -- mon↑3+'' : ∀ a b → Mon (λ n → fold (_^_ a) (fold 1) n b)

    mon↑3+' : ∀ b → Mon (λ n → fold (_^_ 2) (fold 1) n (3 + b))
  -- mon↑3+' b = {!!}

  mon↑3+ : ∀ b → Mon (λ n → 2 ↑⟨ 3 + n ⟩ (3 + b))
  mon↑3+ b {m} {n} rewrite ↑3+ 2 m (3 + b) | ↑3+ 2 n (3 + b) = mon↑3+' b

  lem2^3 : ∀ n → 2 ^ 3 ≤ 2 ^ (3 + n)
  lem2^3 n = 1+a^-mon {1} {3} {3 + n} (s≤s (s≤s (s≤s z≤n)))

  open ↑-Props
  lem>=3 : ∀ m n → 3 ≤ 2 ↑⟨ 3 + m ⟩ (3 + n)
  lem>=3 m n = 3 ≤⟨ s≤s (s≤s (s≤s z≤n)) ⟩
               2 ↑⟨ 3 ⟩ 3 ≡⟨ ↑₃-^ 2 3 ⟩
               2 ^ 3 ≤⟨ lem2^3 n ⟩
               2 ^ (3 + n) ≡⟨ ≡.sym (↑₃-^ 2 (3 + n)) ⟩
               2 ↑⟨ 3 ⟩ (3 + n) ≤⟨ mon↑3+ n z≤n ⟩
               2 ↑⟨ 3 + m ⟩ (3 + n) ∎
    where open ≤-Reasoning

  2* = _*_ 2

  -- fold 2* n 1 ≡ 2 ^ n

  -- nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)

  nest-2* : ∀ m n → nest (m * n) (fold 1) 2* ≡ nest m (nest n (fold 1)) 2*
  nest-2* m n = nest-Properties.nest-* (fold 1) m n 2*

{-
  lem3≤ : ∀ n → 3 ≤ fold 2* (fold 1) n 2
  lem3≤ 0 = s≤s (s≤s (s≤s z≤n))
    where open ≤-Reasoning
  lem3≤ (suc n) =
    3 ≤⟨ {!!} ⟩
    fold 2* f1 (1 + n) 2 ∎
    where open ≤-Reasoning
          f1 = fold 1

  lem3≤' : ∀ n → 3 ≤ fold 2* (fold 1) n 3
  lem3≤' 0 = s≤s (s≤s (s≤s z≤n))
    where open ≤-Reasoning
  lem3≤' (suc n) =
    3 ≤⟨ lem3≤ n ⟩
    fold 2* (fold 1) n 2 ≡⟨ ≡.refl ⟩
    fold 2* (fold 1) n (fold 2* (fold 1) 3 1) ≡⟨ {!!} ⟩
{- ≡⟨ nest-Properties.nest-* {!2*!} {!!} {!!} {!!} ⟩
    fold 2* (fold 1) (3 * n) 1 ≡⟨ {!!} ⟩
-}
    fold 1 (fold 2* (fold 1) n) 3 ≡⟨ ≡.refl ⟩
    fold 2* (fold 1) (1 + n) 3 ∎
    where open ≤-Reasoning
-}
---

{-
fold 2* (fold 1) (3 * n) 1 ≤

fold 2* (fold 1) n (fold 2* (fold 1) n (fold 2* (fold 1) n 1)) ≤

fold 1 (fold 2* (fold 1) n) 3 ≤
fold 2* (fold 1) (1 + n) 3
-}

  lem>=3'' : ∀ m n → 3 ≤ 2 ↑⟨ suc m ⟩ (3 + n)
  lem>=3'' zero n = s≤s (s≤s (s≤s z≤n))
  lem>=3'' (suc zero) n rewrite ↑₂-* 2 (3 + n) = s≤s (s≤s (s≤s z≤n))
  lem>=3'' (suc (suc m)) n = lem>=3 m n

  lem2221 : ∀ m → 2 ≡ 2 ↑⟨ 2 + m ⟩ 1
  lem2221 zero = ≡.refl
  lem2221 (suc m) = lem2221 m

  lem4212 : ∀ m → 4 ≡ 2 ↑⟨ 1 + m ⟩ 2
  lem4212 zero = ≡.refl
  lem4212 (suc m) = 4                            ≡⟨ lem4212 m ⟩
                    2 ↑⟨ 1 + m ⟩ 2               ≡⟨ ≡.cong (_↑⟨_⟩_ 2 (1 + m)) (lem2221 m) ⟩
                    2 ↑⟨ 1 + m ⟩ (2 ↑⟨ 2 + m ⟩ 1) ≡⟨ ≡.refl ⟩
                    2 ↑⟨ 2 + m ⟩ 2 ∎
    where open ≡-Reasoning

  ack-↑ : ∀ m n → 3 + ack m n ≡ 2 ↑⟨ m ⟩ (3 + n)
  ack-↑ zero n = ≡.refl
  ack-↑ (suc m) zero = 3 + ack (suc m) 0   ≡⟨ ack-↑ m 1 ⟩
                       2 ↑⟨ m ⟩ 4          ≡⟨ ≡.cong (_↑⟨_⟩_ 2 m) (lem4212 m) ⟩
                       2 ↑⟨ suc m ⟩ 3 ∎
    where open ≡-Reasoning
  ack-↑ (suc m) (suc n) = 3 + ack (suc m) (suc n)
                        ≡⟨ ≡.refl ⟩
                          3 + ack m (ack (suc m) n)
                        ≡⟨ ≡.refl ⟩
                          3 + ack m ((3 + ack (suc m) n) ∸ 3)
                        ≡⟨ ≡.cong (λ x → 3 + ack m (x ∸ 3)) (ack-↑ (suc m) n) ⟩
                           3 + ack m (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3)
                        ≡⟨ ack-↑ m (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3) ⟩
                           2 ↑⟨ m ⟩ (3 + (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3))
                        ≡⟨ ≡.cong (λ x → 2 ↑⟨ m ⟩ x) (lem∸ (lem>=3'' m n)) ⟩
                           2 ↑⟨ m ⟩ (2 ↑⟨ suc m ⟩ (3 + n))
                        ≡⟨ ≡.refl ⟩
                          2 ↑⟨ suc m ⟩ (4 + n) ∎
    where open ≡-Reasoning

  postulate
    1+a^-infl< : ∀ {a}  → Infl< (_^_ (1 + a))

  --  2+a*1+b-infl< : ∀ a → Infl< (λ x → (2 + a) * (1 + x))
  -- ∀ a b → b < (2 + a) * b
  -- fold-a*-fold1 : ∀ {n a} → Infl< (_↑2+⟨_⟩_ (2 + a) n)
  fold-a^-fold1 : ∀ {n a} → Infl< (fold (_^_ (1 + a)) (fold 1) n)
  fold-a^-fold1 {n} = fold-infl< 1+a^-infl< fold1+-inflT< {n}

  ↑3+-mon : ∀ a n → Mon (fold (_^_ (1 + a)) (fold 1) n)
  ↑3+-mon a n = fold-mon' 1+a^-mon 1+a^-infl< (λ η₁ η₂ → fold-mon η₁ η₂) fold1+-inflT< {n}

{-
  open ↑-Props

  -*⟨1+n⟩-infl : ∀ n → Infl (_*_ (1 + n))
  -*⟨1+n⟩-infl n = {!!}

  lem121 : ∀ a b → b < (1 + a) ↑⟨ 2 ⟩ (1 + b)
  lem121 a b rewrite ↑₂-* (1 + a) (1 + b)
     = 1 + b
              ≤⟨ m≤m+n _ _ ⟩
       (1 + a) * (1 + b)
              ≡⟨ ℕ°.*-comm (1 + a) (1 + b) ⟩
       (1 + b) * (1 + a)
     ∎
     where open ≤-Reasoning

  -- ∀ a b → b < (2 + a) * b
  lem222 : ∀ a b → b < (2 + a) ↑⟨ 2 ⟩ (2 + b)
  lem222 a b rewrite ↑₂-* (2 + a) (2 + b)
     = 1 + b
              ≤⟨ suc-infl ⟩
       2 + b
              ≤⟨ m≤m+n _ _ ⟩
       (2 + a) * (2 + b)
              ≡⟨ ℕ°.*-comm (2 + a) (2 + b) ⟩
       (2 + b) * (2 + a)
     ∎
     where open ≤-Reasoning
-}
{-
  open fold-Props

  module Foo a where
    f = λ n b → (2 + a) ↑2+⟨ n ⟩ b
    f-lem : ∀ n → f (suc n) ≗ fold 1 (f n)
    f-lem n x = ≡.refl

    f2 = λ n b → (2 + a) ↑2+⟨ n ⟩ (2 + b)
    f2-lem : ∀ n → f2 (suc n) ≗ fold 1 (f2 n)
    f2-lem n x = {!!}

  -- b < (1 + a) * (1 + b)

 -- nest-infl< : ∀ f (finfl< : Infl< f) n → Infl< (nest (suc n) f)
  infl3< : ∀ a n → Infl< (λ b → (1 + a) ↑2+⟨ n ⟩ (1 + b))
  infl3< a zero {b} = lem121 a b
  infl3< a (suc n) {b}
    = 1 + b
 --  fold1-infl< : ∀ f → Infl< f → ∀ x → x < fold 1 f x
            ≤⟨ {!fold1f2-infl< {_}!} ⟩
      fold 1 f1 b
            ≤⟨ {!!} ⟩
{-
            ≤⟨ fold1-infl< (f 0) (λ {x} → {!infl3< a n {x}!}) {{!!}} ⟩
      {!!}
            ≤⟨ {!!} ⟩
-}
{-
      1 + b
      (2 + a) ↑2+⟨ n ⟩ (2 + b)
            ≤⟨ {!nest-infl< (λ b → (2 + a) ↑2+⟨ n ⟩ b) ? b {(2 + a) ↑2+⟨ n ⟩ (2 + b)}!} ⟩
      fold (f 0 1) (f 0) (1 + b)
            ≤⟨ {!ℕ≤.reflexive (≡.cong (λ g → g 1) (nest-Properties.nest-+ (f 0) 1 (1 + b)))!} ⟩
-}
      fold 1 (f 0) (1 + b)
            ≡⟨ ≡.refl ⟩
      f 1 (1 + b)
            ≡⟨ ≡.refl ⟩
      (1 + a) ↑2+⟨ suc n ⟩ (1 + b)
    ∎

     where
       f = λ k b → (1 + a) ↑2+⟨ k + n ⟩ b
       f1 = f 0 ∘ suc

       -- fold1f2-infl< : Infl< (fold 1 f2)
       -- fold1f2-infl< = fold1-infl< f2 {!(λ b → infl3< a n b ?)!}

       fold1f1-infl<' : Infl< (fold 1 f1)
       fold1f1-infl<' = {!fold1+1-infl< (f 0) {!infl3< a n!}!}
       lem : ∀ x → f 0 (1 + x) < f 0 (f 0 x)
       lem x = {!!}
       postulate
         finfl : Infl< (f 0)
       open ≤-Reasoning
-}

_⇑⟨_,_⟩_ : (a n k b : ℕ) → ℕ
a ⇑⟨ n , k ⟩ b = fold k f n
  module M⇑ where
    f : ℕ → ℕ
    f x = a ↑⟨ 2 + x ⟩ b

module ⇑-Props where
  _⇑′⟨_,_⟩_ : (a n k b : ℕ) → ℕ
  a ⇑′⟨ n₀ , k ⟩ b = g n₀
    module M⇑′ where
      h : ℕ → ℕ
      h x = a ↑⟨ 2 + x ⟩ b

      g : ℕ → ℕ
      g 0       = k
      g (suc n) = h (g n)

      g-nest : ∀ n → g n ≡ h $⟨ n ⟩ k
      g-nest zero = ≡.refl
      g-nest (suc n) rewrite g-nest n = ≡.refl

  ⇑₀ : ∀ a k b → a ⇑⟨ 0 , k ⟩ b ≡ k
  ⇑₀ _ _ _ = ≡.refl

  ⇑₁ : ∀ a k b → a ⇑⟨ 1 , k ⟩ b ≡ a ↑⟨ 2 + k ⟩ b
  ⇑₁ _ _ _ = ≡.refl

  ⇑-⇑′ : ∀ a n k b → a ⇑⟨ n , k ⟩ b ≡ a ⇑′⟨ n , k ⟩ b
  ⇑-⇑′ a n k b rewrite M⇑′.g-nest a n k b n = ≡.refl

-- https://en.wikipedia.org/wiki/Graham%27s_number
Graham's-number : ℕ
Graham's-number = 3 ⇑⟨ 64 , 4 ⟩ 3
  -- = (f∘⁶⁴…∘f)4
  -- where f x = 3 ↑⟨ 2 + x ⟩ 3

{-
module GeneralisedArithmetic {a} {A : Set a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → Set
  m ≈ n = T (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → T (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p ≡.refl

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → Set where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → Bool
zero   <= _      = true
suc _  <= zero   = false
suc m  <= suc n  = m <= n

module <= where
  sound : ∀ m n → T (m <= n) → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → T (m <= n)
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = ⊥-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (≡.sym eq)
... | tri> _ _ 1+n≤m = ≤-pred (Props.≤-steps 1 1+n≤m)

{-# OPTIONS --universe-polymorphism #-}
module Data.Nat.NP where

import Algebra
open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties as Props
open import Data.Bool
open import Data.Product using (proj₁; proj₂; ∃; _,_)
open import Data.Empty using (⊥-elim)
open import Function.NP
open import Relation.Nullary
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning)

module ℕ°   = Algebra.CommutativeSemiring Props.commutativeSemiring
module ℕcmp = StrictTotalOrder Props.strictTotalOrder
module ℕ≤   = DecTotalOrder    decTotalOrder
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ ≡.refl ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → (suc n ∶ ℕ) ≡ suc m → n ≡ m
suc-injective = ≡.cong pred

fold : ∀ {a} {A : Set a} → A → Endo A → ℕ → A
fold x f n = nest n f x

_==_ : (x y : ℕ) → Bool
zero   == zero   = true
zero   == suc _  = false
suc _  == zero   = false
suc m  == suc n  = m == n

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

{-
postulate
  dist-refl  : ∀ x → dist x x ≡ 0
  dist-sym   : ∀ x y → dist x y ≡ dist y x
  dist-sum   : ∀ x y z → dist x y + dist y z ≤ dist x z
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-x+    : ∀ x y z → dist (x + y) (x + z) ≡ dist y z
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
  dist-x*  : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

2*_ : ℕ → ℕ
2* x = x + x

2^_ : ℕ → ℕ
2^ zero  = 1
2^ suc n = 2* 2^ n

-- https://en.wikipedia.org/wiki/Hyper_operator
_↑⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
a ↑⟨ suc n             ⟩ (suc b) = a ↑⟨ n ⟩ (a ↑⟨ suc n ⟩ b)
a ↑⟨ 0                 ⟩ b       = suc b
a ↑⟨ 1                 ⟩ 0       = a
a ↑⟨ 2                 ⟩ 0       = 0
a ↑⟨ suc (suc (suc n)) ⟩ 0       = 1

module ↑-Props where
  ↑-fold : ∀ a n b → a ↑⟨ suc n ⟩ b ≡ fold (a ↑⟨ suc n ⟩ 0) (_↑⟨_⟩_ a n) b
  ↑-fold a n zero = ≡.refl
  ↑-fold a n (suc b) = ≡.cong (_↑⟨_⟩_ a n) (↑-fold a n b)

  ↑₀-+ : ∀ a b → a ↑⟨ 0 ⟩ b ≡ 1 + b
  ↑₀-+ a b = ≡.refl

  ↑₁-+ : ∀ a b → a ↑⟨ 1 ⟩ b ≡ b + a
  ↑₁-+ a zero    = ≡.refl
  ↑₁-+ a (suc b) = ≡.cong suc (↑₁-+ a b)

  ↑₂-* : ∀ a b → a ↑⟨ 2 ⟩ b ≡ b * a
  ↑₂-* a zero    = ≡.refl
  ↑₂-* a (suc b) rewrite ↑₂-* a b
                       | ↑₁-+ a (b * a)
                       | ℕ°.+-comm (b * a) a
                       = ≡.refl

  -- fold 1 (_*_ a) b ≡ a ^ b
  ↑₃-^ : ∀ a b → a ↑⟨ 3 ⟩ b ≡ a ^ b
  ↑₃-^ a zero = ≡.refl
  ↑₃-^ a (suc b) rewrite ↑₃-^ a b
                       | ↑₂-* a (a ^ b)
                       | ℕ°.*-comm (a ^ b) a
                       = ≡.refl

  _↑⟨_⟩0 : ℕ → ℕ → ℕ
  a ↑⟨ 0                 ⟩0 = 1
  a ↑⟨ 1                 ⟩0 = a
  a ↑⟨ 2                 ⟩0 = 0
  a ↑⟨ suc (suc (suc n)) ⟩0 = 1

  _`↑⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
  _`↑⟨_⟩_ a 0       = suc
  _`↑⟨_⟩_ a (suc n) = fold (a ↑⟨ suc n ⟩0) (_`↑⟨_⟩_ a n)

  ↑-ind-rule : ∀ a n b → a ↑⟨ suc n ⟩ (suc b) ≡ a ↑⟨ n ⟩ (a ↑⟨ suc n ⟩ b)
  ↑-ind-rule a n b = ≡.refl

  _↑′⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
  a ↑′⟨ 0 ⟩ b = suc b
  a ↑′⟨ 1 ⟩ b = a + b
  a ↑′⟨ 2 ⟩ b = a * b
  a ↑′⟨ 3 ⟩ b = a ^ b
  a ↑′⟨ suc (suc (suc (suc n))) ⟩ b = a ↑⟨ 4 + n ⟩ b

  ↑-↑′ : ∀ a n b → a ↑⟨ n ⟩ b ≡ a ↑′⟨ n ⟩ b
  ↑-↑′ a 0 b = ≡.refl
  ↑-↑′ a 1 b = ≡.trans (↑₁-+ a b) (ℕ°.+-comm b a)
  ↑-↑′ a 2 b = ≡.trans (↑₂-* a b) (ℕ°.*-comm b a)
  ↑-↑′ a 3 b = ↑₃-^ a b
  ↑-↑′ a (suc (suc (suc (suc _)))) b = ≡.refl

  _↑2+⟨_⟩_ : ℕ → ℕ → ℕ → ℕ
  _↑2+⟨_⟩_ a = fold (_*_ a) (fold 1)

module InflModule where
  -- Inflationary functions
  Infl< : (f : ℕ → ℕ) → Set
  Infl< f = ∀ {x} → x < f x

  Infl : (f : ℕ → ℕ) → Set
  Infl f = Infl< (suc ∘ f)

  InflT< : (f : Endo (Endo ℕ)) → Set
  InflT< f = ∀ {g} → Infl< g → Infl< (f g)

{-
∀ {x} → x ≤ f x

  1 + x ≤ 1 + f x
  x < 1 + f x
  x < (suc ∘ f) x
  Infl< (suc ∘ f)

  Infl< f = ∀ {x} → 1 + x ≤ f x
  Infl< f = ∀ {x} → 1 + x ≤ f x

Infl< f → Infl f
Infl< f → Infl< (suc ∘ f)
-}

  id-infl : Infl id
  id-infl = ℕ≤.refl

  ∘-infl< : ∀ {f g} → Infl< f → Infl< g → Infl< (f ∘ g)
  ∘-infl< inflf< inflg< = <-trans inflg< inflf<

  suc-infl< : Infl< suc
  suc-infl< = ℕ≤.refl

  suc-infl : Infl suc
  suc-infl = s≤s (≤-step ℕ≤.refl)

  nest-infl : ∀ f (finfl : Infl f) n → Infl (nest n f)
  nest-infl f _ zero = ℕ≤.refl
  nest-infl f finfl (suc n) = ℕ≤.trans (nest-infl f finfl n) finfl

  nest-infl< : ∀ f (finfl< : Infl< f) n → Infl< (nest (suc n) f)
  nest-infl< f finfl< zero = finfl<
  nest-infl< f finfl< (suc n) = <-trans (nest-infl< f finfl< n) finfl<

-- See Function.NP.nest-Properties for more properties
module fold-Props where

  fold-suc : ∀ m n → fold m suc n ≡ n + m
  fold-suc m zero = ≡.refl
  fold-suc m (suc n) rewrite fold-suc m n = ≡.refl

  fold-+ : ∀ m n → fold 0 (_+_ m) n ≡ n * m
  fold-+ m zero = ≡.refl
  fold-+ m (suc n) rewrite fold-+ m n = ≡.refl

  fold-* : ∀ m n → fold 1 (_*_ m) n ≡ m ^ n
  fold-* m zero = ≡.refl
  fold-* m (suc n) rewrite fold-* m n = ≡.refl

{- TODO
  fold-^ : ∀ m n → fold 1 (flip _^_ m) n ≡ m ↑⟨ 4 ⟩ n
  fold-^ m zero = ≡.refl
  fold-^ m (suc n) rewrite fold-^ m n = ?
-}

  cong-fold : ∀ {A : Set} {f g : Endo A} (f≗g : f ≗ g) {z} → fold z f ≗ fold z g
  cong-fold eq zero = ≡.refl
  cong-fold eq {z} (suc x) rewrite cong-fold eq {z} x = eq _

  private
   open ↑-Props
   module Alt↑2 where
    alt : ℕ → ℕ → ℕ → ℕ
    alt a 0       = λ b → a ↑⟨ 2 ⟩ b
    alt a (suc n) = fold 1 (alt a n)

    alt-ok : ∀ a n → _↑2+⟨_⟩_ a n ≗ alt a n
    alt-ok a zero = ≡.sym ∘ ↑-↑′ a 2
    alt-ok a (suc n) = cong-fold (alt-ok a n)

{- TODO
    alt' : ∀ a n → _↑2+⟨_⟩_ a n ≗ _↑⟨_⟩_ a (2 + n)
    alt' a zero  b = ≡.sym (↑-↑′ a 2 _)
    alt' a (suc n) zero = ≡.refl
    alt' a (suc n) (suc x) rewrite alt' a n (_↑2+⟨_⟩_ a (suc n) x)
       = ≡.cong (_↑⟨_⟩_ a (2 + n)) { fold 1 (fold (_*_ a) (fold 1) n) x} {a ↑⟨ suc (suc (suc n)) ⟩ x} (alt' a (suc n) x)
-}

  open InflModule
{-
  fold1-infl : ∀ f → Infl f → Infl (fold 1 f)
  fold1-infl f finfl {zero} = {!z≤n!}
  fold1-infl f finfl {suc x} =
     x          <⟨ {!s≤s (fold1-infl f finfl {x})!} ⟩
     fold 1 f x <⟨ {!!} ⟩
     {- f (fold 1 f x) ≤⟨ finfl ⟩
     f (fold 1 f x) ≡⟨ ≡.refl ⟩ -}
     fold 1 f (1 + x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}

{-
  fold1+1-infl< : ∀ (f : ℕ → ℕ) → Infl< (f ∘ suc) → Infl< (fold 1 f ∘ suc)
  fold1+1-infl< f finfl< {zero} = finfl<
  fold1+1-infl< f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1+1-infl< f finfl< {x}) ⟩
     1 + f (fold 1 f x) ≤⟨ finfl< {f (fold 1 f x)} ⟩
     f (suc (f (fold 1 f x))) ≤⟨ {!!} ⟩
     fold 1 f (2 + x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
{-
  fold1+1-infl< : ∀ (f : ℕ → ℕ) → Infl< (f ∘ suc) → Infl< (fold 1 (f ∘ suc))
  fold1+1-infl< f finfl< {zero} = s≤s z≤n
  fold1+1-infl< f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1+1-infl< f finfl< {x}) ⟩
     1 + fold 1 (f ∘ suc) x ≤⟨ finfl< ⟩
     fold 1 (f ∘ suc) (suc x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
{-
  fold1+-infl< : ∀ k f → Infl< (f ∘′ _+_ k) → Infl< (fold 1 (f ∘′ _+_ k))
  fold1+-infl< k f finfl< {zero} = s≤s z≤n
  fold1+-infl< k f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1+-infl< k f finfl< {x}) ⟩
     1 + fold 1 (f ∘ _+_ k) x ≤⟨ finfl< ⟩
     fold 1 (f ∘ _+_ k) (suc x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}

{-
  fold1+-infl< : ∀ f → Infl+2< f → Infl+2< (fold 1 f)
  fold1+-infl< f finfl< {zero} _ = ℕ≤.refl
  fold1+-infl< f finfl< {suc zero} _ = {!!}
  fold1+-infl< f finfl< {suc (suc zero)} _ = {!!}
  fold1+-infl< f finfl< {suc (suc (suc x))} x>1 =
     4 + x ≤⟨ s≤s (fold1+-infl< f finfl< {suc (suc x)} (m≤m+n 2 x)) ⟩
     1 + fold 1 f (2 + x) ≤⟨ finfl< {!!} ⟩
     fold 1 f (3 + x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
{-
  fold1-infl< f finfl< {zero} = s≤s z≤n
  fold1-infl< f finfl< {suc x} =
     2 + x ≤⟨ s≤s (fold1-infl< f finfl< {x}) ⟩
     1 + fold 1 f x ≤⟨ finfl< ⟩
     fold 1 f (suc x)
   ∎
     where
       open Props
       open ≤-Reasoning
-}
module ^-Props where
  open ≡-Reasoning

  ^1 : ∀ n → n ^ 1 ≡ n
  ^1 zero = ≡.refl
  ^1 (suc n) = ≡.cong suc (proj₂ ℕ°.*-identity n)

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b zero n = ≡.sym (proj₂ ℕ°.+-identity (b ^ n))
  ^-+ b (suc m) n rewrite ^-+ b m n = ≡.sym (ℕ°.*-assoc b (b ^ m) (b ^ n))

  ^-* : ∀ b m n → b ^ (m * n) ≡ (b ^ n) ^ m
  ^-* b zero    n = ≡.refl
  ^-* b (suc m) n = b ^ (n + m * n)
                  ≡⟨ ^-+ b n (m * n) ⟩
                    b ^ n * b ^ (m * n)
                  ≡⟨ ≡.cong (_*_ (b ^ n)) (^-* b m n) ⟩
                    b ^ n * (b ^ n) ^ m ∎

ack : ℕ → ℕ → ℕ
ack zero n          = suc n
ack (suc m) zero    = ack m (suc zero)
ack (suc m) (suc n) = ack m (ack (suc m) n)

module ack-Props where
  lem∸ : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n
  lem∸ z≤n = ≡.refl
  lem∸ (s≤s {m} {n} m≤n) = ≡.cong suc (lem∸ m≤n)

  -- n >= m → m + (n ∸ m) ≡ n
  -- n >= m → ∃ k → n ≡ m + k
  -- ∃ k → n ≡ m + k → m + (n ∸ m) ≡ n
  -- ∀ k → n ≡ m + k → m + (n ∸ m) ≡ n
  -- ∀ k → m + ((m + k) ∸ m) ≡ m + k
  -- ∀ k → m + k ≡ m + k

  -- 3 ≤ x → P x → ∃ λ k → P (3 + k)

  open InflModule

  fold1+-inflT< : ∀ {z} → InflT< (fold (suc z))
  fold1+-inflT<     _      {zero} = s≤s z≤n
  fold1+-inflT< {z} {f} finfl< {suc x} =
     2 + x                ≤⟨ s≤s (fold1+-inflT< {z} {f} finfl< {x}) ⟩
     1 + fold (suc z) f x ≤⟨ finfl< ⟩
     f (fold (suc z) f x) ≡⟨ ≡.refl ⟩
     fold (suc z) f (1 + x)
   ∎
     where open ≤-Reasoning

  Mon : (f : ℕ → ℕ) → Set
  Mon f = ∀ {x y} → x ≤ y → f x ≤ f y
  open InflModule

  ℕ-ind : ∀ (P : ℕ → Set) → P zero → (∀ {n} → P n → P (suc n)) → ∀ {n} → P n
  ℕ-ind P P0 PS {zero} = P0
  ℕ-ind P P0 PS {suc n} = PS (ℕ-ind P P0 PS)

  open fold-Props
  fold-infl< : ∀ {f g} → Infl< f → InflT< g → ∀ {n} → Infl< (fold f g n)
  fold-infl< {f} {g} inflf< inflTg< {n} = ℕ-ind (Infl< ∘ fold f g) inflf< inflTg< {n}

  fold-mon : ∀ {f} (fmon : Mon f) (finfl< : Infl< f) {z} → Mon (fold z f)
  fold-mon fmon finfl< {_} {y = 0} z≤n = ℕ≤.refl
  fold-mon {f} fmon finfl< {z} {y = suc n} z≤n = z ≤⟨ ≤-step ℕ≤.refl ⟩
                                              suc z ≤⟨ nest-infl< f finfl< n {z} ⟩
                                              fold z f (suc n) ≡⟨ ≡.refl ⟩
                                              fold z f (suc n) ∎
    where open ≤-Reasoning
  fold-mon fmon finfl< (s≤s m≤n) = fmon (fold-mon fmon finfl< m≤n)

  MonT : Endo (Endo ℕ) → Set
  MonT g = ∀ {f} → Mon f → Infl< f → Mon (g f)

  fold-mon' : ∀ {f g} → Mon f → Infl< f → MonT g → InflT< g → ∀ {n} → Mon (fold f g n)
  fold-mon' {f} {g} mon-f infl-f mont-g inflTg< {n} = go n where
    go : ∀ n → Mon (fold f g n)
    go zero    = mon-f
    go (suc n) = mont-g (go n) (fold-infl< infl-f inflTg< {n})

  --  +-fold : ∀ a b → a + b ≡ fold a suc b
  --  *-fold : ∀ a b → a * b ≡ fold 0 (_+_ a) b

  1≤1+a^b : ∀ a b → 1 ≤ (1 + a) ^ b
  1≤1+a^b a zero = s≤s z≤n
  1≤1+a^b a (suc b) = 1≤1+a^b a b +-mono z≤n

  1+a^-mon : ∀ {a} → Mon (_^_ (1 + a))
  1+a^-mon {a} (z≤n {b}) = 1≤1+a^b a b
  1+a^-mon {a} (s≤s {m} {n} m≤n)
     = (1 + a) ^ (1 + m)             ≡⟨ ≡.refl ⟩
       (1 + a) ^ m + a * (1 + a) ^ m ≤⟨ (1+a^-mon m≤n) +-mono ((a ∎) *-mono (1+a^-mon m≤n)) ⟩
       (1 + a) ^ n + a * (1 + a) ^ n ≡⟨ ≡.refl ⟩
       (1 + a) ^ (1 + n) ∎
    where open ≤-Reasoning

  postulate
    ↑3+ : ∀ a n b → a ↑⟨ 3 + n ⟩ b ≡ fold (_^_ a) (fold 1) n b
    -- mon↑3+'' : ∀ a b → Mon (λ n → fold (_^_ a) (fold 1) n b)

    mon↑3+' : ∀ b → Mon (λ n → fold (_^_ 2) (fold 1) n (3 + b))
  -- mon↑3+' b = {!!}

  mon↑3+ : ∀ b → Mon (λ n → 2 ↑⟨ 3 + n ⟩ (3 + b))
  mon↑3+ b {m} {n} rewrite ↑3+ 2 m (3 + b) | ↑3+ 2 n (3 + b) = mon↑3+' b

  lem2^3 : ∀ n → 2 ^ 3 ≤ 2 ^ (3 + n)
  lem2^3 n = 1+a^-mon {1} {3} {3 + n} (s≤s (s≤s (s≤s z≤n)))

  open ↑-Props
  lem>=3 : ∀ m n → 3 ≤ 2 ↑⟨ 3 + m ⟩ (3 + n)
  lem>=3 m n = 3 ≤⟨ s≤s (s≤s (s≤s z≤n)) ⟩
               2 ↑⟨ 3 ⟩ 3 ≡⟨ ↑₃-^ 2 3 ⟩
               2 ^ 3 ≤⟨ lem2^3 n ⟩
               2 ^ (3 + n) ≡⟨ ≡.sym (↑₃-^ 2 (3 + n)) ⟩
               2 ↑⟨ 3 ⟩ (3 + n) ≤⟨ mon↑3+ n z≤n ⟩
               2 ↑⟨ 3 + m ⟩ (3 + n) ∎
    where open ≤-Reasoning

  2* = _*_ 2

  -- fold 2* n 1 ≡ 2 ^ n

  -- nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)

  nest-2* : ∀ m n → nest (m * n) (fold 1) 2* ≡ nest m (nest n (fold 1)) 2*
  nest-2* m n = nest-Properties.nest-* (fold 1) m n 2*

{-
  lem3≤ : ∀ n → 3 ≤ fold 2* (fold 1) n 2
  lem3≤ 0 = s≤s (s≤s (s≤s z≤n))
    where open ≤-Reasoning
  lem3≤ (suc n) =
    3 ≤⟨ {!!} ⟩
    fold 2* f1 (1 + n) 2 ∎
    where open ≤-Reasoning
          f1 = fold 1

  lem3≤' : ∀ n → 3 ≤ fold 2* (fold 1) n 3
  lem3≤' 0 = s≤s (s≤s (s≤s z≤n))
    where open ≤-Reasoning
  lem3≤' (suc n) =
    3 ≤⟨ lem3≤ n ⟩
    fold 2* (fold 1) n 2 ≡⟨ ≡.refl ⟩
    fold 2* (fold 1) n (fold 2* (fold 1) 3 1) ≡⟨ {!!} ⟩
{- ≡⟨ nest-Properties.nest-* {!2*!} {!!} {!!} {!!} ⟩
    fold 2* (fold 1) (3 * n) 1 ≡⟨ {!!} ⟩
-}
    fold 1 (fold 2* (fold 1) n) 3 ≡⟨ ≡.refl ⟩
    fold 2* (fold 1) (1 + n) 3 ∎
    where open ≤-Reasoning
-}
---

{-
fold 2* (fold 1) (3 * n) 1 ≤

fold 2* (fold 1) n (fold 2* (fold 1) n (fold 2* (fold 1) n 1)) ≤

fold 1 (fold 2* (fold 1) n) 3 ≤
fold 2* (fold 1) (1 + n) 3
-}

  lem>=3'' : ∀ m n → 3 ≤ 2 ↑⟨ suc m ⟩ (3 + n)
  lem>=3'' zero n = s≤s (s≤s (s≤s z≤n))
  lem>=3'' (suc zero) n rewrite ↑₂-* 2 (3 + n) = s≤s (s≤s (s≤s z≤n))
  lem>=3'' (suc (suc m)) n = lem>=3 m n

  lem2221 : ∀ m → 2 ≡ 2 ↑⟨ 2 + m ⟩ 1
  lem2221 zero = ≡.refl
  lem2221 (suc m) = lem2221 m

  lem4212 : ∀ m → 4 ≡ 2 ↑⟨ 1 + m ⟩ 2
  lem4212 zero = ≡.refl
  lem4212 (suc m) = 4                            ≡⟨ lem4212 m ⟩
                    2 ↑⟨ 1 + m ⟩ 2               ≡⟨ ≡.cong (_↑⟨_⟩_ 2 (1 + m)) (lem2221 m) ⟩
                    2 ↑⟨ 1 + m ⟩ (2 ↑⟨ 2 + m ⟩ 1) ≡⟨ ≡.refl ⟩
                    2 ↑⟨ 2 + m ⟩ 2 ∎
    where open ≡-Reasoning

  ack-↑ : ∀ m n → 3 + ack m n ≡ 2 ↑⟨ m ⟩ (3 + n)
  ack-↑ zero n = ≡.refl
  ack-↑ (suc m) zero = 3 + ack (suc m) 0   ≡⟨ ack-↑ m 1 ⟩
                       2 ↑⟨ m ⟩ 4          ≡⟨ ≡.cong (_↑⟨_⟩_ 2 m) (lem4212 m) ⟩
                       2 ↑⟨ suc m ⟩ 3 ∎
    where open ≡-Reasoning
  ack-↑ (suc m) (suc n) = 3 + ack (suc m) (suc n)
                        ≡⟨ ≡.refl ⟩
                          3 + ack m (ack (suc m) n)
                        ≡⟨ ≡.refl ⟩
                          3 + ack m ((3 + ack (suc m) n) ∸ 3)
                        ≡⟨ ≡.cong (λ x → 3 + ack m (x ∸ 3)) (ack-↑ (suc m) n) ⟩
                           3 + ack m (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3)
                        ≡⟨ ack-↑ m (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3) ⟩
                           2 ↑⟨ m ⟩ (3 + (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3))
                        ≡⟨ ≡.cong (λ x → 2 ↑⟨ m ⟩ x) (lem∸ (lem>=3'' m n)) ⟩
                           2 ↑⟨ m ⟩ (2 ↑⟨ suc m ⟩ (3 + n))
                        ≡⟨ ≡.refl ⟩
                          2 ↑⟨ suc m ⟩ (4 + n) ∎
    where open ≡-Reasoning

  postulate
    1+a^-infl< : ∀ {a}  → Infl< (_^_ (1 + a))

  --  2+a*1+b-infl< : ∀ a → Infl< (λ x → (2 + a) * (1 + x))
  -- ∀ a b → b < (2 + a) * b
  -- fold-a*-fold1 : ∀ {n a} → Infl< (_↑2+⟨_⟩_ (2 + a) n)
  fold-a^-fold1 : ∀ {n a} → Infl< (fold (_^_ (1 + a)) (fold 1) n)
  fold-a^-fold1 {n} = fold-infl< 1+a^-infl< fold1+-inflT< {n}

  ↑3+-mon : ∀ a n → Mon (fold (_^_ (1 + a)) (fold 1) n)
  ↑3+-mon a n = fold-mon' 1+a^-mon 1+a^-infl< (λ η₁ η₂ → fold-mon η₁ η₂) fold1+-inflT< {n}

{-
  open ↑-Props

  -*⟨1+n⟩-infl : ∀ n → Infl (_*_ (1 + n))
  -*⟨1+n⟩-infl n = {!!}

  lem121 : ∀ a b → b < (1 + a) ↑⟨ 2 ⟩ (1 + b)
  lem121 a b rewrite ↑₂-* (1 + a) (1 + b)
     = 1 + b
              ≤⟨ m≤m+n _ _ ⟩
       (1 + a) * (1 + b)
              ≡⟨ ℕ°.*-comm (1 + a) (1 + b) ⟩
       (1 + b) * (1 + a)
     ∎
     where open ≤-Reasoning

  -- ∀ a b → b < (2 + a) * b
  lem222 : ∀ a b → b < (2 + a) ↑⟨ 2 ⟩ (2 + b)
  lem222 a b rewrite ↑₂-* (2 + a) (2 + b)
     = 1 + b
              ≤⟨ suc-infl ⟩
       2 + b
              ≤⟨ m≤m+n _ _ ⟩
       (2 + a) * (2 + b)
              ≡⟨ ℕ°.*-comm (2 + a) (2 + b) ⟩
       (2 + b) * (2 + a)
     ∎
     where open ≤-Reasoning
-}
{-
  open fold-Props

  module Foo a where
    f = λ n b → (2 + a) ↑2+⟨ n ⟩ b
    f-lem : ∀ n → f (suc n) ≗ fold 1 (f n)
    f-lem n x = ≡.refl

    f2 = λ n b → (2 + a) ↑2+⟨ n ⟩ (2 + b)
    f2-lem : ∀ n → f2 (suc n) ≗ fold 1 (f2 n)
    f2-lem n x = {!!}

  -- b < (1 + a) * (1 + b)

 -- nest-infl< : ∀ f (finfl< : Infl< f) n → Infl< (nest (suc n) f)
  infl3< : ∀ a n → Infl< (λ b → (1 + a) ↑2+⟨ n ⟩ (1 + b))
  infl3< a zero {b} = lem121 a b
  infl3< a (suc n) {b}
    = 1 + b
 --  fold1-infl< : ∀ f → Infl< f → ∀ x → x < fold 1 f x
            ≤⟨ {!fold1f2-infl< {_}!} ⟩
      fold 1 f1 b
            ≤⟨ {!!} ⟩
{-
            ≤⟨ fold1-infl< (f 0) (λ {x} → {!infl3< a n {x}!}) {{!!}} ⟩
      {!!}
            ≤⟨ {!!} ⟩
-}
{-
      1 + b
      (2 + a) ↑2+⟨ n ⟩ (2 + b)
            ≤⟨ {!nest-infl< (λ b → (2 + a) ↑2+⟨ n ⟩ b) ? b {(2 + a) ↑2+⟨ n ⟩ (2 + b)}!} ⟩
      fold (f 0 1) (f 0) (1 + b)
            ≤⟨ {!ℕ≤.reflexive (≡.cong (λ g → g 1) (nest-Properties.nest-+ (f 0) 1 (1 + b)))!} ⟩
-}
      fold 1 (f 0) (1 + b)
            ≡⟨ ≡.refl ⟩
      f 1 (1 + b)
            ≡⟨ ≡.refl ⟩
      (1 + a) ↑2+⟨ suc n ⟩ (1 + b)
    ∎

     where
       f = λ k b → (1 + a) ↑2+⟨ k + n ⟩ b
       f1 = f 0 ∘ suc

       -- fold1f2-infl< : Infl< (fold 1 f2)
       -- fold1f2-infl< = fold1-infl< f2 {!(λ b → infl3< a n b ?)!}

       fold1f1-infl<' : Infl< (fold 1 f1)
       fold1f1-infl<' = {!fold1+1-infl< (f 0) {!infl3< a n!}!}
       lem : ∀ x → f 0 (1 + x) < f 0 (f 0 x)
       lem x = {!!}
       postulate
         finfl : Infl< (f 0)
       open ≤-Reasoning
-}

_⇑⟨_,_⟩_ : (a n k b : ℕ) → ℕ
a ⇑⟨ n , k ⟩ b = fold k f n
  module M⇑ where
    f : ℕ → ℕ
    f x = a ↑⟨ 2 + x ⟩ b

module ⇑-Props where
  _⇑′⟨_,_⟩_ : (a n k b : ℕ) → ℕ
  a ⇑′⟨ n₀ , k ⟩ b = g n₀
    module M⇑′ where
      h : ℕ → ℕ
      h x = a ↑⟨ 2 + x ⟩ b

      g : ℕ → ℕ
      g 0       = k
      g (suc n) = h (g n)

      g-nest : ∀ n → g n ≡ h $⟨ n ⟩ k
      g-nest zero = ≡.refl
      g-nest (suc n) rewrite g-nest n = ≡.refl

  ⇑₀ : ∀ a k b → a ⇑⟨ 0 , k ⟩ b ≡ k
  ⇑₀ _ _ _ = ≡.refl

  ⇑₁ : ∀ a k b → a ⇑⟨ 1 , k ⟩ b ≡ a ↑⟨ 2 + k ⟩ b
  ⇑₁ _ _ _ = ≡.refl

  ⇑-⇑′ : ∀ a n k b → a ⇑⟨ n , k ⟩ b ≡ a ⇑′⟨ n , k ⟩ b
  ⇑-⇑′ a n k b rewrite M⇑′.g-nest a n k b n = ≡.refl

-- https://en.wikipedia.org/wiki/Graham%27s_number
Graham's-number : ℕ
Graham's-number = 3 ⇑⟨ 64 , 4 ⟩ 3
  -- = (f∘⁶⁴…∘f)4
  -- where f x = 3 ↑⟨ 2 + x ⟩ 3

{-
module GeneralisedArithmetic {a} {A : Set a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → Set
  m ≈ n = T (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → T (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p ≡.refl

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → Set where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → Bool
zero   <= _      = true
suc _  <= zero   = false
suc m  <= suc n  = m <= n

module <= where
  sound : ∀ m n → T (m <= n) → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → T (m <= n)
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = ⊥-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (≡.sym eq)
... | tri> _ _ 1+n≤m = ≤-pred (Props.≤-steps 1 1+n≤m)