Desc stratified model: descD implicit.

Desc stratified model: descD implicit.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set l) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set l} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set l}(R : I -> IDesc I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set l}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const X
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : {l : Level} -> Set l -> DescDConst -> IDesc Unit
descDChoice I lvar = const (lift I)
descDChoice _ lconst = const (Set _)
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))

descD : {l : Level}(I : Set l) -> IDesc Unit
descD I = sigma DescDConst (descDChoice I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (\_ -> descD I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst  {l = suc x}
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst {l = suc x}
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst {l = suc x}
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst {l = suc x}
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s

--********************************************
-- From the embedding to the host
--********************************************

-- desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
-- descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
-- IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l

-- cases : (l : Level)
--         (I : Set l)
--         (xs : desc (suc l) (lift I) (descD l I) (IMu (suc l) Unit (\ _ -> descD l I)))
--         (hs : desc l I (box l I (descD l I) (IMu l Unit (λ _ -> descD l I)) xs) (λ _ -> IDesc (suc l) I)) ->
--         IDesc (suc l) I
-- cases x I ( lvar , i ) hs =  var i
-- cases x I ( lconst , X ) hs =  const X
-- cases x I ( lprod , (D , D') ) ( d , d' ) =  prod d d'
-- cases x I ( lpi , ( S , T ) ) hs =  pi S hs
-- cases x I ( lsigma , ( S , T ) ) hs = sigma S hs

-- phi : {I : Set} -> IDescl I -> IDesc I
-- phi {I} d = induction (\_ -> descD I) (\_ -> IDesc I) (\_ -> cases) Void d

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set l) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set l} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set l}(R : I -> IDesc I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set l}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const X
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : {l : Level} -> Set l -> DescDConst -> IDesc Unit
descDChoice I lvar = const (lift I)
descDChoice _ lconst = const (Set _)
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc Unit
descD x I = sigma DescDConst (descDChoice I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst  {l = suc x}
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst {l = suc x}
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst {l = suc x}
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst {l = suc x}
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s

--********************************************
-- From the embedding to the host
--********************************************

-- desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
-- descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
-- IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l

-- cases : (l : Level)
--         (I : Set l)
--         (xs : desc (suc l) (lift I) (descD l I) (IMu (suc l) Unit (\ _ -> descD l I)))
--         (hs : desc l I (box l I (descD l I) (IMu l Unit (λ _ -> descD l I)) xs) (λ _ -> IDesc (suc l) I)) ->
--         IDesc (suc l) I
-- cases x I ( lvar , i ) hs =  var i
-- cases x I ( lconst , X ) hs =  const X
-- cases x I ( lprod , (D , D') ) ( d , d' ) =  prod d d'
-- cases x I ( lpi , ( S , T ) ) hs =  pi S hs
-- cases x I ( lsigma , ( S , T ) ) hs = sigma S hs

-- phi : {I : Set} -> IDescl I -> IDesc I
-- phi {I} d = induction (\_ -> descD I) (\_ -> IDesc I) (\_ -> cases) Void d


Simplied some proofs.

Simplied some proofs.

Ignore-this: 1aa23e74e5fb6656bef1c63cc2c1e84b

darcs-hash:20110218170953-3bd4e-ab204ca4c90c40c3fdcd1bd8c40e01b6bb106b5d.gz

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

module Draft.McCarthy91.Properties.AuxiliaryATP where

open import LTC.Base

open import Draft.McCarthy91.ArithmeticATP
open import Draft.McCarthy91.McCarthy91

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

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

--- Auxiliary properties

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

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

---- Case n ≤ 100

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Draft.McCarthy91.Properties.AuxiliaryATP where

open import LTC.Base

open import Draft.McCarthy91.ArithmeticATP
open import Draft.McCarthy91.McCarthy91

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

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

--- Auxiliary properties

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

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

---- Case n ≤ 100

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

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

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

postulate
  mc91-res-99' : ∀ {n} → n ≡ ninety-nine → mc91 n ≡ ninety-one
  mc91-res-98' : ∀ {n} → n ≡ ninety-eight → mc91 n ≡ ninety-one
  mc91-res-97' : ∀ {n} → n ≡ ninety-seven → mc91 n ≡ ninety-one
  mc91-res-96' : ∀ {n} → n ≡ ninety-six → mc91 n ≡ ninety-one
  mc91-res-95' : ∀ {n} → n ≡ ninety-five → mc91 n ≡ ninety-one
  mc91-res-94' : ∀ {n} → n ≡ ninety-four → mc91 n ≡ ninety-one
  mc91-res-93' : ∀ {n} → n ≡ ninety-three → mc91 n ≡ ninety-one
  mc91-res-92' : ∀ {n} → n ≡ ninety-two → mc91 n ≡ ninety-one
  mc91-res-91' : ∀ {n} → n ≡ ninety-one → mc91 n ≡ ninety-one
  mc91-res-90' : ∀ {n} → n ≡ ninety → mc91 n ≡ ninety-one
{-# ATP prove mc91-res-99' mc91-res-99 #-}
{-# ATP prove mc91-res-98' mc91-res-98 #-}
{-# ATP prove mc91-res-97' mc91-res-97 #-}
{-# ATP prove mc91-res-96' mc91-res-96 #-}
{-# ATP prove mc91-res-95' mc91-res-95 #-}
{-# ATP prove mc91-res-94' mc91-res-94 #-}
{-# ATP prove mc91-res-93' mc91-res-93 #-}
{-# ATP prove mc91-res-92' mc91-res-92 #-}
{-# ATP prove mc91-res-91' mc91-res-91 #-}
{-# ATP prove mc91-res-90' mc91-res-90 #-}


Two: +twist

Two: +twist

{-# OPTIONS --without-K #-}
module Data.Two where

open import Data.Bool public hiding (if_then_else_) renaming (Bool to 𝟚; false to 0₂; true to 1₂; T to ✓)
open import Data.Bool.Properties
  public
  using (isCommutativeSemiring-∨-∧
        ;commutativeSemiring-∨-∧
        ;module RingSolver
        ;isCommutativeSemiring-∧-∨
        ;commutativeSemiring-∧-∨
        ;isBooleanAlgebra
        ;booleanAlgebra
        ;commutativeRing-xor-∧
        ;module XorRingSolver
        ;not-involutive
        ;not-¬
        ;¬-not
        ;⇔→≡
        ;proof-irrelevance)
  renaming
        (T-≡ to ✓-≡
        ;T-∧ to ✓-∧
        ;T-∨ to ✓-∨)

open import Type using (★_)

open import Algebra                    using (module CommutativeRing; module CommutativeSemiring)
open import Algebra.FunctionProperties using (Op₁; Op₂)

open import Data.Nat     using (ℕ; _≤_; z≤n; s≤s; _⊓_; _⊔_; _∸_)
open import Data.Zero    using (𝟘-elim)
open import Data.One     using (𝟙)
open import Data.Product using (proj₁; proj₂; uncurry; _×_; _,_)
open import Data.Sum     using (_⊎_; inj₁; inj₂)

open import Function.Equivalence using (module Equivalence)
open import Function.Equality    using (_⟨$⟩_)
open import Function.NP          using (id; _∘_; _⟨_⟩°_; flip)

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; refl; idp; _∙_; !_; coe; coe!; J; J-orig)
open import Relation.Nullary                         using (¬_; Dec; yes; no)

open import HoTT
open Equivalences

open Equivalence using (to; from)

module Xor° = CommutativeRing     commutativeRing-xor-∧
module 𝟚°   = CommutativeSemiring commutativeSemiring-∧-∨

_² : ∀ {a} → ★ a → ★ a
A ² = 𝟚 → A

module _ {p} {P : 𝟚 → ★ p} where

    [0:_1:_] : P 0₂ → P 1₂ → (b : 𝟚) → P b
    [0: e₀ 1: e₁ ] 0₂ = e₀
    [0: e₀ 1: e₁ ] 1₂ = e₁

    tabulate₂ : ((b : 𝟚) → P b) → P 0₂ × P 1₂
    tabulate₂ f = f 0₂ , f 1₂

    η-[0:1:] : ∀ (f : (b : 𝟚) → P b) b → [0: f 0₂ 1: f 1₂ ] b ≡ f b
    η-[0:1:] f 0₂ = refl
    η-[0:1:] f 1₂ = refl

    proj : P 0₂ × P 1₂ → (b : 𝟚) → P b
    proj = uncurry [0:_1:_]

    proj-tabulate₂ : ∀ (f : (b : 𝟚) → P b) b → proj (tabulate₂ f) b ≡ f b
    proj-tabulate₂ = η-[0:1:]

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

    [0:_1:_]′ : A → A → A ²
    [0:_1:_]′ = [0:_1:_]

    case_0:_1:_ : 𝟚 → A → A → A
    case b 0: e₀ 1: e₁ = [0: e₀
                          1: e₁ ] b

    proj′ : A × A → A ²
    proj′ = proj

    proj[_] : 𝟚 → A × A → A
    proj[_] = [0: proj₁ 1: proj₂ ]

    mux : 𝟚 × (A × A) → A
    mux (s , eᵢ) = proj eᵢ s

nor : (b₀ b₁ : 𝟚) → 𝟚
nor b₀ b₁ = not (b₀ ∨ b₁)

nand : (b₀ b₁ : 𝟚) → 𝟚
nand b₀ b₁ = not (b₀ ∧ b₁)

-- For properties about _==_ see Data.Two.Equality
_==_ : (b₀ b₁ : 𝟚) → 𝟚
b₀ == b₁ = (not b₀) xor b₁

twist-equiv : 𝟚 ≃ 𝟚
twist-equiv = self-inv-equiv not not-involutive

module _ {{_ : UA}} where
    twist : 𝟚 ≡ 𝟚
    twist = ua twist-equiv

≡→✓ : ∀ {b} → b ≡ 1₂ → ✓ b
≡→✓ refl = _

≡→✓not : ∀ {b} → b ≡ 0₂ → ✓ (not b)
≡→✓not refl = _

✓→≡ : ∀ {b} → ✓ b → b ≡ 1₂
✓→≡ {1₂} _ = refl
✓→≡ {0₂} ()

✓not→≡ : ∀ {b} → ✓ (not b) → b ≡ 0₂
✓not→≡ {0₂} _ = refl
✓not→≡ {1₂} ()

✓∧ : ∀ {b₁ b₂} → ✓ b₁ → ✓ b₂ → ✓ (b₁ ∧ b₂)
✓∧ p q = _⟨$⟩_ (from ✓-∧) (p , q)

✓∧₁ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁
✓∧₁ = proj₁ ∘ _⟨$⟩_ (to ✓-∧)

✓∧₂ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₂
✓∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (✓-∧ {b₁}))

✓∨-⊎ : ∀ {b₁ b₂} → ✓ (b₁ ∨ b₂) → ✓ b₁ ⊎ ✓ b₂
✓∨-⊎ {b₁} = _⟨$⟩_ (to (✓-∨ {b₁}))

✓∨₁ : ∀ {b₁ b₂} → ✓ b₁ → ✓ (b₁ ∨ b₂)
✓∨₁ = _⟨$⟩_ (from ✓-∨) ∘ inj₁

✓∨₂ : ∀ {b₁ b₂} → ✓ b₂ → ✓ (b₁ ∨ b₂)
✓∨₂ {b₁} = _⟨$⟩_ (from (✓-∨ {b₁})) ∘ inj₂

✓-not-¬ : ∀ {b} → ✓ (not b) → ¬ (✓ b)
✓-not-¬ {0₂} _ = λ()
✓-not-¬ {1₂} ()

✓-¬-not : ∀ {b} → ¬ (✓ b) → ✓ (not b)
✓-¬-not {0₂} _ = _
✓-¬-not {1₂} f = f _

∧⇒∨ : ∀ x y → ✓ (x ∧ y) → ✓ (x ∨ y)
∧⇒∨ 0₂ _ = λ ()
∧⇒∨ 1₂ _ = _

✓dec : ∀ b → Dec (✓ b)
✓dec = [0: no (λ())
        1: yes _ ]

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan 0₂ _ = refl
de-morgan 1₂ _ = refl

≢0→≡1 : ∀ {x} → x ≢ 0₂ → x ≡ 1₂
≢0→≡1 {1₂} p = refl
≢0→≡1 {0₂} p = 𝟘-elim (p refl)

≢1→≡0 : ∀ {x} → x ≢ 1₂ → x ≡ 0₂
≢1→≡0 {0₂} p = refl
≢1→≡0 {1₂} p = 𝟘-elim (p refl)

-- 0₂ is 0 and 1₂ is 1
𝟚▹ℕ : 𝟚 → ℕ
𝟚▹ℕ = [0: 0
       1: 1 ]

𝟚▹ℕ≤1 : ∀ b → 𝟚▹ℕ b ≤ 1
𝟚▹ℕ≤1 = [0: z≤n
         1: s≤s z≤n ]

𝟚▹ℕ-⊓ : ∀ a b → 𝟚▹ℕ a ⊓ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ b)
𝟚▹ℕ-⊓ 1₂ 0₂ = refl
𝟚▹ℕ-⊓ 1₂ 1₂ = refl
𝟚▹ℕ-⊓ 0₂ _  = refl

𝟚▹ℕ-⊔ : ∀ a b → 𝟚▹ℕ a ⊔ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∨ b)
𝟚▹ℕ-⊔ 1₂ 0₂ = refl
𝟚▹ℕ-⊔ 1₂ 1₂ = refl
𝟚▹ℕ-⊔ 0₂ _  = refl

𝟚▹ℕ-∸ : ∀ a b → 𝟚▹ℕ a ∸ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ not b)
𝟚▹ℕ-∸ 0₂ 0₂ = refl
𝟚▹ℕ-∸ 0₂ 1₂ = refl
𝟚▹ℕ-∸ 1₂ 0₂ = refl
𝟚▹ℕ-∸ 1₂ 1₂ = refl

xor-not-not : ∀ x y → (not x) xor (not y) ≡ x xor y
xor-not-not 0₂ y = not-involutive y
xor-not-not 1₂ _ = refl

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {0₂} {0₂} _ = refl
not-inj {1₂} {1₂} _ = refl
not-inj {0₂} {1₂} ()
not-inj {1₂} {0₂} ()

xor-inj₁ : ∀ x {y z} → (x xor y) ≡ (x xor z) → y ≡ z
xor-inj₁ 0₂ = id
xor-inj₁ 1₂ = not-inj

xor-inj₂ : ∀ x {y z} → (y xor x) ≡ (z xor x) → y ≡ z
xor-inj₂ x {y} {z} p = xor-inj₁ x (Xor°.+-comm x y ∙ p ∙ Xor°.+-comm z x)

check : ∀ b → {pf : ✓ b} → 𝟙
check = _

module Indexed {a} {A : ★ a} where
    _∧°_ : Op₂ (A → 𝟚)
    x ∧° y = x ⟨ _∧_ ⟩° y

    _∨°_ : Op₂ (A → 𝟚)
    x ∨° y = x ⟨ _∨_ ⟩° y

    _xor°_ : Op₂ (A → 𝟚)
    x xor° y = x ⟨ _xor_ ⟩° y

    _==°_ : Op₂ (A → 𝟚)
    x ==° y = x ⟨ _==_ ⟩° y

    not° : Op₁ (A → 𝟚)
    not° f = not ∘ f
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Data.Two where

open import Data.Bool public hiding (if_then_else_) renaming (Bool to 𝟚; false to 0₂; true to 1₂; T to ✓)
open import Data.Bool.Properties
  public
  using (isCommutativeSemiring-∨-∧
        ;commutativeSemiring-∨-∧
        ;module RingSolver
        ;isCommutativeSemiring-∧-∨
        ;commutativeSemiring-∧-∨
        ;isBooleanAlgebra
        ;booleanAlgebra
        ;commutativeRing-xor-∧
        ;module XorRingSolver
        ;not-involutive
        ;not-¬
        ;¬-not
        ;⇔→≡
        ;proof-irrelevance)
  renaming
        (T-≡ to ✓-≡
        ;T-∧ to ✓-∧
        ;T-∨ to ✓-∨)

open import Type using (★_)

open import Algebra                    using (module CommutativeRing; module CommutativeSemiring)
open import Algebra.FunctionProperties using (Op₁; Op₂)

open import Data.Nat     using (ℕ; _≤_; z≤n; s≤s; _⊓_; _⊔_; _∸_)
open import Data.Zero    using (𝟘-elim)
open import Data.One     using (𝟙)
open import Data.Product using (proj₁; proj₂; uncurry; _×_; _,_)
open import Data.Sum     using (_⊎_; inj₁; inj₂)

open import Function.Equivalence using (module Equivalence)
open import Function.Equality    using (_⟨$⟩_)
open import Function.NP          using (id; _∘_; _⟨_⟩°_)

open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; refl; idp; _∙_; !_)
open import Relation.Nullary                         using (¬_; Dec; yes; no)

open Equivalence using (to; from)

module Xor° = CommutativeRing     commutativeRing-xor-∧
module 𝟚°   = CommutativeSemiring commutativeSemiring-∧-∨

_² : ∀ {a} → ★ a → ★ a
A ² = 𝟚 → A

module _ {p} {P : 𝟚 → ★ p} where

    [0:_1:_] : P 0₂ → P 1₂ → (b : 𝟚) → P b
    [0: e₀ 1: e₁ ] 0₂ = e₀
    [0: e₀ 1: e₁ ] 1₂ = e₁

    tabulate₂ : ((b : 𝟚) → P b) → P 0₂ × P 1₂
    tabulate₂ f = f 0₂ , f 1₂

    η-[0:1:] : ∀ (f : (b : 𝟚) → P b) b → [0: f 0₂ 1: f 1₂ ] b ≡ f b
    η-[0:1:] f 0₂ = refl
    η-[0:1:] f 1₂ = refl

    proj : P 0₂ × P 1₂ → (b : 𝟚) → P b
    proj = uncurry [0:_1:_]

    proj-tabulate₂ : ∀ (f : (b : 𝟚) → P b) b → proj (tabulate₂ f) b ≡ f b
    proj-tabulate₂ = η-[0:1:]

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

    [0:_1:_]′ : A → A → A ²
    [0:_1:_]′ = [0:_1:_]

    case_0:_1:_ : 𝟚 → A → A → A
    case b 0: e₀ 1: e₁ = [0: e₀
                          1: e₁ ] b

    proj′ : A × A → A ²
    proj′ = proj

    proj[_] : 𝟚 → A × A → A
    proj[_] = [0: proj₁ 1: proj₂ ]

    mux : 𝟚 × (A × A) → A
    mux (s , eᵢ) = proj eᵢ s

nor : (b₀ b₁ : 𝟚) → 𝟚
nor b₀ b₁ = not (b₀ ∨ b₁)

nand : (b₀ b₁ : 𝟚) → 𝟚
nand b₀ b₁ = not (b₀ ∧ b₁)

-- For properties about _==_ see Data.Two.Equality
_==_ : (b₀ b₁ : 𝟚) → 𝟚
b₀ == b₁ = (not b₀) xor b₁

≡→✓ : ∀ {b} → b ≡ 1₂ → ✓ b
≡→✓ refl = _

≡→✓not : ∀ {b} → b ≡ 0₂ → ✓ (not b)
≡→✓not refl = _

✓→≡ : ∀ {b} → ✓ b → b ≡ 1₂
✓→≡ {1₂} _ = refl
✓→≡ {0₂} ()

✓not→≡ : ∀ {b} → ✓ (not b) → b ≡ 0₂
✓not→≡ {0₂} _ = refl
✓not→≡ {1₂} ()

✓∧ : ∀ {b₁ b₂} → ✓ b₁ → ✓ b₂ → ✓ (b₁ ∧ b₂)
✓∧ p q = _⟨$⟩_ (from ✓-∧) (p , q)

✓∧₁ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁
✓∧₁ = proj₁ ∘ _⟨$⟩_ (to ✓-∧)

✓∧₂ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₂
✓∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (✓-∧ {b₁}))

✓∨-⊎ : ∀ {b₁ b₂} → ✓ (b₁ ∨ b₂) → ✓ b₁ ⊎ ✓ b₂
✓∨-⊎ {b₁} = _⟨$⟩_ (to (✓-∨ {b₁}))

✓∨₁ : ∀ {b₁ b₂} → ✓ b₁ → ✓ (b₁ ∨ b₂)
✓∨₁ = _⟨$⟩_ (from ✓-∨) ∘ inj₁

✓∨₂ : ∀ {b₁ b₂} → ✓ b₂ → ✓ (b₁ ∨ b₂)
✓∨₂ {b₁} = _⟨$⟩_ (from (✓-∨ {b₁})) ∘ inj₂

✓-not-¬ : ∀ {b} → ✓ (not b) → ¬ (✓ b)
✓-not-¬ {0₂} _ = λ()
✓-not-¬ {1₂} ()

✓-¬-not : ∀ {b} → ¬ (✓ b) → ✓ (not b)
✓-¬-not {0₂} _ = _
✓-¬-not {1₂} f = f _

∧⇒∨ : ∀ x y → ✓ (x ∧ y) → ✓ (x ∨ y)
∧⇒∨ 0₂ _ = λ ()
∧⇒∨ 1₂ _ = _

✓dec : ∀ b → Dec (✓ b)
✓dec = [0: no (λ())
        1: yes _ ]

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan 0₂ _ = refl
de-morgan 1₂ _ = refl

≢0→≡1 : ∀ {x} → x ≢ 0₂ → x ≡ 1₂
≢0→≡1 {1₂} p = refl
≢0→≡1 {0₂} p = 𝟘-elim (p refl)

≢1→≡0 : ∀ {x} → x ≢ 1₂ → x ≡ 0₂
≢1→≡0 {0₂} p = refl
≢1→≡0 {1₂} p = 𝟘-elim (p refl)

-- 0₂ is 0 and 1₂ is 1
𝟚▹ℕ : 𝟚 → ℕ
𝟚▹ℕ = [0: 0
       1: 1 ]

𝟚▹ℕ≤1 : ∀ b → 𝟚▹ℕ b ≤ 1
𝟚▹ℕ≤1 = [0: z≤n
         1: s≤s z≤n ]

𝟚▹ℕ-⊓ : ∀ a b → 𝟚▹ℕ a ⊓ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ b)
𝟚▹ℕ-⊓ 1₂ 0₂ = refl
𝟚▹ℕ-⊓ 1₂ 1₂ = refl
𝟚▹ℕ-⊓ 0₂ _  = refl

𝟚▹ℕ-⊔ : ∀ a b → 𝟚▹ℕ a ⊔ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∨ b)
𝟚▹ℕ-⊔ 1₂ 0₂ = refl
𝟚▹ℕ-⊔ 1₂ 1₂ = refl
𝟚▹ℕ-⊔ 0₂ _  = refl

𝟚▹ℕ-∸ : ∀ a b → 𝟚▹ℕ a ∸ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ not b)
𝟚▹ℕ-∸ 0₂ 0₂ = refl
𝟚▹ℕ-∸ 0₂ 1₂ = refl
𝟚▹ℕ-∸ 1₂ 0₂ = refl
𝟚▹ℕ-∸ 1₂ 1₂ = refl

xor-not-not : ∀ x y → (not x) xor (not y) ≡ x xor y
xor-not-not 0₂ y = not-involutive y
xor-not-not 1₂ _ = refl

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {0₂} {0₂} _ = refl
not-inj {1₂} {1₂} _ = refl
not-inj {0₂} {1₂} ()
not-inj {1₂} {0₂} ()

xor-inj₁ : ∀ x {y z} → (x xor y) ≡ (x xor z) → y ≡ z
xor-inj₁ 0₂ = id
xor-inj₁ 1₂ = not-inj

xor-inj₂ : ∀ x {y z} → (y xor x) ≡ (z xor x) → y ≡ z
xor-inj₂ x {y} {z} p = xor-inj₁ x (Xor°.+-comm x y ∙ p ∙ Xor°.+-comm z x)

check : ∀ b → {pf : ✓ b} → 𝟙
check = _

module Indexed {a} {A : ★ a} where
    _∧°_ : Op₂ (A → 𝟚)
    x ∧° y = x ⟨ _∧_ ⟩° y

    _∨°_ : Op₂ (A → 𝟚)
    x ∨° y = x ⟨ _∨_ ⟩° y

    _xor°_ : Op₂ (A → 𝟚)
    x xor° y = x ⟨ _xor_ ⟩° y

    _==°_ : Op₂ (A → 𝟚)
    x ==° y = x ⟨ _==_ ⟩° y

    not° : Op₁ (A → 𝟚)
    not° f = not ∘ f
-- -}
-- -}
-- -}


