Also curry index arguments of eliminators.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
open import Function
module Spire.Examples.DarkwingDuck where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Branches : (E : Enum) (P : Tag E → Set) → Set
Branches [] P = ⊤
Branches (l ∷ E) P = P here × Branches E (λ t → P (there t))

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Tel : Set where
  End : Tel
  Arg : (A : Set) (B : A → Tel) → Tel

Elᵀ  : Tel → Set
Elᵀ End = ⊤
Elᵀ (Arg A B) = Σ A (λ a → Elᵀ (B a))

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

data Desc (I : Set) : Set where
  End : (i : I) → Desc I
  Rec : (i : I) (D : Desc I) → Desc I
  Arg : (A : Set) (B : A → Desc I) → Desc I

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

ISet : Set → Set
ISet I = I → Set

Elᴰ : {I : Set} (D : Desc I) → ISet I → ISet I
Elᴰ (End j) X i = j ≡ i
Elᴰ (Rec j D) X i = X j × Elᴰ D X i
Elᴰ (Arg A B) X i = Σ A (λ a → Elᴰ (B a) X i)

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : Elᴰ D X i) → Set
Hyps (End j) X P i q = ⊤
Hyps (Rec j D) X P i (x , xs) = P j x × Hyps D X P i xs
Hyps (Arg A B) X P i (a , b) = Hyps (B a) X P i b

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

data μ {I : Set} (D : Desc I) (i : I) : Set where
  init : Elᴰ D (μ D) i → μ D i

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

ind : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (α : ∀ i (xs : Elᴰ D (μ D) i) (ihs : Hyps D (μ D) M i xs) → M i (init xs))
  (i : I)
  (x : μ D i)
  → M i x

prove : {I : Set} (D E : Desc I)
  (M : (i : I) → μ E i → Set)
  (α : ∀ i (xs : Elᴰ E (μ E) i) (ihs : Hyps E (μ E) M i xs) → M i (init xs))
  (i : I) (xs : Elᴰ D (μ E) i) → Hyps D (μ E) M i xs

ind D M α i (init xs) = α i xs (prove D D M α i xs)

prove (End j) E M α i q = tt
prove (Rec j D) E M α i (x , xs) = ind E M α j x , prove D E M α i xs
prove (Arg A B) E M α i (a , xs) = prove (B a) E M α i xs

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

record Data : Set where
  field
    P : Tel
    I : Elᵀ P → Tel
    E : Enum
    B : (A : Elᵀ P) → Branches E (λ _ → Desc (Elᵀ (I A)))

  C : (A : Elᵀ P) → Tag E → Desc (Elᵀ (I A))
  C A = case (λ _ → Desc (Elᵀ (I A))) (B A)

  D : (A : Elᵀ P) → Desc (Elᵀ (I A))
  D A = Arg (Tag E) (C A)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches [] P X = X
CurriedBranches (l ∷ E) P X = P here → CurriedBranches E (λ t → P (there t)) X

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

UncurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
UncurriedElᵀ T X = (xs : Elᵀ T) → X xs

CurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
CurriedElᵀ End X = X tt
CurriedElᵀ (Arg A B) X = (a : A) → CurriedElᵀ (B a) (λ b → X (a , b))

curryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → CurriedElᵀ T X
curryElᵀ End X f = f tt
curryElᵀ (Arg A B) X f = λ a → curryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

uncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → CurriedElᵀ T X → UncurriedElᵀ T X
uncurryElᵀ End X x tt = x
uncurryElᵀ (Arg A B) X f (a , b) = uncurryElᵀ (B a) (λ b → X (a , b)) (f a) b

ICurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
ICurriedElᵀ End X = X tt
ICurriedElᵀ (Arg A B) X = {a : A} → ICurriedElᵀ (B a) (λ b → X (a , b))

icurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → ICurriedElᵀ T X
icurryElᵀ End X f = f tt
icurryElᵀ (Arg A B) X f = λ {a} → icurryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

iuncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → ICurriedElᵀ T X → UncurriedElᵀ T X
iuncurryElᵀ End X x tt = x
iuncurryElᵀ (Arg A B) X f (a , b) = iuncurryElᵀ (B a) (λ b → X (a , b)) f b

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

UncurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedElᴰ D X = ∀{i} → Elᴰ D X i → X i

CurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedElᴰ (End i) X = X i
CurriedElᴰ (Rec i D) X = (x : X i) → CurriedElᴰ D X
CurriedElᴰ (Arg A B) X = (a : A) → CurriedElᴰ (B a) X

curryElᴰ : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedElᴰ D X → CurriedElᴰ D X
curryElᴰ (End i) X cn = cn refl
curryElᴰ (Rec i D) X cn = λ x → curryElᴰ D X (λ xs → cn (x , xs))
curryElᴰ (Arg A B) X cn = λ a → curryElᴰ (B a) X (λ xs → cn (a , xs))

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : Elᴰ D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
CurriedHyps (End i) X P cn =
  P i (cn refl)
