Stratified Desc model: checkpoint Set0/Set1

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

module Desc 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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- 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

pair : {i j : Level}{A : Set i}{B : A -> Set j} ->
       (x : A) (y : B x) -> Sigma {i = i}{j = j} A B
pair x y = x , y

_*_ : {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 m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (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

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

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

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

data Desc : Set1 where
  id : Desc
  const : Set -> Desc
  prod : Desc -> Desc -> Desc
  sigma : (S : Set) -> (S -> Desc) -> Desc
  pi : (S : Set) -> (S -> Desc) -> Desc

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

[|_|]_ : Desc -> Set -> Set
[| id |] Z        = Z
[| const X |] Z   = X
[| prod D D' |] Z = [| D |] Z * [| D' |] Z
[| sigma S T |] Z = Sigma S (\s -> [| T s |] Z)
[| pi S T |] Z    = (s : S) -> [| T s |] Z

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

data Mu (D : Desc) : Set where
  con : [| D |] (Mu D) -> Mu D

--********************************************
-- Predicate: All
--********************************************

All : {l : Level}(D : Desc)(X : Set)(P : X -> Set l) -> [| D |] X -> Set l
All id          X P x        = P x
All (const Z)   X P x        = Unit
All (prod D D') X P (d , d') = (All D X P d) * (All D' X P d')
All (sigma S T) X P (a , b)  = All (T a) X P b
All (pi S T)    X P f        = (s : S) -> All (T s) X P (f s)

all : (D : Desc)(X : Set)(P : X -> Set)(R : (x : X) -> P x)(x : [| D |] X) -> All D X P x
all id X P R x = R x
all (const Z) X P R z = Void
all (prod D D') X P R (d , d') = all D X P R d , all D' X P R d'
all (sigma S T) X P R (a , b) = all (T a) X P R b
all (pi S T) X P R f = \ s -> all (T s) X P R (f s)

--********************************************
-- Map
--********************************************

map : (D : Desc)(X Y : Set)(f : X -> Y)(v : [| D |] X) -> [| D |] Y
map id X Y sig x = sig x
map (const Z) X Y sig z = z
map (prod D D') X Y sig (d , d') = map D X Y sig d , map D' X Y sig d'
map (sigma S T) X Y sig (a , b) = (a , map (T a) X Y sig b)
map (pi S T) X Y sig f = \x -> map (T x) X Y sig (f x)

proof-map-id : (D : Desc)(X : Set)(v : [| D |] X) -> map D X X (\x -> x) v == v
proof-map-id id X v = refl
proof-map-id (const Z) X v = refl
proof-map-id (prod D D') X (v , v') = cong2 (\x y -> (x , y)) (proof-map-id D X v) (proof-map-id D' X v')
proof-map-id (sigma S T) X (a , b) = cong (\x -> (a , x)) (proof-map-id (T a) X b)
proof-map-id (pi S T) X f = reflFun (\a -> map (T a) X X (\x -> x) (f a)) f (\a -> proof-map-id (T a) X (f a))

proof-map-compos : (D : Desc)(X Y Z : Set)
                   (f : X -> Y)(g : Y -> Z)
                   (v : [| D |] X) ->
                   map D X Z (\x -> g (f x)) v == map D Y Z g (map D X Y f v)
proof-map-compos id X Y Z f g v = refl
proof-map-compos (const K) X Y Z f g v = refl
proof-map-compos (prod D D') X Y Z f g (v , v') = cong2 (\x y -> (x , y))
                                                        (proof-map-compos D X Y Z f g v)
                                                        (proof-map-compos D' X Y Z f g v')
proof-map-compos (sigma S T) X Y Z f g (a , b) = cong (\x -> (a , x)) (proof-map-compos (T a) X Y Z f g b)
proof-map-compos (pi S T) X Y Z f g fc = reflFun (\a -> map (T a) X Z (\x -> g (f x)) (fc a))
                                                 (\a -> map (T a) Y Z g (map (T a) X Y f (fc a)))
                                                 (\a -> proof-map-compos (T a) X Y Z f g (fc a))

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

-- One would like to write the following:

{-
induction : (D : Desc)
            (P : Mu D -> Set) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
induction D P ms (con xs) = ms xs (all D (Mu D) P (\x -> induction D P ms x) xs)
-}

-- But the termination checker is unhappy.
-- So we write the following:

module Elim {l : Level}
            (D : Desc)
            (P : Mu D -> Set l)
            (ms : (x : [| D |] (Mu D)) ->
                  All D (Mu D) P x -> P (con x))
       where

    mutual
        induction : (x : Mu D) -> P x
        induction (con xs) =  ms xs (hyps D xs)

        hyps : (D' : Desc)
               (xs : [| D' |] (Mu D)) ->
               All D' (Mu D) P xs
        hyps id x = induction x
        hyps (const Z) z = Void
        hyps (prod D D') (d , d') = hyps D d , hyps D' d'
        hyps (sigma S T) (a , b) = hyps (T a) b
        hyps (pi S T) f = \s -> hyps (T s) (f s)

induction : {l : Level}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
induction D P ms x = Elim.induction D P ms x

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> Desc
natCases Ze = const Unit
natCases Suc = id

NatD : Desc
NatD = sigma NatConst  natCases

Nat : Set
Nat = Mu NatD

ze : Nat
ze = con (Ze , Void)

su : Nat -> Nat
su n = con (Su , n)

--****************
-- List
--****************

data ListConst : Set where
  Nil : ListConst
  Cons : ListConst

listCases : Set -> ListConst -> Desc
listCases X Nil = const Unit
listCases X Cons = sigma X (\_ -> id)

ListD : Set -> Desc
ListD X = sigma ListConst (listCases X)

List : Set -> Set
List X = Mu (ListD X)

nil : {X : Set} -> List X
nil = con ( Nil , Void )

cons : {X : Set} -> X -> List X -> List X
cons x t = con ( Cons , ( x , t ))

--****************
-- Tree
--****************

data TreeConst : Set where
  Leaf : TreeConst
  Node : TreeConst

treeCases : Set -> TreeConst -> Desc
treeCases X Leaf = const Unit
treeCases X Node = sigma X (\_ -> prod id id)

TreeD : Set -> Desc
TreeD X = sigma TreeConst (treeCases X)

Tree : Set -> Set
Tree X = Mu (TreeD X)

leaf : {X : Set} -> Tree X
leaf = con (Leaf , Void)

node : {X : Set} -> X -> Tree X -> Tree X -> Tree X
node x le ri = con (Node , (x , (le , ri)))

--********************************************
-- Finite sets
--********************************************

-- If we weren't such bug fans of levitating things, we would
-- implement finite sets with:

{-

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n
-}

-- But no, we make it fly in Desc:

EnumU : Set
EnumU = Nat

nilE : EnumU
nilE = ze

consE : EnumU -> EnumU
consE e = su e

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

-- All : {l : Level}(D : Desc)(X : Set l)(P : X -> Set l) -> [| D |] X -> Set l

{-
casesSpi : (xs : [| NatD |] Nat) ->
           All NatD (Nat {l = zero}) (\e -> (EnumT e -> Set1) -> Set1) xs ->
           (EnumT (con xs) -> Set1) -> Set1
casesSpi (Ze , Void) hs P' = Unit
casesSpi (Su , n) hs P' = P' EZe * hs (\e -> P' (ESu e))
-}

{-
induction : {l : Level}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
-}

casesSpi : (xs : [| NatD |] Nat) ->
           All NatD Nat (\e -> (EnumT e -> Set) -> Set) xs ->
           (EnumT (con xs) -> Set) -> Set
casesSpi (Ze , Void) hs P' = Unit
casesSpi (Su , n) hs P' = P' EZe * hs (\e -> P' (ESu e))

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi e P =  induction NatD (\E -> (EnumT E -> Set) -> Set) casesSpi e P

{-
casesSwitch : (xs : [| NatD |] Nat) ->
              All NatD Nat (\e -> (P' : EnumT e -> Set1)
                                  (b' : spi e P')
                                  (x' : EnumT e) -> P' x') xs ->
              (P' : EnumT (con xs) -> Set1)
              (b' : spi (con xs) P')
              (x' : EnumT (con xs)) -> P' x'
casesSwitch (Ze , Void) hs P' b' ()
casesSwitch (Su , n) hs P' b' EZe = fst b'
casesSwitch (Su , n) hs P' b' (ESu e') = hs (\e -> P' (ESu e)) (snd b') e'

switch : (e : EnumU)
         (P : EnumT e -> Set1)
         (b : spi e P)
         (x : EnumT e) -> P x
switch e P b xs =  induction NatD
                            (\e -> (P : EnumT e -> Set1)
                                   (b : spi e P)
                                   (xs : EnumT e) -> P xs)
                            casesSwitch e P b xs

--********************************************
-- Tagged description
--********************************************

-- data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j)
-- spi : {l : Level}(e : EnumU)(P : EnumT e -> Set l) -> Set l

TagDesc : Set2
TagDesc = Sigma (EnumU {l = suc (suc zero)}) (\e -> spi e (\_ -> Desc {l = zero}))

toDesc : {l : Level} -> TagDesc -> Desc {l = zero}
toDesc {x} (B , F) = {!!} -- sigma (EnumT B) (\e -> ?) --switch B (\_ -> Desc {l = x}) F e)

test : (E : EnumU {l = suc (suc zero)}) -> spi E (\_ -> Desc {l = zero}) -> EnumT E -> Desc {l = zero}
test B F e = {!switch B (\_ -> Desc {l = zero}) F e!}

-}
--********************************************
-- Catamorphism
--********************************************

{-

cata : (D : Desc)
       (T : Set) ->
       ([| D |] T -> T) ->
       (Mu D) -> T
cata D T phi x = induction D (\_ -> T) (\x ms -> phi (replace D T x ms)) x
  where replace : (D' : Desc)(T : Set)(xs : [| D' |] (Mu D))(ms : All D' (Mu D) (\_ -> T) xs) -> [| D' |] T
        replace id T x y = y
        replace (const Z) T z z' = z'
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Free monad construction
--********************************************

_**_ : TagDesc -> (X : Set) -> TagDesc
(e , D) ** X = consE e , (const X , D)

--********************************************
-- Substitution
--********************************************

apply : (D : TagDesc)(X Y : Set) ->
        (X -> Mu (toDesc (D ** Y))) ->
        [| toDesc (D ** X) |] (Mu (toDesc (D ** Y))) ->
        Mu (toDesc (D ** Y))
apply (E , B) X Y sig (EZe , x) = sig x
apply (E , B) X Y sig (ESu n , t) = con (ESu n , t)

subst : (D : TagDesc)(X Y : Set) ->
        Mu (toDesc (D ** X)) ->
        (X -> Mu (toDesc (D ** Y))) ->
        Mu (toDesc (D ** Y))
subst D X Y x sig = cata (toDesc (D ** X)) (Mu (toDesc (D ** Y))) (apply D X Y sig) x
-}

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

module Desc 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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- 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

pair : {i j : Level}{A : Set i}{B : A -> Set j} ->
       (x : A) (y : B x) -> Sigma {i = i}{j = j} A B
pair x y = x , y

_*_ : {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 m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (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

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

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

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

data Desc {l : Level} : Set (suc l) where
  id : Desc
  const : Set l -> Desc
  prod : Desc -> Desc -> Desc
  sigma : (S : Set l) -> (S -> Desc) -> Desc
  pi : (S : Set l) -> (S -> Desc) -> Desc

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

[|_|]_ : {l : Level} -> Desc -> Set l -> Set l
[| id |] Z        = Z
[| const X |] Z   = X
[| prod D D' |] Z = [| D |] Z * [| D' |] Z
[| sigma S T |] Z = Sigma S (\s -> [| T s |] Z)
[| pi S T |] Z    = (s : S) -> [| T s |] Z

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

data Mu {l : Level}(D : Desc {l = l}) : Set l where
  con : [| D |] (Mu D) -> Mu D

--********************************************
-- Predicate: All
--********************************************

All : {l : Level}(D : Desc)(X : Set l)(P : X -> Set l) -> [| D |] X -> Set l
All id          X P x        = P x
All (const Z)   X P x        = Unit
All (prod D D') X P (d , d') = (All D X P d) * (All D' X P d')
All (sigma S T) X P (a , b)  = All (T a) X P b
All (pi S T)    X P f        = (s : S) -> All (T s) X P (f s)

all : {l : Level}(D : Desc)(X : Set l)(P : X -> Set l)(R : (x : X) -> P x)(x : [| D |] X) -> All D X P x
all id X P R x = R x
all (const Z) X P R z = Void
all (prod D D') X P R (d , d') = all D X P R d , all D' X P R d'
all (sigma S T) X P R (a , b) = all (T a) X P R b
all (pi S T) X P R f = \ s -> all (T s) X P R (f s)

--********************************************
-- Map
--********************************************

map : {l : Level}(D : Desc)(X Y : Set l)(f : X -> Y)(v : [| D |] X) -> [| D |] Y
map id X Y sig x = sig x
map (const Z) X Y sig z = z
map (prod D D') X Y sig (d , d') = map D X Y sig d , map D' X Y sig d'
map (sigma S T) X Y sig (a , b) = (a , map (T a) X Y sig b)
map (pi S T) X Y sig f = \x -> map (T x) X Y sig (f x)

proof-map-id : {l : Level}(D : Desc)(X : Set l)(v : [| D |] X) -> map D X X (\x -> x) v == v
proof-map-id id X v = refl
proof-map-id (const Z) X v = refl
proof-map-id (prod D D') X (v , v') = cong2 (\x y -> (x , y)) (proof-map-id D X v) (proof-map-id D' X v')
proof-map-id (sigma S T) X (a , b) = cong (\x -> (a , x)) (proof-map-id (T a) X b)
proof-map-id (pi S T) X f = reflFun (\a -> map (T a) X X (\x -> x) (f a)) f (\a -> proof-map-id (T a) X (f a))

proof-map-compos : {l : Level}(D : Desc)(X Y Z : Set l)
                   (f : X -> Y)(g : Y -> Z)
                   (v : [| D |] X) ->
                   map D X Z (\x -> g (f x)) v == map D Y Z g (map D X Y f v)
proof-map-compos id X Y Z f g v = refl
proof-map-compos (const K) X Y Z f g v = refl
proof-map-compos (prod D D') X Y Z f g (v , v') = cong2 (\x y -> (x , y))
                                                        (proof-map-compos D X Y Z f g v)
                                                        (proof-map-compos D' X Y Z f g v')
proof-map-compos (sigma S T) X Y Z f g (a , b) = cong (\x -> (a , x)) (proof-map-compos (T a) X Y Z f g b)
proof-map-compos (pi S T) X Y Z f g fc = reflFun (\a -> map (T a) X Z (\x -> g (f x)) (fc a))
                                                 (\a -> map (T a) Y Z g (map (T a) X Y f (fc a)))
                                                 (\a -> proof-map-compos (T a) X Y Z f g (fc a))

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

-- One would like to write the following:

{-
induction : {l : Set}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
induction D P ms (con xs) = ms xs (all D (Mu D) P (\x -> induction D P ms x) xs)
-}

-- But the termination checker is unhappy.
-- So we write the following:

module Elim {l : Level}
            (D : Desc)
            (P : Mu D -> Set l)
            (ms : (x : [| D |] (Mu D)) ->
                  All D (Mu D) P x -> P (con x))
       where

    mutual
        induction : (x : Mu D) -> P x
        induction (con xs) =  ms xs (hyps D xs)

        hyps : (D' : Desc)
               (xs : [| D' |] (Mu D)) ->
               All D' (Mu D) P xs
        hyps id x = induction x
        hyps (const Z) z = Void
        hyps (prod D D') (d , d') = hyps D d , hyps D' d'
        hyps (sigma S T) (a , b) = hyps (T a) b
        hyps (pi S T) f = \s -> hyps (T s) (f s)

induction : {l : Level}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
induction D P ms x = Elim.induction D P ms x

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst {l : Level} : Set l where
  Ze : NatConst
  Su : NatConst

natCases : {l : Level} -> NatConst {l = l} -> Desc {l = l}
natCases Ze = const Unit
natCases Suc = id

NatD : {l : Level} -> Desc {l = l}
NatD {x} = sigma {l = x} NatConst  natCases

Nat : {l : Level} -> Set l
Nat = Mu NatD

ze : {l : Level} -> Nat {l = l}
ze {x} = con (pair {i = x} {j = x} Ze Void)

su : {l : Level} -> Nat {l = l} -> Nat {l = l}
su {x} n = con (pair {i = x} {j = x} Su n)

--****************
-- List
--****************

data ListConst : Set where
  Nil : ListConst
  Cons : ListConst

listCases : Set -> ListConst -> Desc
listCases X Nil = const Unit
listCases X Cons = sigma X (\_ -> id)

ListD : Set -> Desc
ListD X = sigma ListConst (listCases X)

List : Set -> Set
List X = Mu (ListD X)

nil : {X : Set} -> List X
nil = con ( Nil , Void )

cons : {X : Set} -> X -> List X -> List X
cons x t = con ( Cons , ( x , t ))

--****************
-- Tree
--****************

data TreeConst : Set where
  Leaf : TreeConst
  Node : TreeConst

treeCases : Set -> TreeConst -> Desc
treeCases X Leaf = const Unit
treeCases X Node = sigma X (\_ -> prod id id)

TreeD : Set -> Desc
TreeD X = sigma TreeConst (treeCases X)

Tree : Set -> Set
Tree X = Mu (TreeD X)

leaf : {X : Set} -> Tree X
leaf = con (Leaf , Void)

node : {X : Set} -> X -> Tree X -> Tree X -> Tree X
node x le ri = con (Node , (x , (le , ri)))

--********************************************
-- Finite sets
--********************************************

-- If we weren't such bug fans of levitating things, we would
-- implement finite sets with:

{-

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n
-}

-- But no, we make it fly in Desc:

EnumU : {l : Level} -> Set l
EnumU = Nat

nilE : {l : Level} -> EnumU {l = l}
nilE {x} = ze {l = x}

consE : {l : Level} -> EnumU -> EnumU {l = l}
consE {x} e = su {l = x} e

data EnumT {l : Level} : (e : EnumU {l = l}) -> Set l where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

-- All : {l : Level}(D : Desc)(X : Set l)(P : X -> Set l) -> [| D |] X -> Set l

{-
casesSpi : (xs : [| NatD |] Nat) ->
           All NatD (Nat {l = zero}) (\e -> (EnumT e -> Set1) -> Set1) xs ->
           (EnumT (con xs) -> Set1) -> Set1
casesSpi (Ze , Void) hs P' = Unit
casesSpi (Su , n) hs P' = P' EZe * hs (\e -> P' (ESu e))
-}

{-
induction : {l : Level}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
-}

spi : (e : EnumU {l = zero})(P : EnumT {l = zero} e -> Set) -> Set
spi e P =  induction NatD (\E -> {!(EnumT {l = zero} e -> Set) -> Set!}) {!!} e  ?

{-
casesSwitch : (xs : [| NatD |] Nat) ->
              All NatD Nat (\e -> (P' : EnumT e -> Set1)
                                  (b' : spi e P')
                                  (x' : EnumT e) -> P' x') xs ->
              (P' : EnumT (con xs) -> Set1)
              (b' : spi (con xs) P')
              (x' : EnumT (con xs)) -> P' x'
casesSwitch (Ze , Void) hs P' b' ()
casesSwitch (Su , n) hs P' b' EZe = fst b'
casesSwitch (Su , n) hs P' b' (ESu e') = hs (\e -> P' (ESu e)) (snd b') e'

switch : (e : EnumU)
         (P : EnumT e -> Set1)
         (b : spi e P)
         (x : EnumT e) -> P x
switch e P b xs =  induction NatD
                            (\e -> (P : EnumT e -> Set1)
                                   (b : spi e P)
                                   (xs : EnumT e) -> P xs)
                            casesSwitch e P b xs

--********************************************
-- Tagged description
--********************************************

-- data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j)
-- spi : {l : Level}(e : EnumU)(P : EnumT e -> Set l) -> Set l

TagDesc : Set2
TagDesc = Sigma (EnumU {l = suc (suc zero)}) (\e -> spi e (\_ -> Desc {l = zero}))

toDesc : {l : Level} -> TagDesc -> Desc {l = zero}
toDesc {x} (B , F) = {!!} -- sigma (EnumT B) (\e -> ?) --switch B (\_ -> Desc {l = x}) F e)

test : (E : EnumU {l = suc (suc zero)}) -> spi E (\_ -> Desc {l = zero}) -> EnumT E -> Desc {l = zero}
test B F e = {!switch B (\_ -> Desc {l = zero}) F e!}

-}
--********************************************
-- Catamorphism
--********************************************

{-

cata : (D : Desc)
       (T : Set) ->
       ([| D |] T -> T) ->
       (Mu D) -> T
cata D T phi x = induction D (\_ -> T) (\x ms -> phi (replace D T x ms)) x
  where replace : (D' : Desc)(T : Set)(xs : [| D' |] (Mu D))(ms : All D' (Mu D) (\_ -> T) xs) -> [| D' |] T
        replace id T x y = y
        replace (const Z) T z z' = z'
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Free monad construction
--********************************************

_**_ : TagDesc -> (X : Set) -> TagDesc
(e , D) ** X = consE e , (const X , D)

--********************************************
-- Substitution
--********************************************

apply : (D : TagDesc)(X Y : Set) ->
        (X -> Mu (toDesc (D ** Y))) ->
        [| toDesc (D ** X) |] (Mu (toDesc (D ** Y))) ->
        Mu (toDesc (D ** Y))
apply (E , B) X Y sig (EZe , x) = sig x
apply (E , B) X Y sig (ESu n , t) = con (ESu n , t)

subst : (D : TagDesc)(X Y : Set) ->
        Mu (toDesc (D ** X)) ->
        (X -> Mu (toDesc (D ** Y))) ->
        Mu (toDesc (D ** Y))
subst D X Y x sig = cata (toDesc (D ** X)) (Mu (toDesc (D ** Y))) (apply D X Y sig) x
-}


Only white space.

Only white space.

Ignore-this: 3c31ab0a948cb2060a9774b36afb0522

darcs-hash:20100505162557-3bd4e-272690a3fb1e771a2d00378d140d2867c3e088dc.gz

------------------------------------------------------------------------------
-- Well-founded induction
------------------------------------------------------------------------------

module MyStdLib.Induction.WellFounded where

-- From: http://www.iis.sinica.edu.tw/~scm/2008/well-founded-recursion-and-accessibility/

data Acc {A : Set}(R : A → A → Set) : A → Set where
  acc : (x : A) → ((y : A) → R y x → Acc R y) → Acc R x

WellFounded : {A : Set} → (A → A → Set) → Set
WellFounded {A} R = (x : A) → Acc R x

accFold : {A : Set}(R : A → A → Set){P : A → Set} →
          ((x : A) → ((y : A) → R y x → P y) → P x) →
          (x : A) → Acc R x → P x
accFold R f x (acc .x h) = f x (λ y y<x → accFold R f y (h y y<x))

wellFoundedInd : {A : Set} {R : A → A → Set} {P : A → Set} →
                 WellFounded R →
                 ((x : A) → ((y : A) → R y x → P y) → P x) →
                 (x : A) → P x
wellFoundedInd {R = R} wf f x = accFold R f x (wf x)

------------------------------------------------------------------------------
-- Well-founded induction
------------------------------------------------------------------------------

module MyStdLib.Induction.WellFounded where

-- From: http://www.iis.sinica.edu.tw/~scm/2008/well-founded-recursion-and-accessibility/

data Acc {A : Set}(R : A → A → Set) : A → Set where
  acc : (x : A) → (( y : A) →  R y x → Acc R y) → Acc R x

WellFounded : {A : Set} → (A → A → Set) → Set
WellFounded {A} R = (x : A) → Acc R x

accFold : {A : Set}(R : A → A → Set){P : A → Set} →
          ((x : A) → ((y : A) → R y x → P y) → P x) →
          (x : A) → Acc R x → P x
accFold R f x (acc .x h) = f x (λ y y<x → accFold R f y (h y y<x))

wellFoundedInd : {A : Set} {R : A → A → Set} {P : A → Set} →
                 WellFounded R →
                 ((x : A) → ((y : A) → R y x → P y) → P x) →
                 (x : A) → P x
wellFoundedInd {R = R} wf f x = accFold R f x (wf x)


Rename Atlas-apply to apply-base.

Rename Atlas-apply to apply-base.

Old-commit-hash: aa571d5b9c41b6b4aa16886b55721dc3dbd9e033

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

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

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

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

diff-base : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
diff-base {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
diff-base {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs diff-base) m₁ m₂)

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

apply-base : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
apply-base {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
apply-base {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs apply-base) m₁ m₂)

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

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (ΔType τ)
diff = app₂ (lift-diff diff-base apply-base)

apply : ∀ {τ Γ} →
  Term Γ (ΔType τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply diff-base apply-base)

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

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

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

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

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

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

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

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

diff-base : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
diff-base {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
diff-base {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs diff-base) m₁ m₂)

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

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-apply {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-apply) m₁ m₂)

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

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (ΔType τ)
diff = app₂ (lift-diff diff-base Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (ΔType τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply diff-base Atlas-apply)

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

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

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

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


Cosmetic change.

Cosmetic change.

Ignore-this: 47e76b0e22c2d499cca454901b5785c

darcs-hash:20110301044040-3bd4e-fef74b987c4ab44e77595f538c5b01230921319d.gz

----------------------------------------------------------------------------
-- Well-founded induction
----------------------------------------------------------------------------

module FOTC.Data.Nat.Induction.Acc.WellFounded where

-- Adapted from
-- http://www.iis.sinica.edu.tw/~scm/2008/well-founded-recursion-and-accessibility/
-- and the Agda standard library.

open import FOTC.Base

open import Common.Function
open import FOTC.Data.Nat.Type

----------------------------------------------------------------------------
-- The accessibility predicate: x is accessible if everything which is
-- smaller than x is also accessible (inductively).
data Acc (_<_ : D → D → Set) : D → Set where
 acc : ∀ {n} → N n → (∀ {m} → N m → m < n → Acc _<_ m) → Acc _<_ n

accFold : {P : D → Set} (_<_ : D → D → Set) →
          (∀ {n} → N n → (∀ {m} → N m → m < n → P m) → P n) →
          ∀ {n} → N n → Acc _<_ n → P n
accFold _<_ f Nn (acc _ h) = f Nn (λ Nm m<n → accFold _<_ f Nm (h Nm m<n))

-- The accessibility predicate encodes what it means to be
-- well-founded; if all elements are accessible, then _<_ is
-- well-founded.
WellFounded : (D → D → Set) → Set
WellFounded _<_ = ∀ {n} → N n → Acc _<_ n

WellFoundedInduction : {P : D → Set} {_<_ : D → D → Set} →
                       WellFounded _<_ →
                       (∀ {n} → N n → (∀ {m} → N m → m < n → P m) → P n) →
                       ∀ {n} → N n → P n
WellFoundedInduction {_<_ = _<_} wf f Nn = accFold _<_ f Nn (wf Nn)

module InverseImage {_<_ : D → D → Set}
                    (f : D → D)
                    (f-N : ∀ {n} → N n → N (f n))
                    where

  accessible : ∀ {n} → N n → Acc _<_ (f n) → Acc (λ x y → (f x) < (f y)) n
  accessible Nn (acc _ rs) =
    acc Nn (λ {m} Nm fm<fn → accessible Nm (rs (f-N Nm) fm<fn) )

  wellFounded : WellFounded _<_ → WellFounded (λ x y → (f x) < (f y))
  wellFounded wf = λ Nn → accessible Nn (wf (f-N Nn))

----------------------------------------------------------------------------
-- Well-founded induction
----------------------------------------------------------------------------

module FOTC.Data.Nat.Induction.Acc.WellFounded where

-- Adapted from
-- http://www.iis.sinica.edu.tw/~scm/2008/well-founded-recursion-and-accessibility/ and the Agda standard library.

open import FOTC.Base

open import Common.Function
open import FOTC.Data.Nat.Type

----------------------------------------------------------------------------
-- The accessibility predicate: x is accessible if everything which is
-- smaller than x is also accessible (inductively).
data Acc (_<_ : D → D → Set) : D → Set where
 acc : ∀ {n} → N n → (∀ {m} → N m → m < n → Acc _<_ m) → Acc _<_ n

accFold : {P : D → Set} (_<_ : D → D → Set) →
          (∀ {n} → N n → (∀ {m} → N m → m < n → P m) → P n) →
          ∀ {n} → N n → Acc _<_ n → P n
accFold _<_ f Nn (acc _ h) = f Nn (λ Nm m<n → accFold _<_ f Nm (h Nm m<n))

-- The accessibility predicate encodes what it means to be
-- well-founded; if all elements are accessible, then _<_ is
-- well-founded.
WellFounded : (D → D → Set) → Set
WellFounded _<_ = ∀ {n} → N n → Acc _<_ n

WellFoundedInduction : {P : D → Set} {_<_ : D → D → Set} →
                       WellFounded _<_ →
                       (∀ {n} → N n → (∀ {m} → N m → m < n → P m) → P n) →
                       ∀ {n} → N n → P n
WellFoundedInduction {_<_ = _<_} wf f Nn = accFold _<_ f Nn (wf Nn)

module InverseImage {_<_ : D → D → Set}
                    (f : D → D)
                    (f-N : ∀ {n} → N n → N (f n))
                    where

  accessible : ∀ {n} → N n → Acc _<_ (f n) → Acc (λ x y → (f x) < (f y)) n
  accessible Nn (acc _ rs) =
    acc Nn (λ {m} Nm fm<fn → accessible Nm (rs (f-N Nm) fm<fn) )

  wellFounded : WellFounded _<_ → WellFounded (λ x y → (f x) < (f y))
  wellFounded wf = λ Nn → accessible Nn (wf (f-N Nn))


working on #14 after #26

working on #14 after #26

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFinal x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFinal x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter (CECong eps er)) = {!!}
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong x₁ er) = {!!}
  ve (BVVal x) (CECong x₁ er) = ve (lem-valfill x x₁) er
    where
    lem-valfill : ∀{ε d d'} → d val → d == ε ⟦ d' ⟧ → d' boxedval
    lem-valfill VConst FHOuter = BVVal VConst
    lem-valfill VLam FHOuter = BVVal VLam

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast x bv) (d' , Step FHOuter x₂ FHOuter) = {!x₂!} -- cyrus
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err -- this feels extremely strange
    ie (INEHole x) (CECong FHOuter err) = {!!}
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err) = {!!}
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = {!!}
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFinal x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = {!!}
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFinal x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = {!!}
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole x ind) stp = {!!}
  lem2 (ICastHoleGround x ind x₁) stp = {!!}

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁) = {!!} -- cyrus

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FBoxed x)) FHOuter) = vi x ind
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FIndet x)) FHOuter) = {!!} -- cyrus
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    is (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es er stp = {!!}

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFinal x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFinal x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter (CECong eps er)) = {!!}
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong x₁ er) = {!!}
  ve (BVVal x) (CECong x₁ er) = ve (lem-valfill x x₁) er
    where
    lem-valfill : ∀{ε d d'} → d val → d == ε ⟦ d' ⟧ → d' boxedval
    lem-valfill VConst FHOuter = BVVal VConst
    lem-valfill VLam FHOuter = BVVal VLam

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast x bv) (d' , Step FHOuter x₂ FHOuter) = {!x₂!} -- cyrus
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  mutual
    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err -- this is extremely strange
    ie (INEHole x) (CECong x₁ err) = {!!} -- fe x {!!}
    ie (IAp x indet x₁) (CECong x₂ err) = {!x₂!}
    ie (ICastArr x indet) (CECong x₁ err) = {!!}
    ie (ICastGroundHole x indet) (CECastFinal x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong x₁ err) = {!!}
    ie (ICastHoleGround x indet x₁) (CECastFinal x₂ x₃ x₄ x₅) = {!!}
    ie (ICastHoleGround x indet x₁) (CECong x₂ err) = {!!}

    -- ie (INEHole x) (ENEHole e) = fe x e
    -- ie (IAp i x) (EAp1 e) = ie i e
    -- ie (IAp i x) (EAp2 y e) = fe x e
    -- ie (ICast i) (ECastError x x₁) = {!!} -- todo: this is evidence that casts are busted
    -- ie (ICast i) (ECastProp x) = ie i x

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = {!!} -- cyrus
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole x ind) stp = {!!}
  lem2 (ICastHoleGround x ind x₁) stp = {!!}

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁) = {!!} -- cyrus

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 (FBoxed x) FHOuter = FBoxed x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet x) FHOuter = FIndet x
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = {!!} -- cyrus / maybe that error in the rule with pi-types
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FBoxed x)) FHOuter) = vi x ind
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FIndet x)) FHOuter) = {!!}
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind g) (d' , Step FHOuter x₂ FHOuter) = {!!}
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es er stp = {!!}


red counterexamples; green examples and counterexamples

{-

    Verified KoopaTroopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin renaming (_+_ to _F+_; _<_ to _F<_; suc to fsuc;
    zero to fzero)
  open import Data.Vec renaming (map to vmap; lookup to vlookup;
                                     replicate to vreplicate)
  open import Data.Unit
  open import Data.Empty

  module Matrix where
    data Matrix (A : Set) : ℕ → ℕ → Set where
      Mat : {w h : ℕ} → Vec (Vec A w) h → Matrix A w h

    lookup : ∀ {w h} {A : Set} → Fin h → Fin w → Matrix A w h → A
    lookup row column (Mat rows) = vlookup column (vlookup row rows)
  open Matrix

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa : Color → Set where
    _KT : (c : Color) → KoopaTroopa c

  data Material : Set where
    gas    : Material
    -- liquid : Material
    solid  : Material

  data Clearance : Set where
    Low  : Clearance
    High : Clearance
    God  : Clearance

  record Position : Set where
    constructor pos
    field
      x   : ℕ
      y   : ℕ
      mat : Material
      clr : Clearance

  data _c>_ : Color → Clearance → Set where
    <red>   : ∀ {c} → c c> Low
    <green> : Green c> High

  data _follows_⟨_⟩ : Position → Position → Color → Set where
    stay  : ∀ {c x y} → pos x y gas Low follows pos x y gas Low ⟨ c ⟩
    next  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos (suc x) y gas cl follows pos x y gas Low ⟨ c ⟩
    back  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos x y gas cl follows pos (suc x) y gas Low ⟨ c ⟩
    -- jump  : ∀ {c x y} → pos x (suc y) gas High follows pos x y gas Low ⟨ c ⟩
    fall  : ∀ {c cl x y} → pos x y gas cl follows pos x (suc y) gas High ⟨ c ⟩

  infixr 5 _↠⟨_⟩_
  data Path {c : Color} (Koopa : KoopaTroopa c) :
       Position → Position → Set where
    []  : ∀ {p} → Path Koopa p p
    _↠⟨_⟩_ : {q r : Position} → (p : Position) → q follows p ⟨ c ⟩
                → (qs : Path Koopa q r) → Path Koopa p r

  ex_path : Path (Red KT) (pos 0 0 gas Low) (pos 0 0 gas Low)
  ex_path = pos 0 0 gas Low ↠⟨ next ⟩
            pos 1 0 gas Low ↠⟨ back ⟩
            pos 0 0 gas Low ↠⟨ stay ⟩ []

  matToPosVec : {n : ℕ} → Vec Material n → Vec Material n → ℕ → ℕ →
                   Vec Position n
  matToPosVec []           []        _ _ = []
  matToPosVec (mat ∷ mats) (under ∷ unders) x y =
    pos x y mat cl ∷ matToPosVec mats unders (x + 1) y
      where
        clearance : Material → Material → Clearance
        clearance gas   gas   = High
        clearance gas   solid = Low
        clearance solid _     = God
        cl = clearance mat under

  matToPosVecs : {w h : ℕ} → Vec (Vec Material w) h → Vec (Vec Position w) h
  matToPosVecs [] = []
  matToPosVecs (_∷_ {y} mats matss) =
    matToPosVec mats (unders matss gas) 0 y ∷ matToPosVecs matss
    where
      unders : ∀ {m n ℓ}{A : Set ℓ} → Vec (Vec A m) n → A → Vec A m
      unders [] fallback = vreplicate fallback
      unders (us ∷ _) _ = us

  matsToMat : {w h : ℕ} → Vec (Vec Material w) h → Matrix Position w h
  matsToMat matss = Mat (reverse (matToPosVecs matss))

  □ : Material
  □ = gas
  ■ : Material
  ■ = solid
  example_level : Matrix Position 10 7
  example_level = matsToMat (
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ []) ∷
    (■ ∷ ■ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ []) ∷ [])

  _<'_ : ℕ → ℕ → Set
  m <' zero = ⊥
  zero <' suc n = ⊤
  suc m <' suc n = m <' n

  fromNat : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  fromNat {zero} k {}
  fromNat {suc n} zero = fzero
  fromNat {suc n} (suc k) {p} = fsuc (fromNat k {p})

  f : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  f = fromNat

  p : (x : Fin 10) → (y : Fin 7) → Position
  p x y = lookup y x example_level

  red_path_one : Path (Red KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  red_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                 p (f 6) (f 6) ↠⟨ next ⟩
                 p (f 7) (f 6) ↠⟨ next ⟩
                 p (f 8) (f 6) ↠⟨ stay ⟩ []

  red_path_two : Path (Red KT) (p (f 2) (f 1)) (p (f 3) (f 1))
  red_path_two = p (f 2) (f 1) ↠⟨ back ⟩
                 p (f 1) (f 1) ↠⟨ next ⟩
                 p (f 2) (f 1) ↠⟨ next ⟩
                 p (f 3) (f 1) ↠⟨ next ⟩
                 p (f 4) (f 1) ↠⟨ back ⟩
                 p (f 3) (f 1) ↠⟨ stay ⟩
                 []

  -- -- Type error shows up 'late' because 'cons' is right associative
  -- red_nopath_one : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩
  --                  p (f 0) (f 1) ↠⟨ stay ⟩
  --                  []

  -- -- Red KoopaTroopa can't step into a wall
  -- red_nopath_two : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_two = p (f 1) (f 1) ↠⟨ back ⟩ []

  -- -- Red KoopaTroopa can't step into air
  -- red_nopath_three : Path (Red KT) (p (f 4) (f 1)) (p (f 5) (f 1))
  -- red_nopath_three = p (f 4) (f 1) ↠⟨ next ⟩ []

  -- Any path that is valid for red KoopaTroopas, is also valid for green
  -- KoopaTroopas because we did not constrain KoopaTroopas to only turn
  -- When there is an obstacle
  green_path_one : Path (Green KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  green_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ next ⟩
                   p (f 7) (f 6) ↠⟨ next ⟩
                   p (f 8) (f 6) ↠⟨ stay ⟩ []

  green_path_two : Path (Green KT) (p (f 7) (f 6)) (p (f 5) (f 0))
  green_path_two = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ back ⟩
                   p (f 5) (f 6) ↠⟨ fall ⟩
                   p (f 5) (f 5) ↠⟨ fall ⟩
                   p (f 5) (f 4) ↠⟨ back ⟩
                   p (f 4) (f 4) ↠⟨ back ⟩
                   p (f 3) (f 4) ↠⟨ back ⟩
                   p (f 2) (f 4) ↠⟨ fall ⟩
                   p (f 2) (f 3) ↠⟨ fall ⟩
                   p (f 2) (f 2) ↠⟨ fall ⟩
                   p (f 2) (f 1) ↠⟨ back ⟩
                   p (f 1) (f 1) ↠⟨ next ⟩
                   p (f 2) (f 1) ↠⟨ next ⟩
                   p (f 3) (f 1) ↠⟨ next ⟩
                   p (f 4) (f 1) ↠⟨ next ⟩
                   p (f 5) (f 1) ↠⟨ fall ⟩
                   []

  -- -- Green KoopaTroopa can't step into a wall
  -- green_nopath_one : Path (Green KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- green_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩ []

{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin renaming (_+_ to _F+_; _<_ to _F<_; suc to fsuc;
    zero to fzero)
  open import Data.Vec renaming (map to vmap; lookup to vlookup;
                                     replicate to vreplicate)
  open import Data.Unit
  open import Data.Empty

  module Matrix where
    data Matrix (A : Set) : ℕ → ℕ → Set where
      Mat : {w h : ℕ} → Vec (Vec A w) h → Matrix A w h

    lookup : ∀ {w h} {A : Set} → Fin h → Fin w → Matrix A w h → A
    lookup row column (Mat rows) = vlookup column (vlookup row rows)
  open Matrix

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa : Color → Set where
    _KT : (c : Color) → KoopaTroopa c

  data Material : Set where
    gas    : Material
    -- liquid : Material
    solid  : Material

  data Clearance : Set where
    Low  : Clearance
    High : Clearance
    God  : Clearance

  record Position : Set where
    constructor pos
    field
      x   : ℕ
      y   : ℕ
      mat : Material
      clr : Clearance

  data _c>_ : Color → Clearance → Set where
    <red>   : ∀ {c} → c c> Low
    <green> : Green c> High

  data _follows_⟨_⟩ : Position → Position → Color → Set where
    stay  : ∀ {c x y} → pos x y gas Low follows pos x y gas Low ⟨ c ⟩
    next  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos (suc x) y gas cl follows pos x y gas Low ⟨ c ⟩
    back  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos x y gas cl follows pos (suc x) y gas Low ⟨ c ⟩
    -- jump  : ∀ {c x y} → pos x (suc y) gas High follows pos x y gas Low ⟨ c ⟩
    fall  : ∀ {c cl x y} → pos x y gas cl follows pos x (suc y) gas High ⟨ c ⟩

  infixr 5 _↠⟨_⟩_
  data Path {c : Color} (Koopa : KoopaTroopa c) :
       Position → Position → Set where
    []  : ∀ {p} → Path Koopa p p
    _↠⟨_⟩_ : {q r : Position} → (p : Position) → q follows p ⟨ c ⟩
                → (qs : Path Koopa q r) → Path Koopa p r

  ex_path : Path (Red KT) (pos 0 0 gas Low) (pos 0 0 gas Low)
  ex_path = pos 0 0 gas Low ↠⟨ next ⟩
            pos 1 0 gas Low ↠⟨ back ⟩
            pos 0 0 gas Low ↠⟨ stay ⟩ []

  matToPosVec : {n : ℕ} → Vec Material n → Vec Material n → ℕ → ℕ →
                   Vec Position n
  matToPosVec []           []        _ _ = []
  matToPosVec (mat ∷ mats) (under ∷ unders) x y =
    pos x y mat cl ∷ matToPosVec mats unders (x + 1) y
      where
        clearance : Material → Material → Clearance
        clearance gas   gas   = High
        clearance gas   solid = Low
        clearance solid _     = God
        cl = clearance mat under

  matToPosVecs : {w h : ℕ} → Vec (Vec Material w) h → Vec (Vec Position w) h
  matToPosVecs [] = []
  matToPosVecs (_∷_ {y} mats matss) =
    matToPosVec mats (unders matss gas) 0 y ∷ matToPosVecs matss
    where
      unders : ∀ {m n ℓ}{A : Set ℓ} → Vec (Vec A m) n → A → Vec A m
      unders [] fallback = vreplicate fallback
      unders (us ∷ _) _ = us

  matsToMat : {w h : ℕ} → Vec (Vec Material w) h → Matrix Position w h
  matsToMat matss = Mat (reverse (matToPosVecs matss))

  □ : Material
  □ = gas
  ■ : Material
  ■ = solid
  example_level : Matrix Position 10 7
  example_level = matsToMat (
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ []) ∷
    (■ ∷ ■ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ []) ∷ [])

  _<'_ : ℕ → ℕ → Set
  m <' zero = ⊥
  zero <' suc n = ⊤
  suc m <' suc n = m <' n

  fromNat : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  fromNat {zero} k {}
  fromNat {suc n} zero = fzero
  fromNat {suc n} (suc k) {p} = fsuc (fromNat k {p})

  f : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  f = fromNat

  p : (x : Fin 10) → (y : Fin 7) → Position
  p x y = lookup y x example_level

  red_path_one : Path (Red KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  red_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                 p (f 6) (f 6) ↠⟨ next ⟩
                 p (f 7) (f 6) ↠⟨ next ⟩
                 p (f 8) (f 6) ↠⟨ stay ⟩ []

  red_path_two : Path (Red KT) (p (f 2) (f 1)) (p (f 3) (f 1))
  red_path_two = p (f 2) (f 1) ↠⟨ back ⟩
                 p (f 1) (f 1) ↠⟨ next ⟩
                 p (f 2) (f 1) ↠⟨ next ⟩
                 p (f 3) (f 1) ↠⟨ next ⟩
                 p (f 4) (f 1) ↠⟨ back ⟩
                 p (f 3) (f 1) ↠⟨ stay ⟩
                 []

  red_nopath_one : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  red_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩
                   p (f 0) (f 1) ↠⟨ stay ⟩
                   []

  red_nopath_two : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  red_nopath_two = p (f 1) (f 1) ↠⟨ back ⟩ []


Logical: +⟦★⟧₀, +⟦→⟧⇔Preserves, +⟦→⟧²⇔Preserves₂

{-# OPTIONS --universe-polymorphism #-}
module Relation.Binary.Logical where

open import Type hiding (★)
open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Data.Unit
open import Data.Empty
open import Relation.Nullary
open import Relation.Unary.NP hiding (Decidable)
open import Relation.Binary

⟦★⟧ : ∀ {a₁ a₂} aᵣ (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦★⟧ aᵣ A₁ A₂ = A₁ → A₂ → ★ aᵣ

⟦★⟧₀ : ∀ {a₁ a₂} (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦★⟧₀ = ⟦★⟧ zero

⟦★₀⟧ : ∀ (A₁ A₂ : ★₀) → ★₁
⟦★₀⟧ = ⟦★⟧₀

⟦★₁⟧ : ∀ (A₁ A₂ : ★₁) → ★₂
⟦★₁⟧ = ⟦★⟧ (suc zero)

-- old name
⟦Set⟧ : ∀ {a₁ a₂} aᵣ (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦Set⟧ aᵣ A₁ A₂ = A₁ → A₂ → ★ aᵣ

-- old name
⟦Set₀⟧ : ∀ (A₁ A₂ : Set) → Set₁
⟦Set₀⟧ = ⟦★₀⟧

-- old name
⟦Set₁⟧ : ∀ (A₁ A₂ : Set₁) → Set₂
⟦Set₁⟧ = ⟦★₁⟧

⟦Π⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

infixr 0 ⟦Π⟧
syntax ⟦Π⟧ Aᵣ (λ xᵣ → f) = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

⟦Π⟧e : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧e Aᵣ Bᵣ = λ f₁ f₂ → ∀ x₁ x₂ (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

⟦∀⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : {x : A₁} → B₁ x) (f₂ : {x : A₂} → B₂ x) → ★ _
⟦∀⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ {x₁}) (f₂ {x₂})

infixr 0 ⟦∀⟧
syntax ⟦∀⟧ Aᵣ (λ xᵣ → f) = ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

infixr 1 _⟦→⟧_
_⟦→⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
Aᵣ ⟦→⟧ Bᵣ = ⟦Π⟧ Aᵣ (λ _ → Bᵣ)

infixr 0 _⟦→⟧e_
_⟦→⟧e_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
_⟦→⟧e_ Aᵣ Bᵣ = ⟦Π⟧e Aᵣ (λ _ → Bᵣ)

record ⟦⊤⟧ (x₁ x₂ : ⊤) : ★₀ where
  constructor ⟦tt⟧

data ⟦⊥⟧ (x₁ x₂ : ⊥) : ★₀ where

infix 3 ⟦¬⟧_

⟦¬⟧_ : ∀ {a₁ a₂ aₚ} → (⟦★⟧ {a₁} {a₂} aₚ ⟦→⟧ ⟦★⟧ _) ¬_ ¬_
⟦¬⟧ Aᵣ = Aᵣ ⟦→⟧ ⟦⊥⟧

-- Products ⟦Σ⟧, ⟦∃⟧, ⟦×⟧ are in Data.Product.NP

⟦Pred⟧ : ∀ {p₁ p₂} pᵣ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ _) (Pred p₁) (Pred p₂)
⟦Pred⟧ pᵣ Aᵣ = Aᵣ ⟦→⟧ ⟦★⟧ pᵣ

private
  REL′ : ∀ ℓ {a b} → ★ a → ★ b → ★ (a ⊔ b ⊔ suc ℓ)
  REL′ ℓ A B = A → B → ★ ℓ

  ⟦REL⟧′ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ r₁ r₂} rᵣ →
          (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ {b₁} {b₂} bᵣ ⟦→⟧ ⟦★⟧ _) (REL′ r₁) (REL′ r₂)
  ⟦REL⟧′ rᵣ Aᵣ Bᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦REL⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          {r₁ r₂} rᵣ (∼₁ : REL A₁ B₁ r₁) (∼₂ : REL A₂ B₂ r₂) → ★ _
⟦REL⟧ Aᵣ Bᵣ rᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦Rel⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {r₁ r₂} ℓᵣ (∼₁ : Rel A₁ r₁) (∼₂ : Rel A₂ r₂) → ★ _
⟦Rel⟧ Aᵣ rᵣ = ⟦REL⟧ Aᵣ Aᵣ rᵣ

data ⟦Dec⟧ {ℓ₁ ℓ₂ ℓᵣ} {P₁ : ★ ℓ₁} {P₂ : ★ ℓ₂} (Pᵣ : P₁ → P₂ → ★ ℓᵣ) : ⟦★⟧ (ℓ₁ ⊔ ℓ₂ ⊔ ℓᵣ) (Dec P₁) (Dec P₂) where
  yes : {p₁ : P₁} {p₂ : P₂} (pᵣ : Pᵣ p₁ p₂) → ⟦Dec⟧ Pᵣ (yes p₁) (yes p₂)
  no  : {¬p₁ : ¬ P₁} {¬p₂ : ¬ P₂} (¬pᵣ : (⟦¬⟧ Pᵣ) ¬p₁ ¬p₂) → ⟦Dec⟧ Pᵣ (no ¬p₁) (no ¬p₂)

private
  ⟦Dec⟧' : ∀ {p₁} {p₂} {pᵣ} → ⟦Pred⟧ {p₁} {p₂} _ (⟦★⟧ pᵣ) Dec Dec
  ⟦Dec⟧' = ⟦Dec⟧

⟦Decidable⟧ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ ℓ₁ ℓ₂ ℓᵣ}
              → (∀⟨ Aᵣ ∶ ⟦★⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧
                 ∀⟨ Bᵣ ∶ ⟦★⟧ {b₁} {b₂} bᵣ ⟩⟦→⟧
                   ⟦REL⟧ Aᵣ Bᵣ {ℓ₁} {ℓ₂} ℓᵣ ⟦→⟧ ⟦★⟧ _) Decidable Decidable
⟦Decidable⟧ Aᵣ Bᵣ _∼ᵣ_ = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟨ yᵣ ∶ Bᵣ ⟩⟦→⟧ ⟦Dec⟧ (xᵣ ∼ᵣ yᵣ)

⟦Op₁⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ a) Op₁ Op₁
⟦Op₁⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

⟦Op₂⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ a) Op₂ Op₂
⟦Op₂⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ

open import Function.Equivalence
private
  ⟦→⟧⇔Preserves :
    ∀ {a b aᵣ bᵣ}
      {A : ★ a} {B : ★ b}
      {Aᵣ : ⟦★⟧ aᵣ A A}
      {Bᵣ : ⟦★⟧ bᵣ B B}
      {f}
    → (Aᵣ ⟦→⟧ Bᵣ) f f ⇔ f Preserves Aᵣ ⟶ Bᵣ

  ⟦→⟧⇔Preserves = equivalence (λ x → x) (λ x → x)

  ⟦→⟧²⇔Preserves₂ :
    ∀ {a b c aᵣ bᵣ cᵣ}
      {A : ★ a} {B : ★ b} {C : ★ c}
      {Aᵣ : ⟦★⟧ aᵣ A A}
      {Bᵣ : ⟦★⟧ bᵣ B B}
      {Cᵣ : ⟦★⟧ cᵣ C C}
      {f}
    → (Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ Cᵣ) f f ⇔ f Preserves₂ Aᵣ ⟶ Bᵣ ⟶ Cᵣ

  ⟦→⟧²⇔Preserves₂ = equivalence (λ f {x} {y}   {_} {_} z → f {x} {y} z)
                                (λ f {x} {y} z {_} {_}   → f z)

{-# OPTIONS --universe-polymorphism #-}
module Relation.Binary.Logical where

open import Type hiding (★)
open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Data.Unit
open import Data.Empty
open import Relation.Nullary
open import Relation.Unary.NP hiding (Decidable)
open import Relation.Binary

⟦★⟧ : ∀ {a₁ a₂} aᵣ (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦★⟧ aᵣ A₁ A₂ = A₁ → A₂ → ★ aᵣ

⟦★₀⟧ : ∀ (A₁ A₂ : ★₀) → ★₁
⟦★₀⟧ = ⟦★⟧ zero

⟦★₁⟧ : ∀ (A₁ A₂ : ★₁) → ★₂
⟦★₁⟧ = ⟦★⟧ (suc zero)

-- old name
⟦Set⟧ : ∀ {a₁ a₂} aᵣ (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦Set⟧ aᵣ A₁ A₂ = A₁ → A₂ → ★ aᵣ

-- old name
⟦Set₀⟧ : ∀ (A₁ A₂ : Set) → Set₁
⟦Set₀⟧ = ⟦★₀⟧

-- old name
⟦Set₁⟧ : ∀ (A₁ A₂ : Set₁) → Set₂
⟦Set₁⟧ = ⟦★₁⟧

⟦Π⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

infixr 0 ⟦Π⟧
syntax ⟦Π⟧ Aᵣ (λ xᵣ → f) = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

⟦Π⟧e : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧e Aᵣ Bᵣ = λ f₁ f₂ → ∀ x₁ x₂ (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

⟦∀⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : {x : A₁} → B₁ x) (f₂ : {x : A₂} → B₂ x) → ★ _
⟦∀⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ {x₁}) (f₂ {x₂})

infixr 0 ⟦∀⟧
syntax ⟦∀⟧ Aᵣ (λ xᵣ → f) = ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

infixr 1 _⟦→⟧_
_⟦→⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
Aᵣ ⟦→⟧ Bᵣ = ⟦Π⟧ Aᵣ (λ _ → Bᵣ)

infixr 0 _⟦→⟧e_
_⟦→⟧e_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
_⟦→⟧e_ Aᵣ Bᵣ = ⟦Π⟧e Aᵣ (λ _ → Bᵣ)

record ⟦⊤⟧ (x₁ x₂ : ⊤) : ★₀ where
  constructor ⟦tt⟧

data ⟦⊥⟧ (x₁ x₂ : ⊥) : ★₀ where

infix 3 ⟦¬⟧_

⟦¬⟧_ : ∀ {a₁ a₂ aₚ} → (⟦★⟧ {a₁} {a₂} aₚ ⟦→⟧ ⟦★⟧ _) ¬_ ¬_
⟦¬⟧ Aᵣ = Aᵣ ⟦→⟧ ⟦⊥⟧

-- Products ⟦Σ⟧, ⟦∃⟧, ⟦×⟧ are in Data.Product.NP

⟦Pred⟧ : ∀ {p₁ p₂} pᵣ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ _) (Pred p₁) (Pred p₂)
⟦Pred⟧ pᵣ Aᵣ = Aᵣ ⟦→⟧ ⟦★⟧ pᵣ

private
  REL′ : ∀ ℓ {a b} → ★ a → ★ b → ★ (a ⊔ b ⊔ suc ℓ)
  REL′ ℓ A B = A → B → ★ ℓ

  ⟦REL⟧′ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ r₁ r₂} rᵣ →
          (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ {b₁} {b₂} bᵣ ⟦→⟧ ⟦★⟧ _) (REL′ r₁) (REL′ r₂)
  ⟦REL⟧′ rᵣ Aᵣ Bᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦REL⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          {r₁ r₂} rᵣ (∼₁ : REL A₁ B₁ r₁) (∼₂ : REL A₂ B₂ r₂) → ★ _
⟦REL⟧ Aᵣ Bᵣ rᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦Rel⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {r₁ r₂} ℓᵣ (∼₁ : Rel A₁ r₁) (∼₂ : Rel A₂ r₂) → ★ _
⟦Rel⟧ Aᵣ rᵣ = ⟦REL⟧ Aᵣ Aᵣ rᵣ

data ⟦Dec⟧ {ℓ₁ ℓ₂ ℓᵣ} {P₁ : ★ ℓ₁} {P₂ : ★ ℓ₂} (Pᵣ : P₁ → P₂ → ★ ℓᵣ) : ⟦★⟧ (ℓ₁ ⊔ ℓ₂ ⊔ ℓᵣ) (Dec P₁) (Dec P₂) where
  yes : {p₁ : P₁} {p₂ : P₂} (pᵣ : Pᵣ p₁ p₂) → ⟦Dec⟧ Pᵣ (yes p₁) (yes p₂)
  no  : {¬p₁ : ¬ P₁} {¬p₂ : ¬ P₂} (¬pᵣ : (⟦¬⟧ Pᵣ) ¬p₁ ¬p₂) → ⟦Dec⟧ Pᵣ (no ¬p₁) (no ¬p₂)

private
  ⟦Dec⟧' : ∀ {p₁} {p₂} {pᵣ} → ⟦Pred⟧ {p₁} {p₂} _ (⟦★⟧ pᵣ) Dec Dec
  ⟦Dec⟧' = ⟦Dec⟧

⟦Decidable⟧ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ ℓ₁ ℓ₂ ℓᵣ}
              → (∀⟨ Aᵣ ∶ ⟦★⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧
                 ∀⟨ Bᵣ ∶ ⟦★⟧ {b₁} {b₂} bᵣ ⟩⟦→⟧
                   ⟦REL⟧ Aᵣ Bᵣ {ℓ₁} {ℓ₂} ℓᵣ ⟦→⟧ ⟦★⟧ _) Decidable Decidable
⟦Decidable⟧ Aᵣ Bᵣ _∼ᵣ_ = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟨ yᵣ ∶ Bᵣ ⟩⟦→⟧ ⟦Dec⟧ (xᵣ ∼ᵣ yᵣ)

⟦Op₁⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ a) Op₁ Op₁
⟦Op₁⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

⟦Op₂⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ a) Op₂ Op₂
⟦Op₂⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ


Nand.Properties: renaming

Nand.Properties: renaming

open import Level.NP
open import Type
open import Data.Two
open import Data.Product
open import Function.NP
open import Relation.Binary
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality

open import Explore.Type
import Explore.Explorable
open import Explore.Universe

open import FunUniverse.Nand
open import FunUniverse.Agda

module FunUniverse.Nand.Properties where

module Test {B : ★} (_≟_ : Decidable {A = B} _≡_)
            (A : Ty)
            {f g : El A → B} where
  module _ {ℓ} where
    Aᵉ : Explore ℓ (El A)
    Aᵉ = exploreU A
    Aⁱ : ExploreInd ℓ Aᵉ
    Aⁱ = exploreU-ind A
  Aˡ : Lookup {₀} Aᵉ
  Aˡ = lookupU A

  Check! = Aᵉ _×_ λ x → ✓ ⌊ f x ≟ g x ⌋

  check! : {p✓ : Check!} → f ≗ g
  check! {p✓} x = toWitness (Aˡ p✓ x)

  {- Unused
  open Explore.Explorable.Explorable₀ Aⁱ
  test-∧ = big-∧ λ x → ⌊ f x ≟ g x ⌋
  -}

module Test22 where
  nand nand' : 𝟚 × 𝟚 → 𝟚

  nand  (x , y) = not (x ∧ y)
  nand' (x , y) = not x ∨ not y

  module N = FromNand funRewiring nand
  module T = Test Data.Two._≟_

  module UnOp where
    open T 𝟚′

    not-ok : N.not ≗ not
    not-ok = check!

  module BinOp where
    open T (𝟚′ ×′ 𝟚′)

    nand-ok : nand ≗ nand'
    nand-ok = check!

    and-ok : N.and ≗ uncurry _∧_
    and-ok = check!

    or-ok : N.or ≗ uncurry _∨_
    or-ok = check!

    nor-ok : N.nor ≗ (not ∘ uncurry _∨_)
    nor-ok = check!

    xor-ok : N.xor ≗ uncurry _xor_
    xor-ok = check!

    xnor-ok : N.xnor ≗ uncurry _==_
    xnor-ok = check!

  module TriOp where
    open T (𝟚′ ×′ (𝟚′ ×′ 𝟚′))

    fork : 𝟚 × 𝟚 × 𝟚 → 𝟚
    fork (c , eᵢ) = proj eᵢ c

    fork-ok : N.fork ≗ fork
    fork-ok = check!