Move (apply|diff)-base to the top of the module.

This commit separates the POPL14-specific code from the
language-independent code in this module. The following commits will
remove the language-independent code.

Old-commit-hash: 245a7b618b2ac811d28d702089482e9aed8b8425

module Popl14.Change.Term where

-- Terms Calculus Popl14
--
-- Contents
-- - Term constructors
-- - Weakening on terms
-- - `fit`: weaken a term to its ΔContext
-- - diff-term, apply-term and their syntactic sugars

open import Data.Integer

open import Popl14.Syntax.Type public
open import Popl14.Syntax.Term public
open import Popl14.Change.Type public

import Parametric.Change.Term Const ΔBase as ChangeTerm

diff-base : ChangeTerm.DiffStructure
diff-base {base-int} = abs₂ (λ x y → add x (minus y))
diff-base {base-bag} = abs₂ (λ x y → union x (negate y))

apply-base : ChangeTerm.ApplyStructure
apply-base {base-int} = abs₂ (λ Δx x → add x Δx)
apply-base {base-bag} = abs₂ (λ Δx x → union x Δx)

diff-term  : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

-- Sugars for diff-term and apply-term
infixl 6 _⊕_ _⊝_
_⊕_ : ∀ {τ Γ} → Term Γ τ → Term Γ (ΔType τ) → Term Γ τ
_⊝_ : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (ΔType τ)
t ⊕ Δt = app (app apply-term Δt) t
s ⊝ t  = app (app  diff-term  s) t

