changeset 315:0d7fa6fc5979

System T and System F
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Sat, 15 Mar 2014 10:15:54 +0900
parents d1af69c4aaf8
children 7a3229b32b3c
files freyd.agda record-ex.agda system-f.agda system-t.agda
diffstat 4 files changed, 219 insertions(+), 1 deletions(-) [+]
line wrap: on
line diff
--- a/freyd.agda	Mon Jan 06 17:18:13 2014 +0900
+++ b/freyd.agda	Sat Mar 15 10:15:54 2014 +0900
@@ -36,7 +36,7 @@
       uniqueness  : ( a : Obj A ) →  ( f : Hom A i a ) → A [ f ≈  initial a ]
 
 
--- A has initial object if it has PreInitial-SmallFullSubcategory
+-- A complete catagory has initial object if it has PreInitial-SmallFullSubcategory
 
 open NTrans
 open Limit
--- a/record-ex.agda	Mon Jan 06 17:18:13 2014 +0900
+++ b/record-ex.agda	Sat Mar 15 10:15:54 2014 +0900
@@ -35,6 +35,12 @@
 ya : A
 ya = and1 z
 
+lemma1 : A ∧ B → A
+lemma1 a =  and1 a
+
+lemma2 : A → B → A ∧ B 
+lemma2 a b =  record { and1 = a ; and2 = b }
+
 open  import  Relation.Binary.PropositionalEquality
 
 data Nat : Set where
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/system-f.agda	Sat Mar 15 10:15:54 2014 +0900
@@ -0,0 +1,66 @@
+open import Level
+open import Relation.Binary.PropositionalEquality
+
+module system-f {l : Level} where
+
+postulate A : Set
+postulate B : Set
+
+data _∨_  (A B : Set) : Set where
+  or1 : A -> A ∨ B
+  or2 : B -> A ∨ B
+
+lemma01 : A -> A ∨ B
+lemma01 a = or1 a
+
+lemma02 : B -> A ∨ B
+lemma02 b = or2 b
+
+lemma03 : {C : Set} -> (A ∨ B) -> (A -> C) -> (B -> C) -> C
+lemma03 (or1 a) ac bc = ac a
+lemma03 (or2 b) ac bc = bc b
+
+postulate U : Set l
+postulate V : Set l
+
+
+Bool = {X : Set l} -> X -> X -> X
+
+T : Bool
+T = \{X : Set l} -> \(x y : X) -> x
+
+F : Bool
+F = \{X : Set l} -> \(x y : X) -> y
+
+D : {U : Set l} -> U -> U -> Bool -> U
+D {U} u v t = t {U} u v
+
+lemma04 : {u v : U} -> D u v T ≡  u
+lemma04 = refl
+
+lemma05 : {u v : U} -> D u v F ≡  v
+lemma05 = refl
+
+_×_ : Set l -> Set l ->  Set (suc l)
+U × V =  {X : Set l} -> (U -> V -> X)  -> X 
+
+<_,_> : {U V : Set l} -> U -> V -> (U ×  V) 
+<_,_> {U} {V} u v = \{X} -> \(x : U -> V -> X) -> x u v
+
+π1 : {U V : Set l} -> (U ×  V) -> U
+π1 {U} {V}  t = t {U} (\(x : U) -> \(y : V) -> x)
+
+π2 : {U V : Set l} -> (U ×  V) -> V
+π2 {U} {V}  t = t {V} (\(x : U) -> \(y : V) -> y)
+
+lemma06 : {U V : Set l } -> {u : U } -> {v : V} -> π1 ( < u , v > ) ≡  u
+lemma06 = refl
+
+lemma07 : {U V : Set l } -> {u : U } -> {v : V} -> π2 ( < u , v > ) ≡  v
+lemma07 = refl
+
+hoge : {U V : Set l} -> U -> V  -> (U ×  V)
+hoge u v = < u , v >
+
+-- lemma08 :  (t : U ×  V)  -> < π1 t  , π2 t > ≡ t
+-- lemma08 t = {!!}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/system-t.agda	Sat Mar 15 10:15:54 2014 +0900
@@ -0,0 +1,146 @@
+module system-t where
+open  import  Relation.Binary.PropositionalEquality
+
+record _×_ ( U : Set ) ( V : Set )   :  Set where
+    field
+       π1 : U
+       π2 : V
+
+<_,_> : {U V : Set} -> U -> V -> U × V
+< u , v >  = record {π1 = u ; π2 = v }
+
+open _×_
+
+postulate U : Set
+postulate V : Set
+
+postulate v : V
+postulate u : U
+
+f : U -> V
+f = \u -> v
+
+
+UV : Set
+UV = U × V
+
+uv : U × V
+uv  = < u , v >
+
+lemma01 : π1  < u , v >   ≡ u
+lemma01 = refl
+
+lemma02 : π2  < u , v >   ≡ v
+lemma02 = refl
+
+lemma03 : (uv : U × V ) → < π1  uv , π2 uv >   ≡ uv
+lemma03 uv = refl
+
+lemma04 : (λ x →  f x ) u ≡  f u
+lemma04 = refl
+
+lemma05 : (λ  x → f x ) ≡  f
+lemma05 = refl
+
+nn = λ (x : U ) →  u
+n1 = λ ( x : U ) →  f x
+
+data Bool : Set where
+  T : Bool 
+  F : Bool
+
+D : { U : Set } -> U -> U -> Bool -> U 
+D u v T = u 
+D u v F = v
+
+data Int : Set where 
+    zero : Int
+    S : Int →  Int
+
+pred : Int -> Int
+pred zero = zero
+pred (S t) = t
+
+R : { U : Set } -> U -> ( U -> Int -> U ) -> Int -> U
+R u v zero = u 
+R u v ( S t ) = v (R u v t) t
+
+null : Int -> Bool
+null zero = T
+null (S _)  = F
+
+It : { T : Set } -> T -> (T -> T) -> Int -> T
+It u v zero = u
+It u v ( S t ) = v (It u v t )
+
+R' : { T : Set } -> T -> ( T -> Int -> T ) -> Int -> T
+R' u v t = π1 ( It ( < u , zero > ) (λ x →  < v (π1 x) (π2 x) , S (π2 x) > ) t )
+
+sum : Int -> Int -> Int
+sum x y = R y ( λ z -> λ w -> S z ) x
+
+mul : Int -> Int -> Int
+mul x y = R zero ( λ z -> λ w -> sum y z ) x 
+
+sum' : Int -> Int -> Int
+sum' x y = R' y ( λ z -> λ w -> S z ) x
+
+mul' : Int -> Int -> Int
+mul' x y = R' zero ( λ z -> λ w -> sum y z ) x
+
+fact : Int -> Int
+fact  n = R  (S zero) (λ z -> λ w -> mul (S w) z ) n
+
+fact' : Int -> Int
+fact' n = R' (S zero) (λ z -> λ w -> mul (S w) z ) n
+
+f3 = fact (S (S (S zero)))
+f3' = fact' (S (S (S zero)))
+
+lemma21 : f3 ≡ f3'
+lemma21 = refl
+
+lemma07 : { U : Set } -> ( u : U ) -> ( v : U -> Int -> U ) ->( t :  Int ) -> 
+        (π2 (It < u , zero > (λ x → < v (π1 x) (π2 x) , S (π2 x) >) t )) ≡  t
+lemma07 u v zero   =  refl
+lemma07 u v (S t)  =  cong ( \x -> S x ) ( lemma07 u v t )
+
+lemma06 : { U : Set } -> ( u : U ) -> ( v : U -> Int -> U ) ->( t :  Int ) -> ( (R u v t) ≡  (R' u v t ))
+lemma06 u v zero = refl 
+lemma06 u v (S t) =  trans  ( cong ( \x ->  v x t )  ( lemma06 u v t ) ) 
+                            ( cong ( \y ->  v (R' u v t) y ) (sym ( lemma07 u v t ) ) )
+
+lemma08 : ( n m : Int ) -> ( sum' n m ≡ sum n m )
+lemma08 zero _ = refl 
+lemma08 (S t) y =  cong ( \x -> S x ) ( lemma08 t y ) 
+
+lemma09 : ( n m : Int ) -> ( mul' n m ≡ mul n m )
+lemma09 zero _ = refl 
+lemma09 (S t) y =  cong ( \x -> sum y x) ( lemma09 t y ) 
+
+lemma10 : ( n : Int ) -> ( fact n  ≡ fact n )
+lemma10 zero = refl 
+lemma10 (S t) =  cong ( \x -> mul (S t) x ) ( lemma10 t ) 
+
+lemma11 : ( n : Int ) -> ( fact n  ≡ fact' n )
+lemma11 n = lemma06 (S zero) (λ z -> λ w -> mul (S w) z ) n
+
+lemma06' : { U : Set } -> ( u : U ) -> ( v : U -> Int -> U ) ->( t :  Int ) -> ( (R u v t) ≡  (R' u v t ))
+lemma06' u v zero = refl
+lemma06' u v (S t) = let open ≡-Reasoning in 
+   begin 
+       R u v (S t)
+   ≡⟨⟩
+       v (R u v t) t
+   ≡⟨ cong (\x -> v x t ) ( lemma06' u v t )  ⟩
+       v (R' u v t) t
+   ≡⟨ cong (\x -> v (R' u v t) x ) ( sym ( lemma07 u v t )) ⟩
+       v (R' u v t) (π2 (It < u , zero > (λ x → < v (π1 x) (π2 x) , S (π2 x) >) t))
+   ≡⟨⟩
+       R' u v (S t)
+   ∎
+
+
+
+
+