CurriedHyps (Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps D X P (λ xs → cn (x , xs))
CurriedHyps (Arg A B) X P cn =
  (a : A) → CurriedHyps (B a) X P (λ xs → cn (a , xs))

curryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → UncurriedHyps D X P cn
  → CurriedHyps D X P cn
curryHyps (End i) X P cn pf =
  pf i refl tt
curryHyps (Rec i D) X P cn pf =
  λ x ih → curryHyps D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps (Arg A B) X P cn pf =
  λ a → curryHyps (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps (End .i) X P cn pf i refl tt =
  pf
uncurryHyps (Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps (Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs

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

FormUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → UncurriedElᵀ (Data.I R p) λ i
  → Set
FormUncurried R p i = μ (Data.D R p) i

Form : (R : Data)
  → CurriedElᵀ (Data.P R) λ p
  → CurriedElᵀ (Data.I R p) λ i
  → Set
Form R =
  curryElᵀ (Data.P R) (λ p → CurriedElᵀ (Data.I R p) λ i → Set) λ p →
  curryElᵀ (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
injUncurried R p t = curryElᴰ (Data.C R p t)
  (μ (Data.D R p))
  (λ xs → init (t , xs))

inj : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
inj R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in CurriedElᴰ D (μ D))
  (injUncurried R)

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

indCurried : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (f : CurriedHyps D (μ D) M init)
  (i : I)
  (x : μ D i)
  → M i x
indCurried D M f i x =
  ind D M (uncurryHyps D (μ D) M init f) i x

SumCurriedHyps : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  let unM = uncurryElᵀ (Data.I R p) (λ i → μ (Data.D R p) i → Set) M in
  CurriedHyps (Data.C R p t) (μ (Data.D R p)) unM (λ xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in UncurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x))
elimUncurried R p M cs =
  let D = Data.D R p
      unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in
  curryElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x) λ i x →
  indCurried (Data.D R p) unM
    (case (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in CurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x))
elim R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in
    (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
    → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
    in CurriedBranches (Data.E R)
       (SumCurriedHyps R p M)
       (CurriedElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x)))
  (λ p M → curryBranches
    (elimUncurried R p M))

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

ℕE : Enum
ℕE = "zero" ∷ "suc" ∷ []

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

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

ℕR : Data
ℕR = record
  { P = End
  ; I = λ _ → End
  ; E = ℕE
  ; B = λ _ →
      End tt
    , Rec tt (End tt)
    , tt
  }

ℕ : Set
ℕ = Form ℕR

zero : ℕ
zero = inj ℕR zeroT

suc : ℕ → ℕ
suc = inj ℕR sucT

VecR : Data
VecR = record
  { P = Arg Set (λ _ → End)
  ; I = λ _ → Arg ℕ (λ _ → End)
  ; E = VecE
  ; B = λ A →
      End (zero , tt)
    , Arg ℕ (λ n → Arg (proj₁ A) λ _ → Rec (n , tt) (End (suc n , tt)))
    , tt
  }

Vec : (A : Set) → ℕ → Set
Vec = Form VecR

nil : {A : Set} → Vec A zero
nil = inj VecR nilT

cons : {A : Set} (n : ℕ) (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR consT

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

add : ℕ → ℕ → ℕ
add = elim ℕR (λ n → ℕ → ℕ)
  (λ n → n)
  (λ m ih n → suc (ih n))

mult : ℕ → ℕ → ℕ
mult = elim ℕR (λ n → ℕ → ℕ)
  (λ n → zero)
  (λ m ih n → add n (ih n))

append : {A : Set} (m : ℕ) (xs : Vec A m) (n : ℕ) (ys : Vec A n) → Vec A (add m n)
append {A} = elim VecR (λ m xs → (n : ℕ) (ys : Vec A n) → Vec A (add m n))
  (λ n ys → ys)
  (λ m x xs ih n ys → cons (add m n) x (ih n ys))

concat : {A : Set} (m n : ℕ) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat {A} m = elim VecR (λ n xss → Vec A (mult n m))
  nil
  (λ n xs xss ih → append m xs (mult n m) ih)

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

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
open import Function
module Spire.Examples.DarkwingDuck where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Branches : (E : Enum) (P : Tag E → Set) → Set
Branches [] P = ⊤
Branches (l ∷ E) P = P here × Branches E (λ t → P (there t))

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Tel : Set where
  End : Tel
  Arg : (A : Set) (B : A → Tel) → Tel

Elᵀ  : Tel → Set
Elᵀ End = ⊤
Elᵀ (Arg A B) = Σ A (λ a → Elᵀ (B a))

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

data Desc (I : Set) : Set where
  End : (i : I) → Desc I
  Rec : (i : I) (D : Desc I) → Desc I
  Arg : (A : Set) (B : A → Desc I) → Desc I

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

ISet : Set → Set
ISet I = I → Set

Elᴰ : {I : Set} (D : Desc I) → ISet I → ISet I
Elᴰ (End j) X i = j ≡ i
Elᴰ (Rec j D) X i = X j × Elᴰ D X i
Elᴰ (Arg A B) X i = Σ A (λ a → Elᴰ (B a) X i)

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : Elᴰ D X i) → Set
Hyps (End j) X P i q = ⊤
Hyps (Rec j D) X P i (x , xs) = P j x × Hyps D X P i xs
Hyps (Arg A B) X P i (a , b) = Hyps (B a) X P i b

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

data μ {I : Set} (D : Desc I) (i : I) : Set where
  init : Elᴰ D (μ D) i → μ D i

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

ind : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (α : ∀ i (xs : Elᴰ D (μ D) i) (ihs : Hyps D (μ D) M i xs) → M i (init xs))
  (i : I)
  (x : μ D i)
  → M i x

prove : {I : Set} (D E : Desc I)
  (M : (i : I) → μ E i → Set)
  (α : ∀ i (xs : Elᴰ E (μ E) i) (ihs : Hyps E (μ E) M i xs) → M i (init xs))
  (i : I) (xs : Elᴰ D (μ E) i) → Hyps D (μ E) M i xs

ind D M α i (init xs) = α i xs (prove D D M α i xs)

prove (End j) E M α i q = tt
prove (Rec j D) E M α i (x , xs) = ind E M α j x , prove D E M α i xs
prove (Arg A B) E M α i (a , xs) = prove (B a) E M α i xs

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

record Data : Set where
  field
    P : Tel
    I : Elᵀ P → Tel
    E : Enum
    B : (A : Elᵀ P) → Branches E (λ _ → Desc (Elᵀ (I A)))

  C : (A : Elᵀ P) → Tag E → Desc (Elᵀ (I A))
  C A = case (λ _ → Desc (Elᵀ (I A))) (B A)

  D : (A : Elᵀ P) → Desc (Elᵀ (I A))
  D A = Arg (Tag E) (C A)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches [] P X = X
CurriedBranches (l ∷ E) P X = P here → CurriedBranches E (λ t → P (there t)) X

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

UncurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
UncurriedElᵀ T X = (xs : Elᵀ T) → X xs

CurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
CurriedElᵀ End X = X tt
CurriedElᵀ (Arg A B) X = (a : A) → CurriedElᵀ (B a) (λ b → X (a , b))

curryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → CurriedElᵀ T X
curryElᵀ End X f = f tt
curryElᵀ (Arg A B) X f = λ a → curryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

uncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → CurriedElᵀ T X → UncurriedElᵀ T X
uncurryElᵀ End X x tt = x
uncurryElᵀ (Arg A B) X f (a , b) = uncurryElᵀ (B a) (λ b → X (a , b)) (f a) b

ICurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
ICurriedElᵀ End X = X tt
ICurriedElᵀ (Arg A B) X = {a : A} → ICurriedElᵀ (B a) (λ b → X (a , b))

icurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → ICurriedElᵀ T X
icurryElᵀ End X f = f tt
icurryElᵀ (Arg A B) X f = λ {a} → icurryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

iuncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → ICurriedElᵀ T X → UncurriedElᵀ T X
iuncurryElᵀ End X x tt = x
iuncurryElᵀ (Arg A B) X f (a , b) = iuncurryElᵀ (B a) (λ b → X (a , b)) f b

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

UncurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedElᴰ D X = ∀{i} → Elᴰ D X i → X i

CurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedElᴰ (End i) X = X i
CurriedElᴰ (Rec i D) X = (x : X i) → CurriedElᴰ D X
CurriedElᴰ (Arg A B) X = (a : A) → CurriedElᴰ (B a) X

curryElᴰ : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedElᴰ D X → CurriedElᴰ D X
curryElᴰ (End i) X cn = cn refl
curryElᴰ (Rec i D) X cn = λ x → curryElᴰ D X (λ xs → cn (x , xs))
curryElᴰ (Arg A B) X cn = λ a → curryElᴰ (B a) X (λ xs → cn (a , xs))

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : Elᴰ D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
CurriedHyps (End i) X P cn =
  P i (cn refl)
CurriedHyps (Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps D X P (λ xs → cn (x , xs))
CurriedHyps (Arg A B) X P cn =
  (a : A) → CurriedHyps (B a) X P (λ xs → cn (a , xs))

curryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → UncurriedHyps D X P cn
  → CurriedHyps D X P cn
curryHyps (End i) X P cn pf =
  pf i refl tt
curryHyps (Rec i D) X P cn pf =
  λ x ih → curryHyps D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps (Arg A B) X P cn pf =
  λ a → curryHyps (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps (End .i) X P cn pf i refl tt =
  pf
uncurryHyps (Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps (Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs

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

FormUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → UncurriedElᵀ (Data.I R p) λ i
  → Set
FormUncurried R p i = μ (Data.D R p) i

Form : (R : Data)
  → CurriedElᵀ (Data.P R) λ p
  → CurriedElᵀ (Data.I R p) λ i
  → Set
Form R =
  curryElᵀ (Data.P R) (λ p → CurriedElᵀ (Data.I R p) λ i → Set) λ p →
  curryElᵀ (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
injUncurried R p t = curryElᴰ (Data.C R p t)
  (μ (Data.D R p))
  (λ xs → init (t , xs))

inj : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
inj R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in CurriedElᴰ D (μ D))
  (injUncurried R)

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

indCurried : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (f : CurriedHyps D (μ D) M init)
  (i : I)
  (x : μ D i)
  → M i x
indCurried D M f i x =
  ind D M (uncurryHyps D (μ D) M init f) i x

SumCurriedHyps : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : ∀ i → μ D i → Set)
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  CurriedHyps (Data.C R p t) (μ (Data.D R p)) M (λ xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : UncurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → UncurriedBranches (Data.E R)
    (SumCurriedHyps R p M)
    (∀ i (x : μ D i) → M i x)
elimUncurried R p M cs i x =
  indCurried (Data.D R p) M
    (case (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in CurriedBranches (Data.E R)
     (SumCurriedHyps R p unM)
     (∀ i (x : μ D i) → unM i x)
elim R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in
    (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
    → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
    in CurriedBranches (Data.E R)
       (SumCurriedHyps R p unM)
       (∀ i (x : μ D i) → unM i x))
  (λ p M → curryBranches
    (elimUncurried R p
      (uncurryElᵀ (Data.I R p)
        ((λ i → μ (Data.D R p) i → Set)) M)))

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

ℕE : Enum
ℕE = "zero" ∷ "suc" ∷ []

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

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

ℕR : Data
ℕR = record
  { P = End
  ; I = λ _ → End
  ; E = ℕE
  ; B = λ _ →
      End tt
    , Rec tt (End tt)
    , tt
  }

ℕ : Set
ℕ = Form ℕR

zero : ℕ
zero = inj ℕR zeroT

suc : ℕ → ℕ
suc = inj ℕR sucT

VecR : Data
VecR = record
  { P = Arg Set (λ _ → End)
  ; I = λ _ → Arg ℕ (λ _ → End)
  ; E = VecE
  ; B = λ A →
      End (zero , tt)
    , Arg ℕ (λ n → Arg (proj₁ A) λ _ → Rec (n , tt) (End (suc n , tt)))
    , tt
  }

Vec : (A : Set) → ℕ → Set
Vec = Form VecR

nil : {A : Set} → Vec A zero
nil = inj VecR nilT

cons : {A : Set} (n : ℕ) (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR consT

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

add : ℕ → ℕ → ℕ
add = elim ℕR (λ n → ℕ → ℕ)
  (λ n → n)
  (λ m ih n → suc (ih n))
  tt

mult : ℕ → ℕ → ℕ
mult = elim ℕR (λ n → ℕ → ℕ)
  (λ n → zero)
  (λ m ih n → add n (ih n))
  tt

append : {A : Set} (m : ℕ) (xs : Vec A m) (n : ℕ) (ys : Vec A n) → Vec A (add m n)
append {A} m xs = elim VecR (λ m xs → (n : ℕ) (ys : Vec A n) → Vec A (add m n))
  (λ n ys → ys)
  (λ m x xs ih n ys → cons (add m n) x (ih n ys))
  (m , tt) xs

concat : {A : Set} (m n : ℕ) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat {A} m n xss = elim VecR (λ n xss → Vec A (mult n m))
  nil
  (λ n xs xss ih → append m xs (mult n m) ih)
  (n , tt) xss

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


Remove power from the guessing game

Remove power from the guessing game

module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable
open import flat-funs

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

  vnot∘vnot : ∀ {n} → vnot {n} ∘ vnot ≗ id
  vnot∘vnot [] = refl
  vnot∘vnot (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot xs)

open BitsExtra

Coins = ℕ

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
    ]-[-cong : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'

  breaks : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  _≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ↺ c Bit) → Set
  ⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

  ≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
  ≗⅁-trans p q b R = trans (p b R) (q b R)

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ↺ c₀ Bit) (⅁₁ : Bit → ↺ c₁ Bit) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ↺ c Bit}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong (same-games 0b) (same-games 1b)

module Guess (prgDist : PrgDist) where
  open PrgDist prgDist

  GuessAdv : Coins → Set
  GuessAdv c = ↺ c Bit

  runGuess⅁ : ∀ {ca} (A : GuessAdv ca) (b : Bit) → ↺ ca Bit
  runGuess⅁ A _ = A

  -- An oracle: an adversary who can break the guessing game.
  Oracle : Coins → Set
  Oracle ca = ∃ (λ (A : GuessAdv ca) → breaks (runGuess⅁ A))

  -- Any adversary cannot do better than a random guess.
  GuessSec : Coins → Set
  GuessSec ca = ∀ (A : GuessAdv ca) → ¬(breaks (runGuess⅁ A))

module AbsSemSec (|M| |C| : ℕ) {t} {T : Set t}
                 (♭Funs : FlatFuns T) where

  open FlatFuns ♭Funs

  M = `Bits |M|
  C = `Bits |C|

  record AbsSemSecAdv (|R| : Coins) : Set where
    constructor mk

    field
      {|S|} : ℕ

    S = `Bits |S|
    R = `Bits |R|

    field
      step₀ : R `→ (M `× M) `× S
      step₁ : C `× S `→ `Bit
      -- step₀ : ⟨ p₀ ⟩ R ↝ (M `× M) `× S
      -- step₁ : ⟨ p₁ ⟩ C `× S ↝ `Bit

  SemSecReduction : ∀ (f : Coins → Coins) → Set
  SemSecReduction f = ∀ {c} → AbsSemSecAdv c → AbsSemSecAdv (f c)

-- Here we use Agda functions for FlatFuns.
module FunSemSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  open PrgDist prgDist
  open AbsSemSec |M| |C| fun♭Funs
  open FlatFunsOps fun♭Ops

  M² = Bit → M

  Enc : ∀ cc → Set
  Enc cc = M → ↺ cc C

  Tr : (cc₀ cc₁ : Coins) → Set
  Tr cc₀ cc₁ = Enc cc₀ → Enc cc₁

  FunSemSecAdv : Coins → Set
  FunSemSecAdv = AbsSemSecAdv

  module FunSemSecAdv {|R|} (A : FunSemSecAdv |R|) where
    open AbsSemSecAdv A public

    step₀F : R → (M² × S)
    step₀F = step₀ >>> proj *** idO

    step₀↺ : ↺ |R| (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  -- Returing 0 means Chal wins, Adv looses
  --          1 means Adv  wins, Chal looses
  runSemSec : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  runSemSec E A b
    = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
    where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

  _⇄_ : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  _⇄_ = runSemSec

  runAdv : ∀ {|R|} → FunSemSecAdv |R| → C → Bits |R| → (M × M) × Bit
  runAdv (mk A-step₀ A-step₁) C = A-step₀ >>> id *** (const C &&& id >>> A-step₁)

  _≗A_ : ∀ {p} (A₁ A₂ : FunSemSecAdv p) → Set
  A₀ ≗A A₁ = ∀ C R → runAdv A₀ C R ≡ runAdv A₁ C R

  change-adv : ∀ {cc ca} {E : Enc cc} {A₁ A₂ : FunSemSecAdv ca} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
  change-adv {ca = ca} {A₁ = _} {_} pf b R with splitAt ca R
  change-adv {E = E} {A₁} {A₂} pf b ._ | pre Σ., post , refl = trans (cong proj₂ (helper₀ A₁)) helper₂
     where open FunSemSecAdv
           helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post) pre
           helper₂ = cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                          (helper₀ A₂)

  SafeSemSecReduction : ∀ (f : Coins → Coins) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
  SafeSemSecReduction f E₀ E₁ =
     ∃ λ (red : SemSecReduction f) →
       ∀ {c} A → (E₀ ⇄ A) ⇓ (E₁ ⇄ red {c} A)

  SemSecTr : ∀ {cc₀ cc₁} (f : Coins → Coins) (tr : Tr cc₀ cc₁) → Set
  SemSecTr {cc₀} f tr = ∀ {E : Enc cc₀} → SafeSemSecReduction f (tr E) E

module PostCompSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  module PostCompRed {t} {T : Set t}
             {♭Funs : FlatFuns T}
             (♭ops : FlatFunsOps ♭Funs) where
    open FlatFunsOps ♭ops
    open AbsSemSec |M| |C| ♭Funs

    post-comp-red : (post-E : C `→ C) → SemSecReduction _
    post-comp-red post-E (mk A₀ A₁) = mk A₀ (post-E *** idO >>> A₁)

  open PrgDist prgDist
  open PostCompRed fun♭Ops
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist |M| |C|
  open AbsSemSec |M| |C| fun♭Funs

  post-comp : ∀ {cc} (post-E : C → C) → Tr cc cc
  post-comp post-E E = E >>> map↺ post-E

  post-comp-pres-sem-sec : ∀ {cc} (post-E : C → C)
                           → SemSecTr id (post-comp {cc} post-E)
  post-comp-pres-sem-sec post-E = post-comp-red post-E , (λ _ → id)

  post-comp-pres-sem-sec' : ∀ (post-E post-E⁻¹ : C → C)
                              (post-E-inv : post-E⁻¹ ∘ post-E ≗ id)
                              {cc} {E : Enc cc}
                            → SafeSemSecReduction id E (post-comp post-E E)
  post-comp-pres-sem-sec' post-E post-E⁻¹ post-E-inv {cc} {E} = red , helper where
    E' = post-comp post-E E
    red : SemSecReduction id
    red = post-comp-red post-E⁻¹
    helper : ∀ {p} A → (E ⇄ A) ⇓ (E' ⇄ red {p} A)
    helper {c} A A-breaks-E = A'-breaks-E'
     where open FunSemSecAdv A renaming (step₀F to A₀F)
           A' = red {c} A
           same-games : (E ⇄ A) ≗⅁ (E' ⇄ A')
           same-games b R
             rewrite post-E-inv (run↺ (E (proj₁ (A₀F (take c R)) b))
                                       (drop c R)) = refl
           A'-breaks-E' : breaks (E' ⇄ A')
           A'-breaks-E' = extensional-reduction same-games A-breaks-E

  post-neg : ∀ {cc} → Tr cc cc
  post-neg = post-comp vnot

  post-neg-pres-sem-sec : ∀ {cc} → SemSecTr id (post-neg {cc})
  post-neg-pres-sem-sec {cc} {E} = post-comp-pres-sem-sec vnot {E}

  post-neg-pres-sem-sec' : ∀ {cc} {E : Enc cc}
                            → SafeSemSecReduction id E (post-neg E)
  post-neg-pres-sem-sec' {cc} {E} = post-comp-pres-sem-sec' vnot vnot vnot∘vnot {cc} {E}

open import diff
import Data.Fin as Fin
_]-_-[_ : ∀ {c} (f : ↺ c Bit) k (g : ↺ c Bit) → Set
_]-_-[_ {c} f k g = diff (Fin.toℕ #⟨ run↺ f ⟩) (Fin.toℕ #⟨ run↺ g ⟩) ≥ 2^(c ∸ k)
  --  diff (#1 f) (#1 g) ≥ 2^(-k) * 2^ c
  --  diff (#1 f) (#1 g) ≥ ε * 2^ c
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c
  --    where ε = 2^ -k
  -- {!dist (#1 f / 2^ c) (#1 g / 2^ c) > ε !}

open import Data.Vec.NP using (count)

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

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
ext-# f≗g = ext-count f≗g (allBits _)

]-[-cong : ∀ {k c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]- k -[ f' → g ]- k -[ g'
]-[-cong f≗g f'≗g' f]-[f' rewrite ext-# f≗g | ext-# f'≗g' = f]-[f'

module Concrete k where
  _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
  _]-[_ f g = f ]- k -[ g
  cong' : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  cong' = ]-[-cong {k}
  prgDist : PrgDist
  prgDist = mk _]-[_ cong'
  module Guess' = Guess prgDist
  module FunSemSec' = FunSemSec prgDist
  module PostCompSec' = PostCompSec prgDist

module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable
open import flat-funs

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

  vnot∘vnot : ∀ {n} → vnot {n} ∘ vnot ≗ id
  vnot∘vnot [] = refl
  vnot∘vnot (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot xs)

open BitsExtra

Coins = ℕ

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
    ]-[-cong : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'

  breaks : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  _≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ↺ c Bit) → Set
  ⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

  ≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
  ≗⅁-trans p q b R = trans (p b R) (q b R)

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ↺ c₀ Bit) (⅁₁ : Bit → ↺ c₁ Bit) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ↺ c Bit}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong (same-games 0b) (same-games 1b)

module Guess (Power : Set) (coins : Power → Coins) (prgDist : PrgDist) where
  open PrgDist prgDist

  GuessAdv : Coins → Set
  GuessAdv c = ↺ c Bit

  runGuess⅁ : ∀ {ca} (A : GuessAdv ca) (b : Bit) → ↺ ca Bit
  runGuess⅁ A _ = A

  -- An oracle: an adversary who can break the guessing game.
  Oracle : Power → Set
  Oracle power = ∃ (λ (A : GuessAdv (coins power)) → breaks (runGuess⅁ A))

  -- Any adversary cannot do better than a random guess.
  GuessSec : Power → Set
  GuessSec power = ∀ (A : GuessAdv (coins power)) → ¬(breaks (runGuess⅁ A))

module AbsSemSec (|M| |C| : ℕ) {t} {T : Set t}
                 (♭Funs : FlatFuns T) where

  open FlatFuns ♭Funs

  M = `Bits |M|
  C = `Bits |C|

  record AbsSemSecAdv (|R| : Coins) : Set where
    constructor mk

    field
      {|S|} : ℕ

    S = `Bits |S|
    R = `Bits |R|

    field
      step₀ : R `→ (M `× M) `× S
      step₁ : C `× S `→ `Bit
      -- step₀ : ⟨ p₀ ⟩ R ↝ (M `× M) `× S
      -- step₁ : ⟨ p₁ ⟩ C `× S ↝ `Bit

  SemSecReduction : ∀ (f : Coins → Coins) → Set
  SemSecReduction f = ∀ {c} → AbsSemSecAdv c → AbsSemSecAdv (f c)

-- Here we use Agda functions for FlatFuns.
module FunSemSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  open PrgDist prgDist
  open AbsSemSec |M| |C| fun♭Funs
  open FlatFunsOps fun♭Ops

  M² = Bit → M

  Enc : ∀ cc → Set
  Enc cc = M → ↺ cc C

  Tr : (cc₀ cc₁ : Coins) → Set
  Tr cc₀ cc₁ = Enc cc₀ → Enc cc₁

  FunSemSecAdv : Coins → Set
  FunSemSecAdv = AbsSemSecAdv

  module FunSemSecAdv {|R|} (A : FunSemSecAdv |R|) where
    open AbsSemSecAdv A public

    step₀F : R → (M² × S)
    step₀F = step₀ >>> proj *** idO

    step₀↺ : ↺ |R| (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  -- Returing 0 means Chal wins, Adv looses
  --          1 means Adv  wins, Chal looses
  runSemSec : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  runSemSec E A b
    = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
    where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

  _⇄_ : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  _⇄_ = runSemSec

  runAdv : ∀ {|R|} → FunSemSecAdv |R| → C → Bits |R| → (M × M) × Bit
  runAdv (mk A-step₀ A-step₁) C = A-step₀ >>> id *** (const C &&& id >>> A-step₁)

  _≗A_ : ∀ {p} (A₁ A₂ : FunSemSecAdv p) → Set
  A₀ ≗A A₁ = ∀ C R → runAdv A₀ C R ≡ runAdv A₁ C R

  change-adv : ∀ {cc ca} {E : Enc cc} {A₁ A₂ : FunSemSecAdv ca} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
  change-adv {ca = ca} {A₁ = _} {_} pf b R with splitAt ca R
  change-adv {E = E} {A₁} {A₂} pf b ._ | pre Σ., post , refl = trans (cong proj₂ (helper₀ A₁)) helper₂
     where open FunSemSecAdv
           helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post) pre
           helper₂ = cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                          (helper₀ A₂)

  SafeSemSecReduction : ∀ (f : Coins → Coins) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
  SafeSemSecReduction f E₀ E₁ =
     ∃ λ (red : SemSecReduction f) →
       ∀ {c} A → (E₀ ⇄ A) ⇓ (E₁ ⇄ red {c} A)

  SemSecTr : ∀ {cc₀ cc₁} (f : Coins → Coins) (tr : Tr cc₀ cc₁) → Set
  SemSecTr {cc₀} f tr = ∀ {E : Enc cc₀} → SafeSemSecReduction f (tr E) E

module PostCompSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  module PostCompRed {t} {T : Set t}
             {♭Funs : FlatFuns T}
             (♭ops : FlatFunsOps ♭Funs) where
    open FlatFunsOps ♭ops
    open AbsSemSec |M| |C| ♭Funs

    post-comp-red : (post-E : C `→ C) → SemSecReduction _
    post-comp-red post-E (mk A₀ A₁) = mk A₀ (post-E *** idO >>> A₁)

  open PrgDist prgDist
  open PostCompRed fun♭Ops
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist |M| |C|
  open AbsSemSec |M| |C| fun♭Funs

  post-comp : ∀ {cc} (post-E : C → C) → Tr cc cc
  post-comp post-E E = E >>> map↺ post-E

  post-comp-pres-sem-sec : ∀ {cc} (post-E : C → C)
                           → SemSecTr id (post-comp {cc} post-E)
  post-comp-pres-sem-sec post-E = post-comp-red post-E , (λ _ → id)

  post-comp-pres-sem-sec' : ∀ (post-E post-E⁻¹ : C → C)
                              (post-E-inv : post-E⁻¹ ∘ post-E ≗ id)
                              {cc} {E : Enc cc}
                            → SafeSemSecReduction id E (post-comp post-E E)
  post-comp-pres-sem-sec' post-E post-E⁻¹ post-E-inv {cc} {E} = red , helper where
    E' = post-comp post-E E
    red : SemSecReduction id
    red = post-comp-red post-E⁻¹
    helper : ∀ {p} A → (E ⇄ A) ⇓ (E' ⇄ red {p} A)
    helper {c} A A-breaks-E = A'-breaks-E'
     where open FunSemSecAdv A renaming (step₀F to A₀F)
           A' = red {c} A
           same-games : (E ⇄ A) ≗⅁ (E' ⇄ A')
           same-games b R
             rewrite post-E-inv (run↺ (E (proj₁ (A₀F (take c R)) b))
                                       (drop c R)) = refl
           A'-breaks-E' : breaks (E' ⇄ A')
           A'-breaks-E' = extensional-reduction same-games A-breaks-E

  post-neg : ∀ {cc} → Tr cc cc
  post-neg = post-comp vnot

  post-neg-pres-sem-sec : ∀ {cc} → SemSecTr id (post-neg {cc})
  post-neg-pres-sem-sec {cc} {E} = post-comp-pres-sem-sec vnot {E}

  post-neg-pres-sem-sec' : ∀ {cc} {E : Enc cc}
                            → SafeSemSecReduction id E (post-neg E)
  post-neg-pres-sem-sec' {cc} {E} = post-comp-pres-sem-sec' vnot vnot vnot∘vnot {cc} {E}

open import diff
import Data.Fin as Fin
_]-_-[_ : ∀ {c} (f : ↺ c Bit) k (g : ↺ c Bit) → Set
_]-_-[_ {c} f k g = diff (Fin.toℕ #⟨ run↺ f ⟩) (Fin.toℕ #⟨ run↺ g ⟩) ≥ 2^(c ∸ k)
  --  diff (#1 f) (#1 g) ≥ 2^(-k) * 2^ c
  --  diff (#1 f) (#1 g) ≥ ε * 2^ c
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c
  --    where ε = 2^ -k
  -- {!dist (#1 f / 2^ c) (#1 g / 2^ c) > ε !}

open import Data.Vec.NP using (count)

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

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
ext-# f≗g = ext-count f≗g (allBits _)

]-[-cong : ∀ {k c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]- k -[ f' → g ]- k -[ g'
]-[-cong f≗g f'≗g' f]-[f' rewrite ext-# f≗g | ext-# f'≗g' = f]-[f'

module Concrete k where
  _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
  _]-[_ f g = f ]- k -[ g
  cong' : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  cong' = ]-[-cong {k}
  prgDist : PrgDist
  prgDist = mk _]-[_ cong'
  module Guess' = Guess Coins id prgDist
  module FunSemSec' = FunSemSec prgDist
  module PostCompSec' = PostCompSec prgDist


Fin: +Fin▹𝟘, +𝟘▹Fin, +Fin▹𝟙, +𝟙▹Fin, +Fin▹𝟚, +𝟚▹Fin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open import Relation.Binary.PropositionalEquality

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  {-

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

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

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

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

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

_==_ : ∀ {n} (x y : Fin n) → Bool
x == y = helper (compare x y) where
  helper : ∀ {n} {i j : Fin n} → Ordering i j → Bool
  helper (equal _) = true
  helper _         = false

swap : ∀ {i} (x y : Fin i) → Fin i → Fin i
swap x y z = if x == z then y else if y == z then x else z

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

open import Relation.Binary.PropositionalEquality

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  {-

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


Updated paper's title.

Updated paper's title.

Ignore-this: 2199f50d6284b89c6e8457cec04013a8

darcs-hash:20110430153854-3bd4e-41252e26df59f2df8a4dd02ba87fc2522d3b58c0.gz


Wire together CBV↦CBPV conversion and caching

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term

import Parametric.Syntax.MType as MType
import Parametric.Syntax.MTerm as MTerm

import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Denotation.MValue as MValue
import Parametric.Denotation.CachingMValue as CachingMValue
import Parametric.Denotation.MEvaluation as MEvaluation

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ValConst : MTerm.ValConstStructure Const)
    (CompConst : MTerm.CompConstStructure Const)
    -- I should really switch to records - can it get sillier than this?
    (⟦_⟧ValBase : MEvaluation.ValStructure Const ⟦_⟧Base ValConst CompConst)
    (⟦_⟧CompBase : MEvaluation.CompStructure Const ⟦_⟧Base ValConst CompConst)
  where

open Type.Structure Base
open Term.Structure Base Const

open MType.Structure Base
open MTerm.Structure Const ValConst CompConst

open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open MValue.Structure Base ⟦_⟧Base
open CachingMValue.Structure Base ⟦_⟧Base
open MEvaluation.Structure Const ⟦_⟧Base ValConst CompConst ⟦_⟧ValBase ⟦_⟧CompBase

open import Base.Denotation.Notation

-- Extension Point: Evaluation of fully applied constants.
ValStructure : Set
ValStructure = ∀ {Σ τ} → ValConst Σ τ → ⟦ Σ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

CompStructure : Set
CompStructure = ∀ {Σ τ} → CompConst Σ τ → ⟦ Σ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache

module Structure
       (⟦_⟧ValBaseTermCache  : ValStructure)
       (⟦_⟧CompBaseTermCache : CompStructure)
    where

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Unit

  -- Defining a caching semantics for Term proves to be hard, requiring to
  -- insert and remove caches where we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache
  ⟦_⟧ValsTermCache : ∀ {Γ Σ} → Vals Γ Σ → ⟦ Γ ⟧ValCtxHidCache → ⟦ Σ ⟧ValCtxHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVarHidCache)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- Copy of ⟦_⟧Vals
  ⟦ ∅ ⟧ValsTermCache ρ = ∅
  ⟦ vt • valtms ⟧ValsTermCache ρ = ⟦ vt ⟧ValTermCache ρ • ⟦ valtms ⟧ValsTermCache ρ

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVarHidCache ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ
  -- No caching, because the arguments are values, so evaluating them does not
  -- produce intermediate results.
  ⟦ vConst c args ⟧ValTermCache ρ = ⟦ c ⟧ValBaseTermCache (⟦ args ⟧ValsTermCache ρ)

  -- The only caching is done by the interpretation of the constant (because the
  -- arguments are values so need no caching).
  ⟦_⟧CompTermCache (cConst c args) ρ = ⟦ c ⟧CompBaseTermCache (⟦ args ⟧ValsTermCache ρ)

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ = λ x → ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

  ⟦_⟧TermCacheCBV : ∀ {τ Γ} → Term Γ τ → ⟦ fromCBVCtx Γ ⟧ValCtxHidCache → ⟦ cbvToCompType τ ⟧CompTypeHidCache
  ⟦ t ⟧TermCacheCBV = ⟦ fromCBV t ⟧CompTermCache


Group.Homomorphism: add id, ∘, Δ, zip, pair

{-# OPTIONS --without-K #-}
module Algebra.Group.Homomorphism where

open import Type using (Type_)
open import Function.NP using (Op₂; _∘_; id)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Constructions
open import Level.NP
open import Data.Product.NP
open import Data.Nat.NP     using (1+_)
open import Data.Integer.NP using (ℤ; -[1+_]; +_; -_; module ℤ°)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

record GroupHomomorphism {a}{A : Type a}{b}{B : Type b}
                         (grpA0+ : Group A)(grpB1* : Group B)
                         (f : A → B) : Type (a ⊔ b) where
  constructor mk

  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  field
    hom : Homomorphic₂ f _+_ _*_

  pres-unit : f 0# ≡ 1#
  pres-unit = unique-1-left part
    where part = f 0# * f 0#  ≡⟨ ! hom ⟩
                 f (0# + 0#)  ≡⟨ ap f (fst +-identity) ⟩
                 f 0#         ∎

  mon-hom : MonoidHomomorphism +-mon *-mon f
  mon-hom = pres-unit , hom

  open MonoidHomomorphism mon-hom public

  pres-inv : ∀ {x} → f (0− x) ≡ (f x)⁻¹
  pres-inv {x} = unique-⁻¹ part
    where part = f (0− x) * f x  ≡⟨ ! hom ⟩
                 f (0− x + x)    ≡⟨ ap f (fst 0−-inverse) ⟩
                 f 0#            ≡⟨ pres-unit ⟩
                 1#              ∎

  0−-⁻¹ = pres-inv

  −-/ : ∀ {x y} → f (x − y) ≡ f x / f y
  −-/ {x} {y} = f (x − y)       ≡⟨ hom ⟩
                f x * f (0− y)  ≡⟨ ap (_*_ (f x)) pres-inv ⟩
                f x / f y       ∎

  hom-iterated⁻ : ∀ {x} n → f (x ⊗⁻ n) ≡ f x ^⁻ n
  hom-iterated⁻ {x} n =
    f (x ⊗⁻ n)      ≡⟨by-definition⟩
    f (0−(x ⊗⁺ n))  ≡⟨ pres-inv ⟩
    f(x ⊗⁺ n)⁻¹     ≡⟨ ap _⁻¹ (hom-iterated⁺ n) ⟩
    (f x ^⁺ n)⁻¹    ≡⟨by-definition⟩
    f x ^⁻ n        ∎

  hom-iterated : ∀ {x} i → f (x ⊗ i) ≡ f x ^ i
  hom-iterated -[1+ n ] = hom-iterated⁻ (1+ n)
  hom-iterated (+ n)    = hom-iterated⁺ n

ℤ+-grp-ops : Group-Ops ℤ
ℤ+-grp-ops = ℤ+-mon-ops , -_

ℤ+-grp-struct : Group-Struct ℤ+-grp-ops
ℤ+-grp-struct = ℤ+-mon-struct
              , (λ{x} → fst ℤ°.-‿inverse x)
              , (λ{x} → snd ℤ°.-‿inverse x)

ℤ+-grp : Group ℤ
ℤ+-grp = _ , ℤ+-grp-struct

module ℤ+ = Additive-Group ℤ+-grp

module _ {ℓ}{G : Type ℓ}(𝔾 : Group G) where
  open Groupᵒᵖ
  open Group 𝔾

  module ⁻¹-Hom where
    -- The proper type for ⁻¹-hom′
    ⁻¹-hom' : GroupHomomorphism 𝔾 (𝔾 ᵒᵖ) _⁻¹
    ⁻¹-hom' = mk ⁻¹-hom′
    open GroupHomomorphism ⁻¹-hom' public

  module ℤ+-^-Hom {b} where
    ^-+-hom : GroupHomomorphism ℤ+-grp 𝔾 (_^_ b)
    ^-+-hom = mk (λ {i} {j} → ^-+ i j)

    open GroupHomomorphism ^-+-hom public

module Stability-Minimal
  {a}{A  : Type a}
  {b}{B  : Type b}
  (φ     : A → B)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  {c}{C  : Type c}
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ*   : ∀ {k} → F φ ≡ F (_*_ k ∘ φ))
  where

  +-stable : ∀ {k} → F φ ≡ F (φ ∘ _+_ k)
  +-stable {k} =
    F φ                ≡⟨ Fφ* ⟩
    F (_*_ (φ k) ∘ φ)  ≡⟨ F= (λ x → ! φ-+-*) ⟩
    F (φ ∘ _+_ k)      ∎

module Stability
  {a}{A  : Type a}
  {b}{B  : Type b}
  (G+ : Group A)
  (G* : Group B)
  (φ : A → B)
  (φ-hom : GroupHomomorphism G+ G* φ)
  where
  open Additive-Group G+
  open Multiplicative-Group G*
  open GroupHomomorphism φ-hom

  open Stability-Minimal φ _+_ _*_ hom public

open GroupHomomorphism

module Identity
  {a}{A : Type a}
  (𝔸 : Group A)
  where

  id-hom : GroupHomomorphism 𝔸 𝔸 id
  id-hom = mk refl

module Compose
  {a}{A : Type a}
  {b}{B : Type b}
  {c}{C : Type c}
  (𝔸 : Group A)
  (𝔹 : Group B)
  (ℂ : Group C)
  (ψ : A → B)
  (ψ-hom : GroupHomomorphism 𝔸 𝔹 ψ)
  (φ : B → C)
  (φ-hom : GroupHomomorphism 𝔹 ℂ φ)
  where

  ∘-hom : GroupHomomorphism 𝔸 ℂ (φ ∘ ψ)
  ∘-hom = mk (ap φ (hom ψ-hom) ∙ hom φ-hom)

module Delta
  {a}{A : Type a}
  (𝔸 : Group A)
  where
  open Algebra.Group.Constructions.Product

  Δ-hom : GroupHomomorphism 𝔸 (×-grp 𝔸 𝔸) (λ x → x , x)
  Δ-hom = mk refl

module Zip
  {a₀}{A₀ : Type a₀}
  {a₁}{A₁ : Type a₁}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  (𝔸₀ : Group A₀)
  (𝔸₁ : Group A₁)
  (𝔹₀ : Group B₀)
  (𝔹₁ : Group B₁)
  (φ₀ : A₀ → B₀)
  (φ₀-hom : GroupHomomorphism 𝔸₀ 𝔹₀ φ₀)
  (φ₁ : A₁ → B₁)
  (φ₁-hom : GroupHomomorphism 𝔸₁ 𝔹₁ φ₁)
  where
  open Algebra.Group.Constructions.Product

  zip-hom : GroupHomomorphism (×-grp 𝔸₀ 𝔸₁) (×-grp 𝔹₀ 𝔹₁) (map φ₀ φ₁)
  zip-hom = mk (ap₂ _,_ (hom φ₀-hom) (hom φ₁-hom))

module Pair
  {a}{A   : Type a}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  (𝔸  : Group A)
  (𝔹₀ : Group B₀)
  (𝔹₁ : Group B₁)
  (φ₀ : A → B₀)
  (φ₀-hom : GroupHomomorphism 𝔸 𝔹₀ φ₀)
  (φ₁ : A → B₁)
  (φ₁-hom : GroupHomomorphism 𝔸 𝔹₁ φ₁)
  where

  -- pair = zip ∘ Δ
  pair-hom : GroupHomomorphism 𝔸 (Product.×-grp 𝔹₀ 𝔹₁) < φ₀ , φ₁ >
  pair-hom = Compose.∘-hom _ _ _
               _ (Delta.Δ-hom 𝔸)
               _ (Zip.zip-hom _ _ _ _ _ φ₀-hom _ φ₁-hom)
  -- OR:
  pair-hom = mk (ap₂ _,_ (hom φ₀-hom) (hom φ₁-hom))
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Algebra.Group.Homomorphism where

open import Type using (Type_)
open import Function.NP using (Op₂; _∘_)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Constructions
open import Level.NP
open import Data.Product.NP
open import Data.Nat.NP     using (1+_)
open import Data.Integer.NP using (ℤ; -[1+_]; +_; -_; module ℤ°)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

record GroupHomomorphism {a}{A : Type a}{b}{B : Type b}
                         (grpA0+ : Group A)(grpB1* : Group B)
                         (f : A → B) : Type (a ⊔ b) where
  constructor mk

  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  field
    hom : Homomorphic₂ f _+_ _*_

  pres-unit : f 0# ≡ 1#
  pres-unit = unique-1-left part
    where part = f 0# * f 0#  ≡⟨ ! hom ⟩
                 f (0# + 0#)  ≡⟨ ap f (fst +-identity) ⟩
                 f 0#         ∎

  mon-hom : MonoidHomomorphism +-mon *-mon f
  mon-hom = pres-unit , hom

  open MonoidHomomorphism mon-hom public

  pres-inv : ∀ {x} → f (0− x) ≡ (f x)⁻¹
  pres-inv {x} = unique-⁻¹ part
    where part = f (0− x) * f x  ≡⟨ ! hom ⟩
                 f (0− x + x)    ≡⟨ ap f (fst 0−-inverse) ⟩
                 f 0#            ≡⟨ pres-unit ⟩
                 1#              ∎

  0−-⁻¹ = pres-inv

  −-/ : ∀ {x y} → f (x − y) ≡ f x / f y
  −-/ {x} {y} = f (x − y)       ≡⟨ hom ⟩
                f x * f (0− y)  ≡⟨ ap (_*_ (f x)) pres-inv ⟩
                f x / f y       ∎

  hom-iterated⁻ : ∀ {x} n → f (x ⊗⁻ n) ≡ f x ^⁻ n
  hom-iterated⁻ {x} n =
    f (x ⊗⁻ n)      ≡⟨by-definition⟩
    f (0−(x ⊗⁺ n))  ≡⟨ pres-inv ⟩
    f(x ⊗⁺ n)⁻¹     ≡⟨ ap _⁻¹ (hom-iterated⁺ n) ⟩
    (f x ^⁺ n)⁻¹    ≡⟨by-definition⟩
    f x ^⁻ n        ∎

  hom-iterated : ∀ {x} i → f (x ⊗ i) ≡ f x ^ i
  hom-iterated -[1+ n ] = hom-iterated⁻ (1+ n)
  hom-iterated (+ n)    = hom-iterated⁺ n

ℤ+-grp-ops : Group-Ops ℤ
ℤ+-grp-ops = ℤ+-mon-ops , -_

ℤ+-grp-struct : Group-Struct ℤ+-grp-ops
ℤ+-grp-struct = ℤ+-mon-struct
              , (λ{x} → fst ℤ°.-‿inverse x)
              , (λ{x} → snd ℤ°.-‿inverse x)

ℤ+-grp : Group ℤ
ℤ+-grp = _ , ℤ+-grp-struct

module ℤ+ = Additive-Group ℤ+-grp

module _ {ℓ}{G : Type ℓ}(𝔾 : Group G) where
  open Groupᵒᵖ
  open Group 𝔾

  module ⁻¹-Hom where
    -- The proper type for ⁻¹-hom′
    ⁻¹-hom' : GroupHomomorphism 𝔾 (𝔾 ᵒᵖ) _⁻¹
    ⁻¹-hom' = mk ⁻¹-hom′
    open GroupHomomorphism ⁻¹-hom' public

  module ℤ+-^-Hom {b} where
    ^-+-hom : GroupHomomorphism ℤ+-grp 𝔾 (_^_ b)
    ^-+-hom = mk (λ {i} {j} → ^-+ i j)

    open GroupHomomorphism ^-+-hom public

module Stability-Minimal
  {a}{A  : Type a}
  {b}{B  : Type b}
  (φ     : A → B)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  {c}{C  : Type c}
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ*   : ∀ {k} → F φ ≡ F (_*_ k ∘ φ))
  where

  +-stable : ∀ {k} → F φ ≡ F (φ ∘ _+_ k)
  +-stable {k} =
    F φ                ≡⟨ Fφ* ⟩
    F (_*_ (φ k) ∘ φ)  ≡⟨ F= (λ x → ! φ-+-*) ⟩
    F (φ ∘ _+_ k)      ∎

module Stability
  {a}{A  : Type a}
  {b}{B  : Type b}
  (G+ : Group A)
  (G* : Group B)
  (φ : A → B)
  (φ-hom : GroupHomomorphism G+ G* φ)
  where
  open Additive-Group G+
  open Multiplicative-Group G*
  open GroupHomomorphism φ-hom

  open Stability-Minimal φ _+_ _*_ hom public
-- -}
-- -}
-- -}
-- -}


Updated mirror draft.

Updated mirror draft.

Ignore-this: a5731e95fafcd4ae0b5c3a0055e1aafb

darcs-hash:20111129114129-3bd4e-320936ab5c1803f73f10c676e42599f5b831afd8.gz

-- Tested with the development version of the standard library on
-- 29 November 2011.

module PropertiesListSL where

open import Algebra
open import Data.List as List hiding ( reverse )
open import Data.List.Properties hiding ( reverse-++-commute )
open import Data.Product hiding (map)

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

module LM {A : Set} = Monoid (List.monoid A)

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

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

++-rightIdentity : {A : Set}(xs : List A) → xs ++ [] ≡ xs
++-rightIdentity = proj₂ LM.identity

reverse-++-commute : {A : Set}(xs ys : List A) →
                     reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-commute [] ys       = sym (++-rightIdentity (reverse ys))
reverse-++-commute (x ∷ xs) [] = cong (λ x' → reverse x' ++ x ∷ [])
                                      (++-rightIdentity xs)
reverse-++-commute (x ∷ xs) (y ∷ ys) =
  begin
    reverse (xs ++ y ∷ ys) ++ x ∷ []
      ≡⟨ cong (λ x' → x' ++ x ∷ []) (reverse-++-commute xs (y ∷ ys)) ⟩
    (reverse (y ∷ ys) ++ reverse xs) ++ x ∷ []
      ≡⟨ LM.assoc (reverse (y ∷ ys)) (reverse xs) (x ∷ []) ⟩
    reverse (y ∷ ys) ++ reverse (x ∷ xs)
  ∎

data Tree (A : Set) : Set where
  treeT : A → List (Tree A) → Tree A

mirror : {A : Set} → Tree A → Tree A
mirror (treeT a ts) = treeT a (reverse (map mirror ts))

mutual
  mirror² : {A : Set} → (t : Tree A) → mirror (mirror t) ≡ t
  mirror² (treeT a [])       = refl
  mirror² (treeT a (t ∷ ts)) =
    begin
      treeT a (reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ [])))
        ≡⟨ subst (λ x → treeT a (reverse (map mirror (reverse (map mirror ts) ++
                                                      mirror t ∷ []))) ≡
                        treeT a x)
           (helper (t ∷ ts))
           refl
        ⟩
      treeT a (t ∷ ts)
    ∎

  helper : {A : Set} → (ts : List (Tree A)) →
           reverse (map mirror (reverse (map mirror ts))) ≡ ts
  helper []       = refl
  helper (t ∷ ts) =
    begin
      reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ []))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror (reverse (map mirror ts)) (mirror t ∷ []))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror t ∷ [])))) ≡
                        x)
                 (reverse-++-commute (map mirror (reverse (map mirror ts)))
                                     (map mirror (mirror t ∷ [])))
                 refl
        ⟩
      reverse (map mirror (mirror t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
              ≡⟨ refl ⟩
      mirror (mirror t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror (mirror t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² t)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (helper ts)
                 refl
        ⟩
      t ∷ ts
    ∎

-- Tested with the development version of the standard library on
-- 02 May 2011.

module PropertiesListSL where

open import Algebra
open import Data.List as List hiding ( reverse )
open import Data.List.Properties hiding ( reverse-++-commute )

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

module LM {A : Set} = Monoid (List.monoid A)

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

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

++-rightIdentity : {A : Set}(xs : List A) → xs ++ [] ≡ xs
++-rightIdentity []       = refl
++-rightIdentity (x ∷ xs) = cong (_∷_ x) (++-rightIdentity xs)

reverse-++-commute : {A : Set}(xs ys : List A) →
                     reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-commute [] ys       = sym (++-rightIdentity (reverse ys))
reverse-++-commute (x ∷ xs) [] = cong (λ x' → reverse x' ++ x ∷ [])
                                      (++-rightIdentity xs)
reverse-++-commute (x ∷ xs) (y ∷ ys) =
  begin
    reverse (xs ++ y ∷ ys) ++ x ∷ []
      ≡⟨ cong (λ x' → x' ++ x ∷ []) (reverse-++-commute xs (y ∷ ys)) ⟩
    (reverse (y ∷ ys) ++ reverse xs) ++ x ∷ []
      ≡⟨ LM.assoc (reverse (y ∷ ys)) (reverse xs) (x ∷ []) ⟩
    reverse (y ∷ ys) ++ reverse (x ∷ xs)
  ∎

data Tree (A : Set) : Set where
  treeT : A → List (Tree A) → Tree A

mirror : {A : Set} → Tree A → Tree A
mirror (treeT a ts) = treeT a (reverse (map mirror ts))

mutual
  mirror² : {A : Set} → (t : Tree A) → mirror (mirror t) ≡ t
  mirror² (treeT a [])       = refl
  mirror² (treeT a (t ∷ ts)) =
    begin
      treeT a (reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ [])))
        ≡⟨ subst (λ x → treeT a (reverse (map mirror (reverse (map mirror ts) ++
                                                      mirror t ∷ []))) ≡
                        treeT a x)
           (helper (t ∷ ts))
           refl
        ⟩
      treeT a (t ∷ ts)
    ∎

  helper : {A : Set} → (ts : List (Tree A)) →
           reverse (map mirror (reverse (map mirror ts))) ≡ ts
  helper []       = refl
  helper (t ∷ ts) =
    begin
      reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ []))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror (reverse (map mirror ts)) (mirror t ∷ []))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror t ∷ [])))) ≡
                        x)
                 (reverse-++-commute (map mirror (reverse (map mirror ts)))
                                     (map mirror (mirror t ∷ [])))
                 refl
        ⟩
      reverse (map mirror (mirror t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
              ≡⟨ refl ⟩
      mirror (mirror t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror (mirror t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² t)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (helper ts)
                 refl
        ⟩
      t ∷ ts
    ∎


Introduce and use UncurriedTermConstructor.

Old-commit-hash: d36f33b097ddb2444e6409de52048ef9bf94b001

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Context.Context {Type.Type B} → Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

-- Declarations of Term and Terms to enable mutual recursion
data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

-- (Term Γ τ) represents a term of type τ
-- with free variables bound in Γ.
data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- (Terms Γ Σ) represents a list of terms with types from Σ
-- with free variables bound in Γ.
data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

weaken Γ₁≼Γ₂ (const c ts) = const c (weakenAll Γ₁≼Γ₂ ts)
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

weakenAll Γ₁≼Γ₂ ∅ = ∅
weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ ts

-- Specialized weakening
weaken₁ : ∀ {Γ σ τ} →
  Term Γ τ → Term (σ • Γ) τ
weaken₁ t = weaken (drop _ • ≼-refl) t

weaken₂ : ∀ {Γ α β τ} →
  Term Γ τ → Term (α • β • Γ) τ
weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

weaken₃ : ∀ {Γ α β γ τ} →
  Term Γ τ → Term (α • β • γ • Γ) τ
weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

-- Shorthands for nested applications
app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
app₂ f x = app (app f x)

app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
app₃ f x = app₂ (app f x)

app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
app₄ f x = app₃ (app f x)

app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
app₅ f x = app₄ (app f x)

app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
app₆ f x = app₅ (app f x)

UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

-- helper for lift-η-const, don't try to understand at home
lift-η-const-rec : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
lift-η-const-rec {∅} k = k ∅
lift-η-const-rec {τ • Σ} k = λ t → lift-η-const-rec (λ ts → k (t • ts))

lift-η-const : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
lift-η-const constant = lift-η-const-rec (const constant)

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Context.Context {Type.Type B} → Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

-- Declarations of Term and Terms to enable mutual recursion
data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

-- (Term Γ τ) represents a term of type τ
-- with free variables bound in Γ.
data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- (Terms Γ Σ) represents a list of terms with types from Σ
-- with free variables bound in Γ.
data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

weaken Γ₁≼Γ₂ (const c ts) = const c (weakenAll Γ₁≼Γ₂ ts)
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

weakenAll Γ₁≼Γ₂ ∅ = ∅
weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ ts

-- Specialized weakening
weaken₁ : ∀ {Γ σ τ} →
  Term Γ τ → Term (σ • Γ) τ
weaken₁ t = weaken (drop _ • ≼-refl) t

weaken₂ : ∀ {Γ α β τ} →
  Term Γ τ → Term (α • β • Γ) τ
weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

weaken₃ : ∀ {Γ α β γ τ} →
  Term Γ τ → Term (α • β • γ • Γ) τ
weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

-- Shorthands for nested applications
app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
app₂ f x = app (app f x)

app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
app₃ f x = app₂ (app f x)

app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
app₄ f x = app₃ (app f x)

app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
app₅ f x = app₄ (app f x)

app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
app₆ f x = app₅ (app f x)

CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

-- helper for lift-η-const, don't try to understand at home
lift-η-const-rec : ∀ {Σ Γ τ} → (Terms Γ Σ → Term Γ τ) → CurriedTermConstructor Γ Σ τ
lift-η-const-rec {∅} k = k ∅
lift-η-const-rec {τ • Σ} k = λ t → lift-η-const-rec (λ ts → k (t • ts))

lift-η-const : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
lift-η-const constant = lift-η-const-rec (const constant)


Removed an unproven conjecture.

Removed an unproven conjecture.

------------------------------------------------------------------------------
-- Unproven PA properties
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.Properties.UnprovedATP where

open import PA.Axiomatic.Mendelson.Base
open import PA.Axiomatic.Mendelson.PropertiesATP

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

+-asocc : ∀ m n o → m + n + o ≈ m + (n + o)
+-asocc m n o = S₉ A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≈ i + (n + o)
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 +-leftCong #-}

  -- 25 November 2013: Vampire 0.6 proves the theorem using a time out
  -- of (300 sec).
  postulate is : ∀ i → A i → A (succ i)
  -- {-# ATP prove is +-leftCong #-}

------------------------------------------------------------------------------
-- Unproven PA properties
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.Properties.UnprovedATP where

open import PA.Axiomatic.Mendelson.Base
open import PA.Axiomatic.Mendelson.PropertiesATP

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

+-asocc : ∀ m n o → m + n + o ≈ m + (n + o)
+-asocc m n o = S₉ A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≈ i + (n + o)
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 +-leftCong #-}

  -- 25 November 2013: Vampire 0.6 proves the theorem using a time out
  -- of (300 sec).
  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is +-leftCong #-}


Solver.Linear.Parser: comment out the example (long to check)

open import Data.Vec as Vec using ([]; _∷_)
open import Text.Parser
open import Data.One
open import Data.Char
open import Data.Nat
open import Data.List
open import Data.Product hiding (map)
open import Data.String as String renaming (toList to S▹L; fromList to L▹S)
open import Solver.Linear.Syntax
open import Data.Maybe.NP hiding (Eq)
open import Relation.Binary.PropositionalEquality

module Solver.Linear.Parser where

spaces : Parser 𝟙
spaces = manyOneOfˢ " \t\n\r" *> pure _

pIdent : Parser String
pIdent = someNoneOfˢ "(,)↦_ \t\n\r" <* spaces

tokᶜ : Char → Parser 𝟙
tokᶜ c = char c <* spaces

tokˢ : String → Parser 𝟙
tokˢ s = string s <* spaces

--pPair : ∀ {A B} → Parser A → Parser B → Parser (A × B)
--pPair pA pB = tokᶜ '(' *> ⟪ _,_ · pA <* tokᶜ ',' · pB ⟫ <* tokᶜ ')'

module _ {A} (pA : Parser A) where

    pSimpleSyn pSyn : ℕ → Parser (Syn A)

    pSimpleSyn n =  pure tt <* oneOfˢ "_𝟙"
                ⟨|⟩ tokᶜ '(' *> pSyn n <* tokᶜ ')'
                ⟨|⟩ ⟪ var · pA ⟫

    pSyn zero    = empty
    pSyn (suc n) = ⟪ tuple _ · pSimpleSyn n · many n (tokᶜ ',' *> pSyn n) ⟫

    pEq : ℕ → Parser (Eq A)
    pEq n = ⟪ _↦_ · pSyn n <* tokᶜ '↦' · pSyn n ⟫

pSynˢ : ℕ → Parser (Syn String)
pSynˢ = pSyn pIdent

pEqˢ : ℕ → Parser (Eq String)
pEqˢ = pEq pIdent

parseSynˢ? : String →? Syn String
parseSynˢ? s = runParser (pSynˢ n <* eof) ℓ
  where ℓ = S▹L s
        n = length ℓ

parseSynˢ : T[ parseSynˢ? ]
parseSynˢ = F[ parseSynˢ? ]

parseEqˢ? : String →? Eq String
parseEqˢ? s = runParser (spaces *> pEqˢ (2 * n) <* eof) ℓ
  where ℓ = S▹L s
        n = length ℓ

parseEqˢ : T[ parseEqˢ? ]
parseEqˢ = F[ parseEqˢ? ]

ex-A⇒B : Eq String
ex-A⇒B = parseEqˢ "A↦B"

ex-𝟙⇒𝟙 : Eq String
ex-𝟙⇒𝟙 = parseEqˢ "𝟙↦𝟙"

ex₁ : Eq String
ex₁ = parseEqˢ " ( A , B,(𝟙,C),(D))↦ B,C , A"

{-
test-ex₁ : ex₁ ≡ ((var"A" , (var"B", (tt , var"C") , var"D"))
                ↦ (var"B" , var"C" , var"A"))
test-ex₁ = refl
-}

-- -}

open import Data.Vec as Vec using ([]; _∷_)
open import Text.Parser
open import Data.One
open import Data.Char
open import Data.Nat
open import Data.List
open import Data.Product hiding (map)
open import Data.String as String renaming (toList to S▹L; fromList to L▹S)
open import Solver.Linear.Syntax
open import Data.Maybe.NP hiding (Eq)
open import Relation.Binary.PropositionalEquality

module Solver.Linear.Parser where

spaces : Parser 𝟙
spaces = manyOneOfˢ " \t\n\r" *> pure _

pIdent : Parser String
pIdent = someNoneOfˢ "(,)↦_ \t\n\r" <* spaces

tokᶜ : Char → Parser 𝟙
tokᶜ c = char c <* spaces

tokˢ : String → Parser 𝟙
tokˢ s = string s <* spaces

--pPair : ∀ {A B} → Parser A → Parser B → Parser (A × B)
--pPair pA pB = tokᶜ '(' *> ⟪ _,_ · pA <* tokᶜ ',' · pB ⟫ <* tokᶜ ')'

module _ {A} (pA : Parser A) where

    pSimpleSyn pSyn : ℕ → Parser (Syn A)

    pSimpleSyn n =  pure tt <* oneOfˢ "_𝟙"
                ⟨|⟩ tokᶜ '(' *> pSyn n <* tokᶜ ')'
                ⟨|⟩ ⟪ var · pA ⟫

    pSyn zero    = empty
    pSyn (suc n) = ⟪ tuple _ · pSimpleSyn n · many n (tokᶜ ',' *> pSyn n) ⟫

    pEq : ℕ → Parser (Eq A)
    pEq n = ⟪ _↦_ · pSyn n <* tokᶜ '↦' · pSyn n ⟫

pSynˢ : ℕ → Parser (Syn String)
pSynˢ = pSyn pIdent

pEqˢ : ℕ → Parser (Eq String)
pEqˢ = pEq pIdent

parseSynˢ? : String →? Syn String
parseSynˢ? s = runParser (pSynˢ n <* eof) ℓ
  where ℓ = S▹L s
        n = length ℓ

parseSynˢ : T[ parseSynˢ? ]
parseSynˢ = F[ parseSynˢ? ]

parseEqˢ? : String →? Eq String
parseEqˢ? s = runParser (spaces *> pEqˢ (2 * n) <* eof) ℓ
  where ℓ = S▹L s
        n = length ℓ

parseEqˢ : T[ parseEqˢ? ]
parseEqˢ = F[ parseEqˢ? ]

ex-A⇒B : Eq String
ex-A⇒B = parseEqˢ "A↦B"

ex-𝟙⇒𝟙 : Eq String
ex-𝟙⇒𝟙 = parseEqˢ "𝟙↦𝟙"

ex₁ : Eq String
ex₁ = parseEqˢ " ( A , B,(𝟙,C),(D))↦ B,C , A"

test-ex₁ : ex₁ ≡ ((var"A" , (var"B", (tt , var"C") , var"D"))
                ↦ (var"B" , var"C" , var"A"))
test-ex₁ = refl

-- -}