apply-term {base ι} = apply-base {ι}
apply-term {σ ⇒ τ} =
  let
    Δf = var (that (that this))
    f  = var (that this)
    x  = var this
  in
  -- Δf   f    x
    abs (abs (abs
      (app f x ⊕ app (app Δf x) (x ⊝ x))))

diff-term {base ι} = diff-base {ι}
diff-term {σ ⇒ τ} =
  let
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
  in
  -- g    f    x    Δx
    abs (abs (abs (abs
      (app g (x ⊕ Δx) ⊝ app f x))))

module Popl14.Change.Term where

-- Terms Calculus Popl14
--
-- Contents
-- - Term constructors
-- - Weakening on terms
-- - `fit`: weaken a term to its ΔContext
-- - diff-term, apply-term and their syntactic sugars

open import Data.Integer

open import Popl14.Syntax.Type public
open import Popl14.Syntax.Term public
open import Popl14.Change.Type public

import Parametric.Change.Term Const ΔBase as ChangeTerm

diff-term  : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

-- Sugars for diff-term and apply-term
infixl 6 _⊕_ _⊝_
_⊕_ : ∀ {τ Γ} → Term Γ τ → Term Γ (ΔType τ) → Term Γ τ
_⊝_ : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (ΔType τ)
t ⊕ Δt = app (app apply-term Δt) t
s ⊝ t  = app (app  diff-term  s) t

apply-base : ChangeTerm.ApplyStructure
apply-base {base-int} =
  abs₂ (λ Δx x → add x Δx)
apply-base {base-bag} =
  abs₂ (λ Δx x → union x Δx)

apply-term {base ι} = apply-base {ι}
apply-term {σ ⇒ τ} =
  let
    Δf = var (that (that this))
    f  = var (that this)
    x  = var this
  in
  -- Δf   f    x
    abs (abs (abs
      (app f x ⊕ app (app Δf x) (x ⊝ x))))

diff-base : ChangeTerm.DiffStructure
diff-base {base-int} =
  abs₂ (λ x y → add x (minus y))
diff-base {base-bag} =
  abs₂ (λ x y → union x (negate y))

diff-term {base ι} = diff-base {ι}
diff-term {σ ⇒ τ} =
  let
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
  in
  -- g    f    x    Δx
    abs (abs (abs (abs
      (app g (x ⊕ Δx) ⊝ app f x))))


whitespace and alpha renaming #3

