#lang racket (require redex) (define-language L (B ::= t f (B · B))) (define-judgment-form L #:mode (r I O) #:contract (r B B) [ -------------- "t" (r (t · B) t)] [ -------------- "f" (r (f · B) B)]) (test-judgment-holds (r (t · f) t)) (test-judgment-holds (r (f · t) t)) (define-judgment-form L #:mode (-->r I O) #:contract (-->r B B) [(r B_1 B_2) -------------- "r" (-->r B_1 B_2)] [(-->r B_1 B_2) -------------------------- "right" (-->r (B · B_1) (B · B_2))] #| [(-->r B_1 B_2) -------------------------- "left" (-->r (B_1 · B) (B_2 · B))] |#) (test-judgment-holds (-->r (t · f) t)) (test-judgment-holds (-->r (f · t) t)) (test-judgment-holds (-->r (t · (t · f)) t)) (test-judgment-holds (-->r (t · (t · f)) (t · t))) (test-equal (judgment-holds (-->r (t · (t · f)) (B_1 · B_2)) B_2) '(t)) (define-judgment-form L #:mode (-->>r I O) #:contract (-->>r B B) [----------- "zero" (-->>r B B)] [(-->r B_1 B_2) (-->>r B_2 B_3) ------------------------------- "many" (-->>r B_1 B_3)]) (test-judgment-holds (-->>r (f · (t · f)) t)) (define-judgment-form L #:mode (has-t I) #:contract (has-t B) [--------- (has-t t)] [(has-t B_1) ------------------- (has-t (B_1 · B_2))] [(has-t B_2) ------------------- (has-t (B_1 · B_2))]) (define (fact? B) (and (implies (judgment-holds (has-t ,B)) (judgment-holds (-->>r ,B t))) (implies (judgment-holds (-->>r ,B t)) (judgment-holds (has-t ,B))))) ;;; ∀ B. something (redex-check L B (fact? (term B)) #:attempts 100)