diff --git a/example.rkt b/example.rkt index ac73adc..38a9dad 100644 --- a/example.rkt +++ b/example.rkt @@ -5,6 +5,14 @@ ;; seems to with check-equal? (require rackunit) +;; ------------------- +;; Define inductive data + +(data true : Type (T : true)) + +(data false : Type) + +;; ------------------- ;; Look, syntax extension! (define-syntax (-> syn) (syntax-case syn () @@ -20,49 +28,51 @@ (lambda (y : (-> nat nat)) (lambda (x : nat) (y x)))) +;; ------------------- ;; Lexical scoping! I can reuse the name nat! + (define nat-is-just-a-name (lambda (nat : Type) nat)) -(data true : Type (T : true)) - -(data false : Type) - -;; Real meta-programming! Syntax is just data. -(define-syntax (inhabit-type syn) - (syntax-case syn (true false nat) - [(_ true) #'T] - [(_ nat) #'z] - [(_ false) - (raise-syntax-error 'inhabit - "Actually, this type is unhabited" syn)] - [(_ t) - (raise-syntax-error 'inhabit - "Sorry, this type is too much for me" syn)])) - -(define hmm (inhabit-type true)) -(check-equal? hmm T) - -#;(define is-this-inhabited (inhabit-type false)) - +;; ------------------- ;; Reuse some familiar syntax + (define y (lambda (x : true) x)) (define (y1 (x : true)) x) (define (y2 (x1 : true) (x2 : true)) x1) + +;; ------------------- +;; Unit test dependently typed code! + (check-equal? (y2 T T) T) +;; ------------------- ;; Write functions on inductive data -(define (plus (n1 : nat) (n2 : nat)) +;; TODO: This is not plus! Plus require recursion and I don't have +;; recursion! +;(define (plus (n1 : nat) (n2 : nat)) +; (case n1 +; [z n2] +; ;; TODO: Add macro to enable writing this line as: +; ;; [(s x) (s (s x))] +; [s (λ (x : nat) (s (s x)))])) +; +;(define four (plus (s (s z)) (s (s z)))) +;(check-equal? four (s (s (s z)))) + +(define (add1 (n1 : nat)) (case n1 - [z n2] + [z (s z)] ;; TODO: Add macro to enable writing this line as: ;; [(s x) (s (s x))] [s (λ (x : nat) (s (s x)))])) -(define four (plus (s (s z)) (s (s z)))) -(check-equal? four (s (s (s z)))) +(define two (add1 (s z))) +(check-equal? two (s (s z))) +;; ------------------- ;; It's annoying to have to write things explicitly curried -;; Macros to the rescue +;; Macros to the rescue! + (define-syntax forall* (syntax-rules (:) [(_ (a : t) (ar : tr) ... b) @@ -81,6 +91,7 @@ (conj : (forall* (A : Type) (B : Type) (x : A) (y : B) (and A B)))) +;; ------------------- ;; Prove interesting theorems! #| @@ -115,8 +126,101 @@ (ab : (and^ P Q)) (and^ P Q)))) T) + (define proof:and^-is-symmetric (lambda* (P : Type) (Q : Type) (ab : (and^ P Q)) (conj^ Q P (snd P Q ab) (fst P Q ab)))) (check-equal? T (thm:and^-is-symmetric proof:and^-is-symmetric)) + +;; ------------------- +;; Gee, I wish there was a special syntax for theorems and proofs so I could think of +;; them as seperate from types and programs. + +(define-syntax-rule (define-theorem name prop) + (define (name (x : prop)) T)) + +(define-syntax-rule (qed thm pf) + (check-equal? T (thm pf))) + +(define-theorem thm:and^-is-symmetric^ + (forall* (P : Type) (Q : Type) (ab : (and^ P Q)) (and^ P Q))) + +(qed thm:and^-is-symmetric^ proof:and^-is-symmetric) + +;; ------------------- +;; Gee, I wish I had special syntax for defining types like I do for +;; defining functions. + +(define-syntax-rule (define-type (name (a : t) ...) body) + (define name (forall* (a : t) ... body))) + +(define-type (not (A : Type)) (-> A false)) + +(define-type (and^^ (A : Type) (B : Type)) + (forall* (C : Type) (f : (forall* (a : A) (b : B) C)) C)) +#| +TODO: Can't seem to pattern match on a inductive with 0 constructors... +should result in a term of any type, I think. +(define-theorem thm:absurdidty + (forall (P : Type) (A : Type) (-> (and^ A (not A)) P))) + +(define (proof:absurdidty (P : Type) (A : Type) (a*nota : (and^ A (not A))) + ((snd A (not A) a*nota) (fst A (not A) a*nota)))) +|# + +;; ------------------- +;; Automate theorem proving! With real meta-programming, syntax is just data. + +(define-syntax (inhabit-type syn) + (syntax-case syn (true false nat forall :) + [(_ true) #'T] + [(_ nat) #'z] + [(_ false) + (raise-syntax-error 'inhabit + "Actually, this type is unhabited" syn)] + ;; TODO: We want all forall*s to be expanded by this point. Should + ;; look into Racket macro magic to expand syn before matching on it. + [(_ (forall (x : t0) t1)) + ;; TODO: Should carry around assumptions to enable inhabhit-type to use + ;; them + #'(lambda (x : t0) (inhabit-type t1))] + [(_ t) + (raise-syntax-error 'inhabit + "Sorry, this type is too much for me" syn)])) + +(define-theorem thm:true-is-proveable true) +(qed thm:true-is-proveable (inhabit-type true)) + +(define-theorem thm:anything-implies-true (forall (P : Type) true)) +(qed thm:true-is-proveable (inhabit-type (forall (P : Type) true))) + +#;(define is-this-inhabited? (inhabit-type false)) + + +;; ------------------- +;; Unit test your theorems before proving them! + +(define-syntax ->* + (syntax-rules () + [(->* a) a] + [(->* a a* ...) + (-> a (->* a* ...))])) + +;; TODO: Ought to have some syntactic sugar for doing this. +;; Or a different representation of theorems. +(define type-thm:true? + (forall* (A : Type) (B : Type) (P : Type) + ;; If A implies P and (and A B) then P + (->* (-> A P) (and^ A B) P))) + +(define-theorem thm:true? type-thm:true?) + +(qed (lambda (x : (type-thm:true? true true true)) T) + ;; TODO: inhabit-type ought to be able to reduce (type-thm:true? true true true) + ;; but can't. Maybe instead there should be a reduce tactic/macro. + (inhabit-type (forall (a : (-> true true)) + (forall (f : (and^ true true)) + true)))) + +;; TODO: Interopt with Racket at runtime via contracts?!?!