whitespace and alpha renaming #3

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
    -- if the left is indetermiante but the right is a value
  progress (TAAp wt1 wt2) | I x | V x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | V y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | V y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (_ , _ , refl , _)         = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (_ , _ , refl , _)         = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = {!!} -- I {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (_ , Step x a q) = S (_ , Step {!!} (ITCastFail y z w) {!!} )
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | V x = I (IFailedCast (FBoxed x) y z w)

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
    -- if the left is indetermiante but the right is a value
  progress (TAAp wt1 wt2) | I x | V x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | V y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | V y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | V y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = S (_ , Step FHOuter ITApCast FHOuter)

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = {!!} -- I {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (_ , Step x a q) = S (_ , Step {!!} (ITCastFail y z w) {!!} )
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | V x = I (IFailedCast (FBoxed x) y z w)


Removed unused code.

Removed unused code.

Ignore-this: bb2cba0cc416e210cbca1ac97da677e5

darcs-hash:20100505162046-3bd4e-f69bdae78351e9271235c7a8d96d8aea25255f18.gz

------------------------------------------------------------------------------
-- Inequalities on partial natural numbers
------------------------------------------------------------------------------

module LTC.Relation.Inequalities where

open import LTC.Minimal
open import MyStdLib.Data.Product

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

postulate
  lt : D → D → D

  lt-00 : lt zero zero                     ≡ false

  lt-0S : (d : D) → lt zero (succ d)       ≡ true

  lt-S0 : (d : D) → lt (succ d) zero       ≡ false

  lt-SS : (d e : D) → lt (succ d) (succ e) ≡ lt d e

{-# ATP axiom lt-00 #-}
{-# ATP axiom lt-0S #-}
{-# ATP axiom lt-S0 #-}
{-# ATP axiom lt-SS #-}

gt : D → D → D
gt d e = lt e d
{-# ATP definition gt #-}

------------------------------------------------------------------------
-- The data types

-- infix 4 _≤_ _<_ _≥_ _>_

GT : D → D → Set
GT d e = gt d e ≡ true
{-# ATP definition GT #-}

LT : D → D  → Set
LT d e = lt d e ≡ true
{-# ATP definition LT #-}

LE : D → D → Set
LE d e = gt d e ≡ false
{-# ATP definition LE #-}

GE : D → D → Set
GE d e = lt d e ≡ false
{-# ATP definition GE #-}

-- ------------------------------------------------------------------------
-- -- Lexicographical order on D
-- data LT₂ : D × D → D × D → Set where
--   left  : {x₁ x₂ y₁ y₂ : D} → LT x₁ x₂ → LT₂ (x₁ , y₁) (x₂ , y₂)
--   right : {x y₁ y₂ : D} →  LT y₁ y₂ → LT₂ (x , y₁) (x , y₂)
-- -- {-# ATP hint left #-}
-- -- {-# ATP hint right #-}


making complete expansion a little bit stronger by also observing that the resultant hole context must be empty

open import Nat
open import Prelude
open import core
open import contexts
open import typed-expansion
open import lemmas-gcomplete

module complete-expansion where
  -- this might be derivable from things below and a fact about => and ::
  -- that we seem to have not proven
  complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) → (Δ , Γ ⊢ d :: τ) → d dcomplete → τ tcomplete
  complete-ta gc TAConst comp = TCBase
  complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁
  complete-ta gc (TALam a wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁ a ) wt comp)
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) with complete-ta gc wt comp
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) | TCArr qq qq₁ = qq₁
  complete-ta gc (TAEHole x x₁) ()
  complete-ta gc (TANEHole x wt x₁) ()
  complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂
  complete-ta gc (TAFailedCast wt x x₁ x₂) ()

  comp-synth : ∀{Γ e τ} →
                   Γ gcomplete →
                   e ecomplete →
                   Γ ⊢ e => τ →
                   τ tcomplete
  comp-synth gc ec SConst = TCBase
  comp-synth gc (ECAsc x ec) (SAsc x₁) = x
  comp-synth gc ec (SVar x) = gc _ _ x
  comp-synth gc (ECAp ec ec₁) (SAp _ wt MAHole x₁) with comp-synth gc ec wt
  ... | ()
  comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) with comp-synth gc ec wt
  comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) | TCArr qq qq₁ = qq₁
  comp-synth gc () SEHole
  comp-synth gc () (SNEHole _ wt)
  comp-synth gc (ECLam2 ec x₁) (SLam x₂ wt) = TCArr x₁ (comp-synth (gcomp-extend gc x₁ x₂) ec wt)

  mutual
    complete-expansion-synth : ∀{e τ Γ Δ d} →
                               Γ gcomplete →
                               e ecomplete →
                               Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                               (d dcomplete × τ tcomplete × Δ == ∅)
    complete-expansion-synth gc ec ESConst = DCConst , TCBase , refl
    complete-expansion-synth gc ec (ESVar x₁) = DCVar , gc _ _ x₁ , refl
    complete-expansion-synth gc (ECLam2 ec x₁) (ESLam x₂ exp) with complete-expansion-synth (gcomp-extend gc x₁ x₂) ec exp
    ... | ih1 , ih2 , ih3 = DCLam ih1 x₁ , TCArr x₁ ih2 , ih3
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp _ _ x MAHole x₂ x₃) with comp-synth gc ec x
    ... | ()
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp {Δ1 = Δ1} {Δ2 = Δ2} _ _ x MAArr x₂ x₃)
      with comp-synth gc ec x
    ... | TCArr t1 t2
      with complete-expansion-ana gc ec (TCArr t1 t2) x₂ | complete-expansion-ana gc ec₁ t1 x₃
    ... | ih1 , ih4 | ih2 , ih3 = DCAp (DCCast ih1 (comp-ana gc x₂ ih1) (TCArr t1 t2)) (DCCast ih2 (comp-ana gc x₃ ih2) t1) ,
                                  t2 ,
                                  tr (λ qq → (qq ∪ Δ2) == ∅) (! ih4) (tr (λ qq → (∅ ∪ qq) == ∅) (! ih3) refl)
    complete-expansion-synth gc () ESEHole
    complete-expansion-synth gc () (ESNEHole _ exp)
    complete-expansion-synth gc (ECAsc x ec) (ESAsc x₁)
      with complete-expansion-ana gc ec x x₁
    ... | ih1 , ih2 = DCCast ih1 (comp-ana gc x₁ ih1) x , x , ih2

    complete-expansion-ana : ∀{e τ τ' Γ Δ d} →
                             Γ gcomplete →
                             e ecomplete →
                             τ tcomplete →
                             Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                             (d dcomplete × Δ == ∅)
    complete-expansion-ana gc (ECLam1 ec) () (EALam x₁ MAHole exp)
    complete-expansion-ana gc (ECLam1 ec) (TCArr t1 t2)  (EALam x₁ MAArr exp)
      with complete-expansion-ana (gcomp-extend gc t1 x₁) ec t2 exp
    ... | ih , ih2 = DCLam ih t1 , ih2
    complete-expansion-ana gc ec tc (EASubsume x x₁ x₂ x₃)
      with complete-expansion-synth gc ec x₂
    ... | ih1 , ih2 , ih3 = ih1 , ih3

    --this is just a convenience since it shows up a few times above
    comp-ana : ∀{Γ e τ d τ' Δ} →
       Γ gcomplete →
       Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
       d dcomplete →
       τ' tcomplete
    comp-ana gc ex dc = complete-ta gc (π2 (typed-expansion-ana ex)) dc

open import Nat
open import Prelude
open import core
open import contexts
open import typed-expansion
open import lemmas-gcomplete

module complete-expansion where
  -- this might be derivable from things below and a fact about => and ::
  -- that we seem to have not proven
  complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) → (Δ , Γ ⊢ d :: τ) → d dcomplete → τ tcomplete
  complete-ta gc TAConst comp = TCBase
  complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁
  complete-ta gc (TALam a wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁ a ) wt comp)
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) with complete-ta gc wt comp
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) | TCArr qq qq₁ = qq₁
  complete-ta gc (TAEHole x x₁) ()
  complete-ta gc (TANEHole x wt x₁) ()
  complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂
  complete-ta gc (TAFailedCast wt x x₁ x₂) ()

  comp-synth : ∀{Γ e τ} →
                   Γ gcomplete →
                   e ecomplete →
                   Γ ⊢ e => τ →
                   τ tcomplete
  comp-synth gc ec SConst = TCBase
  comp-synth gc (ECAsc x ec) (SAsc x₁) = x
  comp-synth gc ec (SVar x) = gc _ _ x
  comp-synth gc (ECAp ec ec₁) (SAp _ wt MAHole x₁) with comp-synth gc ec wt
  ... | ()
  comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) with comp-synth gc ec wt
  comp-synth gc (ECAp ec ec₁) (SAp _ wt MAArr x₁) | TCArr qq qq₁ = qq₁
  comp-synth gc () SEHole
  comp-synth gc () (SNEHole _ wt)
  comp-synth gc (ECLam2 ec x₁) (SLam x₂ wt) = TCArr x₁ (comp-synth (gcomp-extend gc x₁ x₂) ec wt)

  mutual
    complete-expansion-synth : ∀{e τ Γ Δ d} →
                               Γ gcomplete →
                               e ecomplete →
                               Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                               (d dcomplete × τ tcomplete)
    complete-expansion-synth gc ec ESConst = DCConst , TCBase
    complete-expansion-synth gc ec (ESVar x₁) = DCVar , gc _ _ x₁
    complete-expansion-synth gc (ECLam2 ec x₁) (ESLam x₂ exp) with complete-expansion-synth (gcomp-extend gc x₁ x₂) ec exp
    ... | ih1 , ih2 = DCLam ih1 x₁ , TCArr x₁ ih2
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp _ _ x MAHole x₂ x₃) with comp-synth gc ec x
    ... | ()
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp _ _ x MAArr x₂ x₃)
      with comp-synth gc ec x
    ... | TCArr t1 t2
      with complete-expansion-ana gc ec (TCArr t1 t2) x₂ | complete-expansion-ana gc ec₁ t1 x₃
    ... | ih1 | ih2 = DCAp (DCCast ih1 (comp-ana gc x₂ ih1) (TCArr t1 t2)) (DCCast ih2 (comp-ana gc x₃ ih2) t1) , t2

    complete-expansion-synth gc () ESEHole
    complete-expansion-synth gc () (ESNEHole _ exp)
    complete-expansion-synth gc (ECAsc x ec) (ESAsc x₁)
      with complete-expansion-ana gc ec x x₁
    ... | ih = DCCast ih (comp-ana gc x₁ ih) x , x

    complete-expansion-ana : ∀{e τ τ' Γ Δ d} →
                             Γ gcomplete →
                             e ecomplete →
                             τ tcomplete →
                             Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                             d dcomplete
    complete-expansion-ana gc (ECLam1 ec) () (EALam x₁ MAHole exp)
    complete-expansion-ana gc (ECLam1 ec) (TCArr t1 t2)  (EALam x₁ MAArr exp)
      with complete-expansion-ana (gcomp-extend gc t1 x₁) ec t2 exp
    ... | ih = DCLam ih t1
    complete-expansion-ana gc ec tc (EASubsume x x₁ x₂ x₃) = π1(complete-expansion-synth gc ec x₂)

    --this is just a convenience since it shows up a few times above
    comp-ana : ∀{Γ e τ d τ' Δ} →
       Γ gcomplete →
       Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
       d dcomplete →
       τ' tcomplete
    comp-ana gc ex dc = complete-ta gc (π2 (typed-expansion-ana ex)) dc


CyclicGroup: remove useless import

CyclicGroup: remove useless import

{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (JS[_]; return; _++_; _>>_)
open import FFI.JS.Check using (check!)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → JS[ ℤp★ ]
  BigI▹ℤ[_]★ x =
    -- Console.log "BigI▹ℤ[_]★" >>
    check! "below modulus" (x <I p)
           (λ _ → "Not below the modulus: p:" ++
                  toString p ++
                  " is less than x:" ++
                  toString x) >>
    check! "strictcly positive" (x >I 0I)
           (λ _ → "Should be strictly positive: " ++
                  toString x ++
                  " <= 0") >>
    return x

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv x p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (JS[_]; return; Bool; _++_; _>>_)
open import FFI.JS.Check using (check!)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → JS[ ℤp★ ]
  BigI▹ℤ[_]★ x =
    -- Console.log "BigI▹ℤ[_]★" >>
    check! "below modulus" (x <I p)
           (λ _ → "Not below the modulus: p:" ++
                  toString p ++
                  " is less than x:" ++
                  toString x) >>
    check! "strictcly positive" (x >I 0I)
           (λ _ → "Should be strictly positive: " ++
                  toString x ++
                  " <= 0") >>
    return x

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv x p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}


or-elimiation proved

or-elimiation proved

module IPL where

data _∧_ (P : Set) (Q : Set) : Set where
  ∧-intro : P → Q → (P ∧ Q)

proof₁ : {P Q : Set} → (P ∧ Q) → P
proof₁ (∧-intro p q) = p

proof₂ : {P Q : Set} → (P ∧ Q) → Q
proof₂ (∧-intro p q) = q

_⇔_ : (P : Set) → (Q : Set) → Set
a ⇔ b = (a → b) ∧ (b → a)

∧-comm′ : (P Q : Set) → (P ∧ Q) → (Q ∧ P)
∧-comm′ _ _ (∧-intro p q) = ∧-intro q p

∧-comm : (P Q : Set) → (P ∧ Q) ⇔ (Q ∧ P)
∧-comm P Q = ∧-intro (∧-comm′ P Q) (∧-comm′ Q P)

∧-comm1′ : {P Q : Set} → (P ∧ Q) → (Q ∧ P)
∧-comm1′ (∧-intro p q) = ∧-intro q p

data _∨_ (P Q : Set) : Set where
   ∨-intro₁ : P → P ∨ Q
   ∨-intro₂ : Q → P ∨ Q

∨-elim : {A B C : Set} → (A → C) → (B → C) → (A ∨ B) → C
∨-elim ac bc (∨-intro₁ a) = ac a
∨-elim ac bc (∨-intro₂ b) = bc b

module IPL where

data _∧_ (P : Set) (Q : Set) : Set where
  ∧-intro : P → Q → (P ∧ Q)

proof₁ : {P Q : Set} → (P ∧ Q) → P
proof₁ (∧-intro p q) = p

proof₂ : {P Q : Set} → (P ∧ Q) → Q
proof₂ (∧-intro p q) = q

_⇔_ : (P : Set) → (Q : Set) → Set
a ⇔ b = (a → b) ∧ (b → a)

∧-comm′ : (P Q : Set) → (P ∧ Q) → (Q ∧ P)
∧-comm′ _ _ (∧-intro p q) = ∧-intro q p

∧-comm : (P Q : Set) → (P ∧ Q) ⇔ (Q ∧ P)
∧-comm P Q = ∧-intro (∧-comm′ P Q) (∧-comm′ Q P)

∧-comm1′ : {P Q : Set} → (P ∧ Q) → (Q ∧ P)
∧-comm1′ (∧-intro p q) = ∧-intro q p

∧-comm1 : {P Q : Set} → (P ∧ Q) ⇔ (Q ∧ P)
∧-comm1 = ∧-intro ∧-comm1′ ∧-comm1′


Cosmetic changes.

Cosmetic changes.

Ignore-this: 22c69a21ac99143a432e5eaf91e798a

darcs-hash:20110305125148-3bd4e-eaf2fcfcc0c50fbe2e040203577ac1ce04f9e8d4.gz

------------------------------------------------------------------------------
-- Well-founded induction on the relation LTL
------------------------------------------------------------------------------

open import FOTC.Base

open import FOTC.Data.List
open import FOTC.Data.List.LT-Length
open import FOTC.Data.List.Type

module FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInduction
  (xs<[]→⊥                   : ∀ {xs} → List xs → ¬ (LTL xs []))
  (x∷xs<y∷ys→xs<ys           : ∀ {x xs y ys} → List xs → List ys →
                               LTL (x ∷ xs) (y ∷ ys) → LTL xs ys)
  (<-trans                   : ∀ {xs ys zs} → List xs → List ys → List zs →
                               LTL xs ys → LTL ys zs → LTL xs zs)
  (lg-xs≡lg-ys→ys<zx→xs<zs   : ∀ {xs ys zs} → length xs ≡ length ys →
                               LTL ys zs → LTL xs zs)
  (xs<y∷ys→xs<ys∨lg-xs≡lg-ys : ∀ {xs y ys} → List xs → List ys →
                               LTL xs (y ∷ ys) →
                               LTL xs ys ∨ length xs ≡ length ys)
  where

open import FOTC.Data.List.Induction.Acc.WellFounded

------------------------------------------------------------------------------
-- The relation LTL is well-founded.
-- Adapted from FOTC.Data.Nat.Induction.Acc.WellFoundedInduction.WF₁-LT.
wf-LTL : WellFounded LTL
wf-LTL Lxs = acc Lxs (helper Lxs)
  where
    helper : ∀ {xs ys} → List xs → List ys → LTL ys xs → Acc LTL ys
    helper nilL Lys ys<[] = ⊥-elim (xs<[]→⊥ Lys ys<[])
    helper (consL x {xs} Lxs) nilL []<x∷xs =
      acc nilL (λ Lys ys<[] → ⊥-elim (xs<[]→⊥ Lys ys<[]))
    helper (consL x {xs} Lxs) (consL y {ys} Lys) y∷ys<x∷xs = acc (consL y Lys)
      (λ {zs} Lzs zs<y∷ys →
          let ys<xs : LTL ys xs
              ys<xs = x∷xs<y∷ys→xs<ys Lys Lxs y∷ys<x∷xs

              zs<xs : LTL zs xs
              zs<xs = [ (λ zs<ys → <-trans Lzs Lys Lxs zs<ys ys<xs)
                      , (λ h → lg-xs≡lg-ys→ys<zx→xs<zs h ys<xs)
                      ] (xs<y∷ys→xs<ys∨lg-xs≡lg-ys Lzs Lys zs<y∷ys)

          in  helper Lxs Lzs zs<xs
        )

-- Well-founded induction on the relation LTL.
wfInd-LTL : (P : D → Set) →
            (∀ {xs} → List xs → (∀ {ys} → List ys → LTL ys xs → P ys) → P xs) →
            ∀ {xs} → List xs → P xs
wfInd-LTL P = WellFoundedInduction wf-LTL

------------------------------------------------------------------------------
-- Well-founded induction on the relation LTL
------------------------------------------------------------------------------

open import FOTC.Base
open import FOTC.Data.List
open import FOTC.Data.List.Type

open import FOTC.Data.List.LT-Length

  module FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInduction
  (xs<[]→⊥                   : ∀ {xs} → List xs → ¬ (LTL xs []))
  (x∷xs<y∷ys→xs<ys           : ∀ {x xs y ys} → List xs → List ys →
                               LTL (x ∷ xs) (y ∷ ys) → LTL xs ys)
  (<-trans                   : ∀ {xs ys zs} → List xs → List ys → List zs →
                               LTL xs ys → LTL ys zs → LTL xs zs)
  (lg-xs≡lg-ys→ys<zx→xs<zs   : ∀ {xs ys zs} → length xs ≡ length ys →
                               LTL ys zs → LTL xs zs)
  (xs<y∷ys→xs<ys∨lg-xs≡lg-ys : ∀ {xs y ys} → List xs → List ys →
                               LTL xs (y ∷ ys) →
                               LTL xs ys ∨ length xs ≡ length ys)
  where

open import FOTC.Data.List.Induction.Acc.WellFounded

------------------------------------------------------------------------------
-- The relation LTL is well-founded.
-- Adapted from FOTC.Data.Nat.Induction.Acc.WellFoundedInduction.WF₁-LT
wf-LTL : WellFounded LTL
wf-LTL Lxs = acc Lxs (helper Lxs)
  where
    helper : ∀ {xs ys} → List xs → List ys → LTL ys xs → Acc LTL ys
    helper nilL Lys ys<[] = ⊥-elim (xs<[]→⊥ Lys ys<[])
    helper (consL x {xs} Lxs) nilL []<x∷xs =
      acc nilL (λ Lys ys<[] → ⊥-elim (xs<[]→⊥ Lys ys<[]))
    helper (consL x {xs} Lxs) (consL y {ys} Lys) y∷ys<x∷xs = acc (consL y Lys)
      (λ {zs} Lzs zs<y∷ys →
          let ys<xs : LTL ys xs
              ys<xs = x∷xs<y∷ys→xs<ys Lys Lxs y∷ys<x∷xs

              zs<xs : LTL zs xs
              zs<xs = [ (λ zs<ys → <-trans Lzs Lys Lxs zs<ys ys<xs)
                      , (λ h → lg-xs≡lg-ys→ys<zx→xs<zs h ys<xs)
                      ] (xs<y∷ys→xs<ys∨lg-xs≡lg-ys Lzs Lys zs<y∷ys)

          in  helper Lxs Lzs zs<xs
        )

-- Well-founded induction on the relation LTL.
wfInd-LTL : (P : D → Set) →
            (∀ {xs} → List xs → (∀ {ys} → List ys → LTL ys xs → P ys) → P xs) →
            ∀ {xs} → List xs → P xs
wfInd-LTL P = WellFoundedInduction wf-LTL


otp: permutations

otp: permutations

module single-bit-one-time-pad where

open import Function.NP
open import Data.Bool.NP as Bool
open import Data.Product renaming (map to <_×_>)
open import Data.Nat.NP
import Data.Vec.NP as V
open V using (Vec; take; drop; drop′; take′; _++_) renaming (swap to vswap)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning)

open import Data.Bits
open import flipbased-implem
open import program-distance

K = Bit
M = Bit
C = Bit

record Adv (S₀ S₁ S₂ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    step₁ : S₀ → (Bit → M) × S₁
    step₂ : C × S₁ → S₂
    step₃ : S₂ → Bit

record Adv₁ (S₀ S₁ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    -- step₁ s₀ = id , s₀
    step₂ : C × S₀ → S₁
    step₃ : S₁ → Bit

Adv₂ : ∀ ca → Set
Adv₂ ca = ↺ ca (C → Bit)

module Run⅁′ {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open Adv A
  E : M → ↺ 1 C
  E m = toss >>= λ k → return↺ (m xor k)
  run⅁′ : ⅁? (ca + 1)
  run⅁′ b = step₀ >>= λ s₀ →
            case step₁ s₀ of λ {(m , s₁) →
            E (m b) >>= λ c →
            return↺ (step₃ (step₂ (c , s₁)))}

module Run⅁ {S₀ S₁ S₂ ca} (E : K → M → C) (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
  open Adv A

  kont₀ : ⅁? _
  kont₀ k =
    step₀ ▹↺ λ s₀ →
    case step₁ s₀ of λ {(m , s₁) →
    let c = E k (m b) in
    step₃ (step₂ (c , s₁))}

  run⅁ : EXP (1 + ca)
  run⅁ = toss >>= kont₀

  {- looks wrong
module Run⅁-Properties {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b k : Bit) where
  open Run⅁ A
  kont₀-not : kont₀ b k ≡ kont₀ (not b) (not k)
  kont₀-not rewrite xor-not-not b k = {!refl!}
  -}

module SymAdv (homPrgDist : HomPrgDist) {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  step₁′ : S₀ → (Bit → M) × S₁
  step₁′ s₀ = case step₁ s₀ of λ { (m , s₁) → (m ∘ not , s₁) }
  symA : Adv S₀ S₁ S₂ ca
  symA = mk step₀ step₁′ step₂ (not ∘ step₃)

  symA′ : Adv S₀ S₁ S₂ ca
  symA′ = mk step₀ step₁′ step₂ step₃

  open Run⅁ _xor_ A renaming (run⅁ to runA)
  open Run⅁ _xor_ symA renaming (run⅁ to runSymA)
  open Run⅁ _xor_ symA′ renaming (run⅁ to runSymA′)
  {-
  helper : ∀ {n} (g₀ g₁ : EXP n) → g₀ ]-[ g₁ → not↺ g₀ ]-[ not↺ g₁
  helper = {!!}
  lem : runA ⇓ runSymA
  lem A-breaks-E = {!helper (uunSymA′ 0b) (runSymA′ 1)!}
     where pf : breaks runSymA
           pf = {!!}
  -}

module Run⅁₂ {ca} (A : Adv₂ ca) (b : Bit) where
  E : Bit → M → C
  E k m = m xor k

  m : Bit → Bit
  m = id

  kont₀ : ⅁? _
  kont₀ k =
      A ▹↺ λ f →
      f (E k (m b))

      {-
    kont₀′ : ⅁? _
    kont₀′ k =
      conv-Adv A ▹↺ λ f →
      f (E k (m b))
      -}

  run⅁₂ : EXP (1 + ca)
  run⅁₂ = toss >>= kont₀

module Run⅁₂-Properties {ca} (A : Adv₂ ca) where
    open Run⅁₂ A renaming (run⅁₂ to runA)
    kont₀-not : ∀ b k → kont₀ b k ≡ kont₀ (not b) (not k)
    kont₀-not b k rewrite xor-not-not b k = ≡.refl

    open ≡-Reasoning

    lem₂ : ∀ b → count↺ (runA b) ≡ count↺ (runA (not b))
    lem₂ b = count↺ (runA b)
          ≡⟨ ≡.refl ⟩
            count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
          ≡⟨ ≡.cong₂ (_+_ on count↺) (kont₀-not b 0b) (kont₀-not b 1b) ⟩
            count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
          ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
            count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
          ≡⟨ ≡.refl ⟩
            count↺ (runA (not b)) ∎

    lem₃ : Safe⅁? runA
    lem₃ = lem₂ 0b

    -- A specialized version of lem₂ (≈lem₃)
    lem₄ : Safe⅁? (Run⅁₂.run⅁₂ A)
    lem₄    = count↺ (runA 0b)
            ≡⟨ ≡.refl ⟩
              count↺ (kont₀ 0b 0b) + count↺ (kont₀ 0b 1b)
            ≡⟨ ≡.cong₂ (_+_ on count↺) (kont₀-not 0b 0b) (kont₀-not 0b 1b) ⟩
              count↺ (kont₀ 1b 1b) + count↺ (kont₀ 1b 0b)
            ≡⟨ ℕ°.+-comm (count↺ (kont₀ 1b 1b)) _ ⟩
              count↺ (kont₀ 1b 0b) + count↺ (kont₀ 1b 1b)
            ≡⟨ ≡.refl ⟩
              count↺ (runA 1b) ∎

conv-Adv : ∀ {ca S₀ S₁ S₂} → Adv S₀ S₁ S₂ ca → Adv₂ ca
conv-Adv A = step₀ ▹↺ λ s₀ →
             case step₁ s₀ of λ {(m , s₁) →
             λ c → m (step₃ (step₂ (c , s₁)))}
  where open Adv A

module Conv-Adv-Props (homPrgDist : HomPrgDist) {ca S₀ S₁ S₂} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  open Run⅁ _xor_ A renaming (run⅁ to runA)
  -- open Run⅁-Properties A

  A′ : Adv₂ ca
  A′ = conv-Adv A
  open Run⅁₂ A′ using () renaming (kont₀ to kont₀′; run⅁₂ to runA′)

  kont₀′′ : ∀ b k → EXP ca
  kont₀′′ b k =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ ((m b) xor k , s₁)))}

  kont₀′′′ : ∀ b′ → EXP ca
  kont₀′′′ b′ =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ (b′ , s₁)))}

  {-
  kont′′-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′′ b k)
  kont′′-lem true true = {!!}
  kont′′-lem false true = {!!}
  kont′′-lem true false = {!!}
  kont′′-lem false false = {!!}

  kont-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′ b k)
  kont-lem b true = {!!}
  kont-lem b false = {!!}

  conv-Adv-lem : runA ≈⅁? runA′
  conv-Adv-lem b = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ _+_ (kont-lem b 0b) (kont-lem b 1b) ⟩
          count↺ (kont₀′ b 0b) + count↺ (kont₀′ b 1b)
        ≡⟨ refl ⟩
          count↺ (runA′ b) ∎

  conv-Adv-sound : runA ⇓ runA′
  conv-Adv-sound = ]-[-cong-≈↺ (conv-Adv-lem 0b) (conv-Adv-lem 1b)
  -}