open import Level.NP
open import Type
open import Data.Two
open import Data.Product
open import Function.NP
open import Relation.Binary
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality

open import Explore.Type
import Explore.Explorable
open import Explore.Universe

open import FunUniverse.Nand
open import FunUniverse.Agda

module FunUniverse.Nand.Properties where

module Test {B : ★} (_≟_ : Decidable {A = B} _≡_)
            (A : Ty)
            {f g : El A → B} where
  module _ {ℓ} where
    Aᵉ : Explore ℓ (El A)
    Aᵉ = exploreU A
    Aⁱ : ExploreInd ℓ Aᵉ
    Aⁱ = exploreU-ind A
  Aˡ : Lookup {₀} Aᵉ
  Aˡ = lookupU A

  Check! = Aᵉ _×_ λ x → ✓ ⌊ f x ≟ g x ⌋

  check! : {p✓ : Check!} → f ≗ g
  check! {p✓} x = toWitness (Aˡ p✓ x)

  {- Unused
  open Explore.Explorable.Explorable₀ Aⁱ
  test-∧ = big-∧ λ x → ⌊ f x ≟ g x ⌋
  -}

module Test22 where
  nand nand' : 𝟚 × 𝟚 → 𝟚

  nand  (x , y) = not (x ∧ y)
  nand' (x , y) = not x ∨ not y

  module N = FromNand funRewiring nand
  module T = Test Data.Two._≟_

  module UnOp where
    open T 𝟚′

    pf-not : N.not ≗ not
    pf-not = check!

  module BinOp where
    open T (𝟚′ ×′ 𝟚′)

    pf-nand : nand ≗ nand'
    pf-nand = check!

    pf-and : N.and ≗ uncurry _∧_
    pf-and = check!

    pf-or : N.or ≗ uncurry _∨_
    pf-or = check!

    pf-nor : N.nor ≗ (not ∘ uncurry _∨_)
    pf-nor = check!

    pf-xor : N.xor ≗ uncurry _xor_
    pf-xor = check!

    pf-xnor : N.xnor ≗ uncurry _==_
    pf-xnor = check!

  module TriOp where
    open T (𝟚′ ×′ (𝟚′ ×′ 𝟚′))

    fork : 𝟚 × 𝟚 × 𝟚 → 𝟚
    fork (c , eᵢ) = proj eᵢ c

    pf-fork : N.fork ≗ fork
    pf-fork = check!