-- Cute fact: this is true by computation!
count↺-toss->>= : ∀ {c} (f : ⅁? c) → count↺ (toss >>= f) ≡ count↺ (f 0b) + count↺ (f 1b)
count↺-toss->>= f = ≡.refl

{-
module Run⅁-Properties' {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
    open Run⅁ _xor_ A renaming (run⅁ to runA)
    lem : count↺ (runA b) ≡ count↺ (runA (not b))
    lem = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ (_+_ on count↺) {x = kont₀ b 0b} {kont₀ (not b) 1b} {kont₀ b 1b} {kont₀ (not b) 0b} {!!} {!!} ⟩
          count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
        ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
          count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
        ≡⟨ refl ⟩
          count↺ (runA (not b)) ∎
-}
open import program-distance
open import Relation.Nullary

⁇ : ∀ {n} → ↺ n (Bits n)
-- ⁇ = random
⁇ = mk id

lem'' : ∀ {k} (f : Bits k → Bit) → #⟨ f ∘ tail ⟩ ≡ 2* #⟨ f ⟩
lem'' f = ≡.refl

lem' : ∀ {k} (f g : Bits k → Bit) → #⟨ f ∘ tail ⟩ ≡ #⟨ g ∘ tail ⟩ → #⟨ f ⟩ ≡ #⟨ g ⟩
lem' f g pf = 2*-inj (≡.trans (lem'' f) (≡.trans pf (≡.sym (lem'' g))))

drop-tail : ∀ k {n a} {A : Set a} → drop (suc k) {n} ≗ drop k ∘ tail {A = A}
drop-tail k (x ∷ xs) = V.drop-∷ k x xs

lemdrop′ : ∀ {k n} (f : Bits n → Bit) → #⟨ f ∘ drop′ k ⟩ ≡ ⟨2^ k * #⟨ f ⟩ ⟩
lemdrop′ {zero} f = ≡.refl
lemdrop′ {suc k} f = #⟨ f ∘ drop′ k ∘ tail ⟩
                   ≡⟨ lem'' (f ∘ drop′ k) ⟩
                     2* #⟨ f ∘ drop′ k ⟩
                   ≡⟨ ≡.cong 2*_ (lemdrop′ {k} f) ⟩
                     2* ⟨2^ k * #⟨ f ⟩ ⟩ ∎
                    where open ≡-Reasoning

-- exchange to independant statements
lem-flip$-⊕ : ∀ {m n a} {A : Set a} (f : ↺ m (A → Bit)) (x : ↺ n A) →
               count↺ ⟪ flip _$_ · x · f ⟫ ≡ count↺ (f ⊛ x)
lem-flip$-⊕ {m} {n} f x = ≡.sym (
               count↺ fx
              ≡⟨ #-+ {m} {n} (run↺ fx) ⟩
               sum {m} (λ xs → #⟨_⟩ {n} (λ ys → run↺ fx (xs ++ ys)))
              ≡⟨ sum-sum {m} {n} (Bool.toℕ ∘ run↺ fx) ⟩
               sum {n} (λ ys → #⟨_⟩ {m} (λ xs → run↺ fx (xs ++ ys)))
              ≡⟨ sum-≗₂ (λ ys xs → Bool.toℕ (run↺ fx (xs ++ ys)))
                        (λ ys xs → Bool.toℕ (run↺ ⟪ flip _$_ · x · f ⟫ (ys ++ xs)))
                        (λ ys xs → ≡.cong Bool.toℕ (lem₁ xs ys)) ⟩
               sum {n} (λ ys → #⟨_⟩ {m} (λ xs → run↺ ⟪ flip _$_ · x · f ⟫ (ys ++ xs)))
              ≡⟨ ≡.sym (#-+ {n} {m} (run↺ ⟪ flip _$_ · x · f ⟫)) ⟩
               count↺ ⟪ flip _$_ · x · f ⟫
              ∎ )
    where open ≡-Reasoning
          fx = f ⊛ x
          lem₁ : ∀ xs ys → run↺ f (take m (xs ++ ys)) (run↺ x (drop m (xs ++ ys)))
                         ≡ run↺ f (drop n (ys ++ xs)) (run↺ x (take n (ys ++ xs)))
          lem₁ xs ys rewrite V.take-++ m xs ys | V.drop-++ m xs ys
                           | V.take-++ n ys xs | V.drop-++ n ys xs = ≡.refl

≈ᴬ′-toss : ∀ b → ⟪ b ⟫ᴰ ⟨xor⟩ toss ≈ᴬ′ toss
≈ᴬ′-toss true Adv = ℕ°.+-comm (count↺ (Adv true)) _
≈ᴬ′-toss false Adv = ≡.refl

≈ᴬ-toss : ∀ b → ⟪ b ⟫ᴰ ⟨xor⟩ toss ≈ᴬ toss
≈ᴬ-toss b Adv = ≈ᴬ′-toss b (returnᴰ ∘ Adv)

-- should be equivalent to #-comm if ⟪ m ⟫ᴰ ⟨⊕⟩ x were convertible to ⟪ _⊕_ m · x ⟫
≈ᴬ-⁇ : ∀ {k} (m : Bits k) → ⟪ m ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⁇
≈ᴬ-⁇ {zero}  _       _ = ≡.refl
≈ᴬ-⁇ {suc k} (h ∷ m) Adv
  rewrite ≈ᴬ-⁇ m (Adv ∘ _∷_ (h xor 0b))
        | ≈ᴬ-⁇ m (Adv ∘ _∷_ (h xor 1b))
        = ≈ᴬ′-toss h (λ x → ⟪ Adv ∘ _∷_ x · ⁇ ⟫)

open OperationSyntax

_⟨∙⟩_ : Op → ∀ {m n} → Endo (↺ m (Bits n))
f ⟨∙⟩ g = ⟪ _∙_ f · g ⟫

≈ᴬ-op-⁇ : ∀ {k} f → f ⟨∙⟩ ⁇ ≈ᴬ ⁇ {k}
≈ᴬ-op-⁇ = flip #-op

≈ᴬ-⁇₂ : ∀ {k} (m₀ m₁ : Bits k) → ⟪ m₀ ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ m₁ ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₂ {k} m₀ m₁ = ≈ᴬ.trans {k} (≈ᴬ-⁇ m₀) (≈ᴬ.sym {k} (≈ᴬ-⁇ m₁))

≈ᴬ-⁇₃ : ∀ {k} (m : Bit → Bits k) (b : Bit) → ⟪ m b ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ m (not b) ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₃ m b = ≈ᴬ-⁇₂ (m b) (m (not b))

≈ᴬ-⁇₄ : ∀ {k} (m : Bits k × Bits k) (b : Bit) → ⟪ proj m b ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ proj m (not b) ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₄ = ≈ᴬ-⁇₃ ∘ proj

module single-bit-one-time-pad where

open import Function
open import Data.Bool.NP as Bool
open import Data.Product renaming (map to <_×_>)
open import Data.Nat.NP
import Data.Vec.NP as V
open V using (Vec; take; drop; drop′; take′; _++_) renaming (swap to vswap)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning)

open import Data.Bits
open import flipbased-implem
open import program-distance

K = Bit
M = Bit
C = Bit

record Adv (S₀ S₁ S₂ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    step₁ : S₀ → (Bit → M) × S₁
    step₂ : C × S₁ → S₂
    step₃ : S₂ → Bit

record Adv₁ (S₀ S₁ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    -- step₁ s₀ = id , s₀
    step₂ : C × S₀ → S₁
    step₃ : S₁ → Bit

Adv₂ : ∀ ca → Set
Adv₂ ca = ↺ ca (C → Bit)

module Run⅁′ {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open Adv A
  E : M → ↺ 1 C
  E m = toss >>= λ k → return↺ (m xor k)
  run⅁′ : ⅁? (ca + 1)
  run⅁′ b = step₀ >>= λ s₀ →
            case step₁ s₀ of λ {(m , s₁) →
            E (m b) >>= λ c →
            return↺ (step₃ (step₂ (c , s₁)))}

module Run⅁ {S₀ S₁ S₂ ca} (E : K → M → C) (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
  open Adv A

  kont₀ : ⅁? _
  kont₀ k =
    step₀ ▹↺ λ s₀ →
    case step₁ s₀ of λ {(m , s₁) →
    let c = E k (m b) in
    step₃ (step₂ (c , s₁))}

  run⅁ : EXP (1 + ca)
  run⅁ = toss >>= kont₀

  {- looks wrong
module Run⅁-Properties {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b k : Bit) where
  open Run⅁ A
  kont₀-not : kont₀ b k ≡ kont₀ (not b) (not k)
  kont₀-not rewrite xor-not-not b k = {!refl!}
  -}

module SymAdv (homPrgDist : HomPrgDist) {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  step₁′ : S₀ → (Bit → M) × S₁
  step₁′ s₀ = case step₁ s₀ of λ { (m , s₁) → (m ∘ not , s₁) }
  symA : Adv S₀ S₁ S₂ ca
  symA = mk step₀ step₁′ step₂ (not ∘ step₃)

  symA′ : Adv S₀ S₁ S₂ ca
  symA′ = mk step₀ step₁′ step₂ step₃

  open Run⅁ _xor_ A renaming (run⅁ to runA)
  open Run⅁ _xor_ symA renaming (run⅁ to runSymA)
  open Run⅁ _xor_ symA′ renaming (run⅁ to runSymA′)
  {-
  helper : ∀ {n} (g₀ g₁ : EXP n) → g₀ ]-[ g₁ → not↺ g₀ ]-[ not↺ g₁
  helper = {!!}
  lem : runA ⇓ runSymA
  lem A-breaks-E = {!helper (uunSymA′ 0b) (runSymA′ 1)!}
     where pf : breaks runSymA
           pf = {!!}
  -}

module Run⅁₂ {ca} (A : Adv₂ ca) (b : Bit) where
  E : Bit → M → C
  E k m = m xor k

  m : Bit → Bit
  m = id

  kont₀ : ⅁? _
  kont₀ k =
      A ▹↺ λ f →
      f (E k (m b))

      {-
    kont₀′ : ⅁? _
    kont₀′ k =
      conv-Adv A ▹↺ λ f →
      f (E k (m b))
      -}

  run⅁₂ : EXP (1 + ca)
  run⅁₂ = toss >>= kont₀

module Run⅁₂-Properties {ca} (A : Adv₂ ca) where
    open Run⅁₂ A renaming (run⅁₂ to runA)
    kont₀-not : ∀ b k → kont₀ b k ≡ kont₀ (not b) (not k)
    kont₀-not b k rewrite xor-not-not b k = ≡.refl

    open ≡-Reasoning

    lem₂ : ∀ b → count↺ (runA b) ≡ count↺ (runA (not b))
    lem₂ b = count↺ (runA b)
          ≡⟨ ≡.refl ⟩
            count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
          ≡⟨ ≡.cong₂ (_+_ on count↺) (kont₀-not b 0b) (kont₀-not b 1b) ⟩
            count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
          ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
            count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
          ≡⟨ ≡.refl ⟩
            count↺ (runA (not b)) ∎

    lem₃ : Safe⅁? runA
    lem₃ = lem₂ 0b

    -- A specialized version of lem₂ (≈lem₃)
    lem₄ : Safe⅁? (Run⅁₂.run⅁₂ A)
    lem₄    = count↺ (runA 0b)
            ≡⟨ ≡.refl ⟩
              count↺ (kont₀ 0b 0b) + count↺ (kont₀ 0b 1b)
            ≡⟨ ≡.cong₂ (_+_ on count↺) (kont₀-not 0b 0b) (kont₀-not 0b 1b) ⟩
              count↺ (kont₀ 1b 1b) + count↺ (kont₀ 1b 0b)
            ≡⟨ ℕ°.+-comm (count↺ (kont₀ 1b 1b)) _ ⟩
              count↺ (kont₀ 1b 0b) + count↺ (kont₀ 1b 1b)
            ≡⟨ ≡.refl ⟩
              count↺ (runA 1b) ∎

conv-Adv : ∀ {ca S₀ S₁ S₂} → Adv S₀ S₁ S₂ ca → Adv₂ ca
conv-Adv A = step₀ ▹↺ λ s₀ →
             case step₁ s₀ of λ {(m , s₁) →
             λ c → m (step₃ (step₂ (c , s₁)))}
  where open Adv A

module Conv-Adv-Props (homPrgDist : HomPrgDist) {ca S₀ S₁ S₂} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  open Run⅁ _xor_ A renaming (run⅁ to runA)
  -- open Run⅁-Properties A

  A′ : Adv₂ ca
  A′ = conv-Adv A
  open Run⅁₂ A′ using () renaming (kont₀ to kont₀′; run⅁₂ to runA′)

  kont₀′′ : ∀ b k → EXP ca
  kont₀′′ b k =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ ((m b) xor k , s₁)))}

  kont₀′′′ : ∀ b′ → EXP ca
  kont₀′′′ b′ =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ (b′ , s₁)))}

  {-
  kont′′-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′′ b k)
  kont′′-lem true true = {!!}
  kont′′-lem false true = {!!}
  kont′′-lem true false = {!!}
  kont′′-lem false false = {!!}

  kont-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′ b k)
  kont-lem b true = {!!}
  kont-lem b false = {!!}

  conv-Adv-lem : runA ≈⅁? runA′
  conv-Adv-lem b = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ _+_ (kont-lem b 0b) (kont-lem b 1b) ⟩
          count↺ (kont₀′ b 0b) + count↺ (kont₀′ b 1b)
        ≡⟨ refl ⟩
          count↺ (runA′ b) ∎

  conv-Adv-sound : runA ⇓ runA′
  conv-Adv-sound = ]-[-cong-≈↺ (conv-Adv-lem 0b) (conv-Adv-lem 1b)
  -}