Added a proof using an instance of an induction principle.

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.AddTotality where

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

------------------------------------------------------------------------------
-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind A A0 is Nm
  where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (nsucc ih)

-- Combined proof using an instance of the induction principle.
+-N-ind : ∀ {n} →
          N (zero + n) →
          (∀ {m} → N (m + n) → N (succ₁ m + n)) →
          ∀ {m} → N m → N (m + n)
+-N-ind {n} = N-ind (λ i → N (i + n))

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ {n = n} Nm Nn = +-N-ind prf₁ prf₂ Nm
  where
  prf₁ : N (zero + n)
  prf₁ = subst N (sym (+-0x n)) Nn

  prf₂ : ∀ {m} → N (m + n) → N (succ₁ m + n)
  prf₂ {m} ih = subst N (sym (+-Sx m n)) (nsucc ih)

postulate +-N₂ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₂ +-N-ind #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate +-N₃ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
-- {-# ATP prove +-N₃ N-ind #-}

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.AddTotality where

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

------------------------------------------------------------------------------
-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind A A0 is Nm
  where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (nsucc ih)

-- Combined proof using an instance of the induction principle.
+-N-ind : ∀ n →
          N (zero + n) →
          (∀ {m} → N (m + n) → N (succ₁ m + n)) →
          ∀ {m} → N m → N (m + n)
+-N-ind n = N-ind (λ i → N (i + n))

postulate +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ +-N-ind #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
-- {-# ATP prove +-N₂ N-ind #-}


Drop unused redundant case

Drop unused redundant case

module Thesis.SIRelBigStep.DSyntax where

open import Thesis.SIRelBigStep.Syntax public

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context
module DC = Base.Syntax.Context DType

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ (pair τ1 τ2) = pair (Δτ τ1) (Δτ τ2)
Δτ nat = nat

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δτ τ • ΔΔ Γ
--ΔΔ Γ = Γ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var Δ τ) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)
  dcons : ∀ {τ1 τ2}
    (dsv1 : DSVal Δ τ1)
    (dsv2 : DSVal Δ τ2) →
    DSVal Δ (pair τ1 τ2)
  dconst : ∀ {τ} → (dc : Const (Δτ τ)) → DSVal Δ τ

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  dprimapp : ∀ {σ}
    (p : Primitive (σ ⇒ τ)) →
    (sv : SVal Δ σ) →
    (dsv : DSVal Δ σ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ

module Thesis.SIRelBigStep.DSyntax where

open import Thesis.SIRelBigStep.Syntax public

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context
module DC = Base.Syntax.Context DType

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ (pair τ1 τ2) = pair (Δτ τ1) (Δτ τ2)
Δτ nat = nat

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δτ τ • ΔΔ Γ
--ΔΔ Γ = Γ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var Δ τ) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)
  dcons : ∀ {τ1 τ2}
    (dsv1 : DSVal Δ τ1)
    (dsv2 : DSVal Δ τ2) →
    DSVal Δ (pair τ1 τ2)
  dconst : ∀ {τ} → (dc : Const (Δτ τ)) → DSVal Δ τ

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  dprimapp : ∀ {σ}
    (p : Primitive (σ ⇒ τ)) →
    (sv : SVal Δ σ) →
    (dsv : DSVal Δ σ) →
    DTerm Δ τ
  dconst :
    (c : Const τ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