-- Cute fact: this is true by computation!
count↺-toss->>= : ∀ {c} (f : ⅁? c) → count↺ (toss >>= f) ≡ count↺ (f 0b) + count↺ (f 1b)
count↺-toss->>= f = ≡.refl

{-
module Run⅁-Properties' {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
    open Run⅁ _xor_ A renaming (run⅁ to runA)
    lem : count↺ (runA b) ≡ count↺ (runA (not b))
    lem = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ (_+_ on count↺) {x = kont₀ b 0b} {kont₀ (not b) 1b} {kont₀ b 1b} {kont₀ (not b) 0b} {!!} {!!} ⟩
          count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
        ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
          count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
        ≡⟨ refl ⟩
          count↺ (runA (not b)) ∎
-}
open import program-distance
open import Relation.Nullary

⁇ : ∀ {n} → ↺ n (Bits n)
⁇ = random

lem'' : ∀ {k} (f : Bits k → Bit) → #⟨ f ∘ tail ⟩ ≡ 2* #⟨ f ⟩
lem'' f = ≡.refl

lem' : ∀ {k} (f g : Bits k → Bit) → #⟨ f ∘ tail ⟩ ≡ #⟨ g ∘ tail ⟩ → #⟨ f ⟩ ≡ #⟨ g ⟩
lem' f g pf = 2*-inj (≡.trans (lem'' f) (≡.trans pf (≡.sym (lem'' g))))

drop-tail : ∀ k {n a} {A : Set a} → drop (suc k) {n} ≗ drop k ∘ tail {A = A}
drop-tail k (x ∷ xs) = V.drop-∷ k x xs

lemdrop′ : ∀ {k n} (f : Bits n → Bit) → #⟨ f ∘ drop′ k ⟩ ≡ ⟨2^ k * #⟨ f ⟩ ⟩
lemdrop′ {zero} f = ≡.refl
lemdrop′ {suc k} f = #⟨ f ∘ drop′ k ∘ tail ⟩
                   ≡⟨ lem'' (f ∘ drop′ k) ⟩
                     2* #⟨ f ∘ drop′ k ⟩
                   ≡⟨ ≡.cong 2*_ (lemdrop′ {k} f) ⟩
                     2* ⟨2^ k * #⟨ f ⟩ ⟩ ∎
                    where open ≡-Reasoning

-- exchange to independant statements
lem-flip$-⊕ : ∀ {m n a} {A : Set a} (f : ↺ m (A → Bit)) (x : ↺ n A) →
               count↺ ⟪ flip _$_ · x · f ⟫ ≡ count↺ (f ⊛ x)
lem-flip$-⊕ {m} {n} f x = ≡.sym (
               count↺ fx
              ≡⟨ #-+ {m} {n} (run↺ fx) ⟩
               sum {m} (λ xs → #⟨_⟩ {n} (λ ys → run↺ fx (xs ++ ys)))
              ≡⟨ sum-sum {m} {n} (Bool.toℕ ∘ run↺ fx) ⟩
               sum {n} (λ ys → #⟨_⟩ {m} (λ xs → run↺ fx (xs ++ ys)))
              ≡⟨ sum-≗₂ (λ ys xs → Bool.toℕ (run↺ fx (xs ++ ys)))
                        (λ ys xs → Bool.toℕ (run↺ ⟪ flip _$_ · x · f ⟫ (ys ++ xs)))
                        (λ ys xs → ≡.cong Bool.toℕ (lem₁ xs ys)) ⟩
               sum {n} (λ ys → #⟨_⟩ {m} (λ xs → run↺ ⟪ flip _$_ · x · f ⟫ (ys ++ xs)))
              ≡⟨ ≡.sym (#-+ {n} {m} (run↺ ⟪ flip _$_ · x · f ⟫)) ⟩
               count↺ ⟪ flip _$_ · x · f ⟫
              ∎ )
    where open ≡-Reasoning
          fx = f ⊛ x
          lem₁ : ∀ xs ys → run↺ f (take m (xs ++ ys)) (run↺ x (drop m (xs ++ ys)))
                         ≡ run↺ f (drop n (ys ++ xs)) (run↺ x (take n (ys ++ xs)))
          lem₁ xs ys rewrite V.take-++ m xs ys | V.drop-++ m xs ys
                           | V.take-++ n ys xs | V.drop-++ n ys xs = ≡.refl

≈ᴬ′-toss : ∀ b → ⟪ b ⟫ᴰ ⟨xor⟩ toss ≈ᴬ′ toss
≈ᴬ′-toss true Adv = ℕ°.+-comm (count↺ (Adv true)) _
≈ᴬ′-toss false Adv = ≡.refl

≈ᴬ-toss : ∀ b → ⟪ b ⟫ᴰ ⟨xor⟩ toss ≈ᴬ toss
≈ᴬ-toss b Adv = ≈ᴬ′-toss b (returnᴰ ∘ Adv)

-- should be equivalent to #-comm if ⟪ m ⟫ᴰ ⟨⊕⟩ x were convertible to ⟪ _⊕_ m · x ⟫
≈ᴬ-⁇ : ∀ {k} (m : Bits k) → ⟪ m ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⁇
≈ᴬ-⁇ {zero}  _       _ = ≡.refl
≈ᴬ-⁇ {suc k} (h ∷ m) Adv
  rewrite ≈ᴬ-⁇ m (Adv ∘ _∷_ (h xor 0b))
        | ≈ᴬ-⁇ m (Adv ∘ _∷_ (h xor 1b))
        = ≈ᴬ′-toss h (λ x → ⟪ Adv ∘ _∷_ x · ⁇ ⟫)

≈ᴬ-⁇₂ : ∀ {k} (m₀ m₁ : Bits k) → ⟪ m₀ ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ m₁ ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₂ {k} m₀ m₁ = ≈ᴬ.trans {k} (≈ᴬ-⁇ m₀) (≈ᴬ.sym {k} (≈ᴬ-⁇ m₁))

≈ᴬ-⁇₃ : ∀ {k} (m : Bit → Bits k) (b : Bit) → ⟪ m b ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ m (not b) ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₃ m b = ≈ᴬ-⁇₂ (m b) (m (not b))

≈ᴬ-⁇₄ : ∀ {k} (m : Bits k × Bits k) (b : Bit) → ⟪ proj m b ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ proj m (not b) ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₄ = ≈ᴬ-⁇₃ ∘ proj


Typo.

Typo.

Ignore-this: 7ff4279cea3751561b0a45c24a588967

darcs-hash:20101130074907-3bd4e-2ced29f128dcfb342686615a9d6c60073dd9ec60.gz

------------------------------------------------------------------------------
-- Peano arithmetic base
------------------------------------------------------------------------------

module Draft.PA.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe
-- N.B. The following module is exported by this module.
open import Common.Universe public renaming ( D to PA )

-- Logical constants
-- N.B. The module is exported by this module.
open import Common.LogicalConstants public

-- Non-logical constants
postulate
  zero : PA
  succ : PA → PA
  _+_  : PA → PA → PA
  _*_  : PA → PA → PA

-- The PA equality
-- The PA equality is the propositional identity on the PA universe.
-- N.B. The following modules are exported by this module.
-- N.B. We are not using the refl and sym properties because they are
-- not stated in the proper axioms (see below).
open import Common.Relation.Binary.PropositionalEquality public
  using ( _≡_ )
open import Common.Relation.Binary.PropositionalEquality.Properties public
  using ( trans )

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- S₁. x₁ = x₂ → x₁ = x₃ → x₂ = x₃
-- S₂. x₁ = x₂ → succ x₁ = succ x₂
-- S₃. 0 ≠ succ x
-- S₄. succ x₁ = succ x₂ → x₁ = x₂
-- S₅. x₁ + 0 = x₁
-- S₆. x₁ + succ x₂ = succ (x₁ + x₂)
-- S₇. x₁ * 0 = 0
-- S₈. x₁ * succ x₂ = (x₁ * x₂) + x₁
-- S₉. P(0) → (∀x.P(x) → P(succ x)) → ∀x.P(x)

postulate
  -- S₁: This axiom is the transitivity property imported from
  --     Common.Relation.Binary.PropositionalEquality.Properties.

  -- S₂: This axiom is not required by the ATPs.

  S₃ : ∀ {x} → ¬ (zero ≡ succ x)

  S₄ : ∀ {x₁ x₂} → succ x₁ ≡ succ x₂ → x₁ ≡ x₂

  S₅ : ∀ x →     zero    + x  ≡ x
  S₆ : ∀ x₁ x₂ → succ x₁ + x₂ ≡ succ (x₁ + x₂)

  S₇ : ∀ x →     zero    * x  ≡ zero
  S₈ : ∀ x₁ x₂ → succ x₁ * x₂ ≡ x₂ + x₁ * x₂

  -- S₉: Instead of the induction schema we will use the inductive predicate N
  --     (see Draft.PA.Type).

{-# ATP axiom S₃ #-}
{-# ATP axiom S₄ #-}
{-# ATP axiom S₅ #-}
{-# ATP axiom S₆ #-}
{-# ATP axiom S₇ #-}
{-# ATP axiom S₈ #-}

------------------------------------------------------------------------------
-- Peano arithmetic base
------------------------------------------------------------------------------

module Draft.PA.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe
-- N.B. The following module is exported by this module.
open import Common.Universe public renaming ( D to PA )

-- Logical constants
-- N.B. The module is exported by this module.
open import Common.LogicalConstants public

-- Non-logical constants of PA.
postulate
  zero : PA
  succ : PA → PA
  _+_  : PA → PA → PA
  _*_  : PA → PA → PA

-- The PA equality
-- The PA equality is the propositional identity on the PA universe.
-- N.B. The following modules are exported by this module.
-- N.B. We are not using the refl and sym properties because they are
-- not stated in the proper axioms (see below).
open import Common.Relation.Binary.PropositionalEquality public
  using ( _≡_ )
open import Common.Relation.Binary.PropositionalEquality.Properties public
  using ( trans )

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- S₁. x₁ = x₂ → x₁ = x₃ → x₂ = x₃
-- S₂. x₁ = x₂ → succ x₁ = succ x₂
-- S₃. 0 ≠ succ x
-- S₄. succ x₁ = succ x₂ → x₁ = x₂
-- S₅. x₁ + 0 = x₁
-- S₆. x₁ + succ x₂ = succ (x₁ + x₂)
-- S₇. x₁ * 0 = 0
-- S₈. x₁ * succ x₂ = (x₁ * x₂) + x₁
-- S₉. P(0) → (∀x.P(x) → P(succ x)) → ∀x.P(x)

postulate
  -- S₁: This axiom is the transitivity property imported from
  --     Common.Relation.Binary.PropositionalEquality.Properties.

  -- S₂: This axiom is not required by the ATPs.

  S₃ : ∀ {x} → ¬ (zero ≡ succ x)

  S₄ : ∀ {x₁ x₂} → succ x₁ ≡ succ x₂ → x₁ ≡ x₂

  S₅ : ∀ x →     zero    + x  ≡ x
  S₆ : ∀ x₁ x₂ → succ x₁ + x₂ ≡ succ (x₁ + x₂)

  S₇ : ∀ x →     zero    * x  ≡ zero
  S₈ : ∀ x₁ x₂ → succ x₁ * x₂ ≡ x₂ + x₁ * x₂

  -- S₉: Instead of the induction schema we will use the inductive predicate N
  --     see (Draft.PA.Type)

{-# ATP axiom S₃ #-}
{-# ATP axiom S₄ #-}
{-# ATP axiom S₅ #-}
{-# ATP axiom S₆ #-}
{-# ATP axiom S₇ #-}
{-# ATP axiom S₈ #-}


Document Postulate.Extensionality regularly.

Old-commit-hash: 35222e92088dbd2313ec7252e50cd68e85b340bf

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Postulate extensionality of functions.
--
-- Justification on Agda mailing list:
-- http://permalink.gmane.org/gmane.comp.lang.agda/2343
------------------------------------------------------------------------

module Postulate.Extensionality where

open import Relation.Binary.PropositionalEquality

postulate ext : ∀ {a b} → Extensionality a b

-- Convenience of using extensionality 3 times in a row
-- (using it twice in a row is moderately tolerable)
ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))

module Postulate.Extensionality where

-- POSTULATE EXTENSIONALITY
--
-- Justification on Agda mailing list:
-- http://permalink.gmane.org/gmane.comp.lang.agda/2343

open import Relation.Binary.PropositionalEquality

postulate ext : ∀ {a b} → Extensionality a b

-- Convenience of using extensionality 3 times in a row
-- (using it twice in a row is moderately tolerable)
ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))