├── README.md ├── hlean ├── contr_toys.hlean ├── rats.hlean ├── basics.hlean ├── int_order.hlean └── rats_basic.hlean ├── crispy-haskell └── sketch.hs ├── graded-applicatives └── Grading.hs ├── mltt ├── sigh.rkt ├── mltt.rkt ├── hott-mess.rkt └── mess.rkt ├── polystream └── Polystream.hs ├── trilambda ├── PlanarC.hs └── Planar.hs ├── contexts ├── Cxt.hs └── Lambek.hs ├── infinitraverse ├── predictable.bib └── IT.hs └── algebra-of-programming └── Algebraically.hs /README.md: -------------------------------------------------------------------------------- 1 | # works-in-progress 2 | scraps and bits and bobs 3 | -------------------------------------------------------------------------------- /hlean/contr_toys.hlean: -------------------------------------------------------------------------------- 1 | import types.nat types.sigma hit.trunc 2 | 3 | open nat sigma is_trunc trunc eq prod 4 | 5 | definition isFive : ℕ -> Type.{0} := λ x, prod (5 ≤ x) (x ≤ 5) 6 | 7 | definition fiveIsFive : sigma isFive := sigma.mk 5 (prod.mk (le.refl 5) (le.refl 5)) 8 | 9 | definition isFive.elim {n : ℕ} (x : isFive n) : 5 = n := prod.rec 10 | begin 11 | intros, 12 | exfalso, 13 | discard x 14 | end 15 | x 16 | 17 | 18 | check prod.rec 19 | print classes 20 | print fields algebra.linear_ordered_semiring 21 | 22 | /- 23 | definition isFive.elim {n : ℕ} (x : isFive n) : 5 = n := prod.rec le.antisymm x 24 | 25 | definition isFiveIsContr : is_contr (sigma isFive) := 26 | is_contr.mk fiveIsFive 27 | (λ x, sigma_eq 28 | (sigma.rec_on x (λ n p, isFive.elim p)) 29 | (sigma.rec_on x (λ n p, pathover_of_tr_eq (prod_eq (is_hprop.elim _ _) (is_hprop.elim _ _))))) 30 | 31 | definition isFiveIsTr : is_hprop (sigma isFive) := @is_trunc_of_is_contr _ _ (isFiveIsContr) 32 | 33 | definition isFiveTr : trunc -1 (sigma isFive) := tr fiveIsFive 34 | 35 | definition elimFromTrunc : ℕ := pr1 (@trunc.elim _ _ _ isFiveIsTr (λ x, x) isFiveTr) 36 | 37 | eval elimFromTrunc 38 | -/ 39 | -------------------------------------------------------------------------------- /crispy-haskell/sketch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StaticPointers #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | import GHC.StaticPtr 5 | import Data.Typeable 6 | 7 | type Global = StaticPtr 8 | 9 | local :: Global a -> a 10 | local = deRefStaticPtr 11 | 12 | x = static (5 :: Int) :: Global Int 13 | 14 | y :: Global Int 15 | y = let z = 20 in static (local x + 5) 16 | 17 | z = 20 18 | 19 | class CFunctor f where 20 | cmap :: Global (a -> b) -> f a -> f b 21 | 22 | class (Typeable w, CFunctor w) => CComonad w where 23 | -- | 24 | -- @ 25 | -- 'extract' . 'fmap' f = f . 'extract' 26 | -- @ 27 | extract :: w a -> a 28 | 29 | -- | 30 | -- @ 31 | -- 'duplicate' = 'extend' 'id' 32 | -- 'fmap' ('fmap' f) . 'duplicate' = 'duplicate' . 'fmap' f 33 | -- @ 34 | duplicate :: w a -> w (w a) 35 | 36 | -- | 37 | -- @ 38 | -- 'extend' f = 'fmap' f . 'duplicate' 39 | -- @ 40 | extend :: Global (w a -> b) -> w a -> w b 41 | 42 | 43 | -- toss in a label? 44 | data Crisp a = Crisp a 45 | instance IsStatic Crisp where 46 | fromStaticPtr = Crisp . local 47 | 48 | instance CFunctor Crisp where 49 | cmap f (Crisp a) = Crisp (local f a) 50 | 51 | cjoin :: Crisp (Crisp a) -> Crisp a 52 | cjoin (Crisp x) = x 53 | 54 | 55 | -- ask ian orton / licata uses? 56 | 57 | 58 | 59 | instance CComonad Crisp where 60 | extract (Crisp a) = a 61 | duplicate = Crisp 62 | extend f x = Crisp (local f x) 63 | 64 | 65 | strength :: Functor f => a -> f b -> f (a,b) 66 | strength x = fmap (x,) 67 | 68 | {- 69 | -- can't do it! 70 | cstrength :: (Typeable a, Typeable b, CFunctor f) => a -> f b -> f (a,b) 71 | cstrength x = cmap (static (x,)) 72 | -} 73 | 74 | -- foo :: Exists Gamma. (Gamma, Crisp ((Gamma -> Int) -> String)) 75 | -- bar :: Global ( -------------------------------------------------------------------------------- /graded-applicatives/Grading.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, TypeFamilies, ConstraintKinds, PolyKinds, MultiParamTypeClasses, TypeOperators, DataKinds, GADTs, ExistentialQuantification, FlexibleInstances #-} 2 | 3 | module Grading where 4 | import GHC.Exts ( Constraint ) 5 | import Data.Maybe (mapMaybe) 6 | -- import GHC.TypeLits 7 | 8 | -- cf http://conferences.inf.ed.ac.uk/clapscotland/uustalu.pdf 9 | -- https://www.cs.kent.ac.uk/people/staff/dao7/publ/combining-effects-and-coeffects-icfp16.pdf 10 | 11 | -- Effect is a cut down version of graded monads as per https://hackage.haskell.org/package/effect-monad 12 | 13 | {-| Specifies "parametric effect monads" which are essentially monads but 14 | annotated by a type-level monoid formed by 'Plus' and 'Unit' -} 15 | class Effect (m :: k -> * -> *) where 16 | 17 | {-| Effect of a trivially effectful computation |-} 18 | type Unit m :: k 19 | {-| Cominbing effects of two subcomputations |-} 20 | type Plus m (f :: k) (g :: k) :: k 21 | 22 | {-| Effect-parameterised version of 'return'. Annotated with the 'Unit m' effect, 23 | denoting pure compuation -} 24 | ereturn :: a -> m (Unit m) a 25 | 26 | {-| Effect-parameterise version of '>>=' (bind). Combines 27 | two effect annotations 'f' and 'g' on its parameter computations into 'Plus' -} 28 | 29 | ebind :: m f a -> (a -> m g b) -> m (Plus m f g) b 30 | 31 | ethen :: m f a -> m g b -> m (Plus m f g) b 32 | x `ethen` y = x `ebind` (\_ -> y) 33 | 34 | -- functorality arises from the plus/unit law. Not clear how to express this in general? 35 | efmap :: Effect m => (a -> b) -> m e a -> m (Plus m e (Unit m)) b 36 | efmap f x = x `ebind` (ereturn . f) 37 | 38 | 39 | 40 | -- counter 41 | 42 | 43 | {-| Define type constructors for natural numbers -} 44 | data N = Z | S N | Inf 45 | 46 | 47 | type family (:+) n m :: N where 48 | n :+ Z = n 49 | n :+ (S m) = S (n :+ m) 50 | Inf :+ m = Inf 51 | n :+ Inf = Inf 52 | 53 | type family Min n m :: N where 54 | Min n Inf = n 55 | Min Inf m = m 56 | Min n Z = Z 57 | Min Z m = Z 58 | Min (S n) (S m) = S (Min n m) 59 | 60 | data Vec (n :: N) a = Vec {unVec :: [a]} deriving Show 61 | 62 | atMay (x:xs) 0 = Just x 63 | atMay (x:xs) n = atMay xs (n-1) 64 | atMay [] _ = Nothing 65 | 66 | instance Effect Vec where 67 | {-| Trivial effect annotation is 0 -} 68 | type Unit Vec = Inf 69 | {-| Compose effects by addition -} 70 | type Plus Vec n m = Min n m 71 | 72 | ereturn a = Vec (repeat a) 73 | (Vec a) `ebind` k = Vec . mapMaybe (uncurry atMay) . (`zip` [0..]) $ map (unVec . k) a 74 | 75 | instance Functor (Vec n) where 76 | fmap = efmap 77 | 78 | oneVec :: a -> Vec (S Z) a 79 | oneVec x = Vec [x] 80 | 81 | twoVec :: a -> a -> Vec (S (S Z)) a 82 | twoVec x y = Vec [x,y] 83 | 84 | threeVec :: a -> a -> a -> Vec (S (S (S Z))) a 85 | threeVec x y z = Vec [x,y,z] 86 | 87 | 88 | -- regular applicatives from graded monads! 89 | 90 | data WrapEff m a = forall n. WrapEff (m n a) 91 | 92 | instance Show a => Show (WrapEff Vec a) where show (WrapEff x) = show x 93 | 94 | instance (Effect m) => Functor (WrapEff m) where 95 | fmap f (WrapEff x) = WrapEff (efmap f x) 96 | 97 | -- conjecture: every WrapEff of an effect does not necc obey the monad laws, but will obey the applicative laws 98 | 99 | instance (Effect m) => Applicative (WrapEff m) where 100 | pure = WrapEff . ereturn 101 | WrapEff x <*> WrapEff y = WrapEff $ x `ebind` \x1 -> y `ebind` \y1 -> ereturn (x1 y1) 102 | 103 | -- for Vec this recovers ZipList 104 | 105 | -- we should be able to give a "times" monoid as well and recover the max-times algebra! 106 | 107 | -- todo writer as a graded monad. 108 | 109 | -- thm relating distribution over monads and distribution over resultant applicatives -- when does the latter induce the former? 110 | 111 | -- also when does a WrapEff a actually yield a monad? -------------------------------------------------------------------------------- /mltt/sigh.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/match) 3 | 4 | ; type formers 5 | (define (type-nat) 'type-nat) 6 | (define (type-unit) 'type-unit) 7 | (struct type-and (x y)) 8 | (struct type-or (x y)) 9 | (struct type-fun (dom codom)) 10 | ; dependency 11 | (struct type-pi (var dom codom)) 12 | (struct type-sig (var dom codom)) 13 | (define (type-type) 'type) ;; inconsistent! 14 | 15 | ; value formers 16 | (struct lam (var vt body)) 17 | (struct app (fun arg)) 18 | ;cons and either we take ambiently 19 | 20 | ; dependency 21 | (struct lam-pi (var vt body)) 22 | (struct sigma (val vt snd)) 23 | 24 | (define (type? env t) 25 | (match t 26 | ['type #t] 27 | ['type-nat #t] 28 | ['type-unit #t] 29 | [(type-and a b) (and (type? env a) (type? env b))] 30 | [(type-or a b) (and (type? env a) (type? env b))] 31 | [(type-fun a b) (and (type? env a) (type? env b))] 32 | [(type-pi var a b) (and (type? env a) (type? (cons (cons var a) env) b))] 33 | [(type-sig val a b) (and (type? env a) (type? (cons (cons val a) env) b))] 34 | [_ #f] 35 | )) 36 | 37 | (define (hasType? env x t) 38 | (match x 39 | [(app (lam fvar vt body) arg) 40 | (and (hasType? env arg vt) 41 | (hasType? (cons (cons fvar vt) env) body t))] 42 | ;dependency 43 | [(app (lam-pi fvar vt body) arg) 44 | (and (hasType? env arg vt) 45 | (hasType? (cons (cons fvar vt env)) body (subst fvar arg t)))] 46 | [(var vname) #:when (symbol? vname) 47 | (eq? t (cdr (assoc vname env)))] 48 | [_ (match t 49 | ['type-nat (and (integer? x) (>= x 0))] 50 | ['type-unit (null? x)] 51 | [(type-and a b) 52 | (match x 53 | [(cons y z) (and (hasType? env y a) 54 | (hasType? env z b))])] 55 | [(type-or a b) 56 | (match x 57 | [(cons 'l y) (hasType? env y a)] 58 | [(cons 'r z) (hasType? env z b)])] 59 | [(type-fun a b) 60 | (match x 61 | [(lam y yt z) (and (eqType? env yt a) 62 | (hasType? (cons (cons y a) env) z b))])] 63 | [(type-pi fvar a b) 64 | (match x 65 | [(lam-pi y yt z) (and (eqType? env yt a) (eq? fvar y) 66 | (hasType? (cons (cons y a) env) z b))])] 67 | [(type-sig fvar a b) 68 | (match x 69 | [(sigma y yt z) (and (eqType? env yt a) (hasType? y a) 70 | (hasType? env (subst fvar y z) b))])] 71 | )] 72 | )) 73 | 74 | ; substitution and reduction 75 | (define (subst v arg body) 76 | (reduce (match body 77 | [(type-and a b) (type-and (subst v arg a) (subst v arg b))] 78 | [(type-or a b) (type-or (subst v arg a) (subst v arg b))] 79 | [(type-fun a b) (type-fun (subst v arg a) (subst v arg b))] 80 | [(type-pi var a b) (type-pi var (subst v arg a) (subst v arg b))] 81 | 82 | [(cons a b) (cons (subst v arg a) (subst v arg b))] 83 | [(list 'l a) ('l (subst v arg a))] 84 | [(list 'r a) ('r (subst v arg a))] 85 | 86 | [(var vname) #:when (eq? vname v) arg] 87 | [(var vname) #:when (symbol? vname) vname] 88 | 89 | ;; this should suffice to avoid capture 90 | [(lam var vt b) (lam var vt (if (eq? var v) b (subst v arg b)))] 91 | [(lam-pi var vt b) (lam-pi var vt (if (eq? var v) b (subst v arg b)))] 92 | [(app f a) (reduce (app (subst v arg f) (subst v arg a)))] 93 | ))) 94 | 95 | ; strict 96 | (define (reduce body) 97 | (match body 98 | [(app (lam var vt body) arg) (subst var (reduce arg) body)] 99 | [(app (lam-pi var vt body) arg) (subst var (reduce arg) body)] 100 | [(app fun arg) (reduce (app (reduce fun) (reduce arg)))] 101 | [_ body] 102 | )) 103 | 104 | (define (eqType? env t1 t2) (eq? t1 t2)) 105 | (define (eqVal? env typ v1 v2) (eq? v1 v2)) 106 | (define (getType env v1) (#f)) 107 | 108 | (define id-nat (lam 'x (type-nat) 'x)) 109 | (hasType? '() id-nat (type-fun (type-nat) (type-nat))) 110 | (reduce (app id-nat 5)) 111 | 112 | (define id-forall (lam-pi 'x (type-type) (lam 'y 'x 'y))) 113 | (hasType? '() id-forall (type-pi 'x (type-type) (type-fun 'x 'x))) 114 | 115 | (reduce (app (app id-forall (type-nat)) 5)) 116 | 117 | ;; todo -- prims 118 | ;; todo -- simplicial equality -------------------------------------------------------------------------------- /polystream/Polystream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, GADTs, ScopedTypeVariables, RankNTypes, StandaloneDeriving, TypeInType, PolyKinds, TypeApplications, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} 2 | 3 | module Polystream where 4 | import Data.Proxy 5 | import Data.List 6 | import qualified Data.Map as M 7 | import Debug.Trace 8 | -- import GHC.TypeLits 9 | 10 | data Nat = Z | S Nat 11 | 12 | class ToInt a where 13 | toInt :: a -> Int 14 | 15 | instance ToInt (Proxy Z) where 16 | toInt _ = 0 17 | 18 | instance ToInt (Proxy n) => ToInt (Proxy (S n)) where 19 | toInt _ = 1 + toInt (Proxy :: Proxy n) 20 | 21 | 22 | -- todo elim vec case? 23 | data Vec n a where 24 | VZ :: a -> Vec Z a 25 | VS :: a -> Vec m a -> Vec (S m) a 26 | 27 | vec2List :: Vec n a -> [a] 28 | vec2List (VZ a) = [a] 29 | vec2List (VS a v) = a : vec2List v 30 | 31 | -- move to level n, m variables and this works without singleton... hrm. 32 | -- level n, (m+1) variables 33 | data SVec n m a where 34 | SUnit :: a -> SVec Z m a 35 | SSingleton :: ToInt (Proxy n) => a -> SVec n Z a 36 | SBase :: Vec m a -> SVec (S Z) m a 37 | -- at level n, for a given variable it splits into all level n-1 with that variable added plus all level n-1 with that variable not present and the next variable bumped, and so on until we've eliminated all variables 38 | SCons :: SDesc n (S m) a -> SVec (S n) (S m) a 39 | 40 | -- SVec n (S m) a -> SVec n m a -> SVec (S n) (S m) a 41 | 42 | data SDesc n m a where 43 | SDNil :: SVec n Z a -> SDesc n Z a 44 | SDCons :: SVec n (S m) a -> SDesc n m a -> SDesc n (S m) a 45 | 46 | 47 | numvars v = take (length (vec2List v)) [(1::Int)..] 48 | 49 | type Trm = M.Map Int Int 50 | 51 | bumpVarName :: M.Map Trm a -> M.Map Trm a 52 | bumpVarName = M.mapKeys (M.mapKeys (+1)) 53 | 54 | bumpVar :: Int -> M.Map Trm a -> M.Map Trm a 55 | bumpVar n = M.mapKeys (M.insertWith (+) n 1) 56 | 57 | sToProxy :: SVec n m a -> Proxy n 58 | sToProxy = undefined 59 | 60 | mkMap :: Num a => SVec n m a -> M.Map Trm a 61 | mkMap (SUnit a) = M.singleton M.empty a 62 | mkMap x@(SSingleton a) = trace (show $ (toInt (sToProxy x))) $ M.singleton (M.singleton 1 (toInt (sToProxy x))) a -- TODO different count for each n 63 | mkMap (SBase v) = M.fromList $ zip (map (`M.singleton` 1) $ numvars v) (vec2List v) 64 | mkMap (SCons x) = mkMapDesc x 65 | 66 | mkMapDesc :: Num a => SDesc n m a -> M.Map Trm a 67 | mkMapDesc (SDCons x y) = M.unionWith (+) (bumpVar 1 $ mkMap x) (bumpVarName $ mkMapDesc y) 68 | mkMapDesc (SDNil v) = bumpVar 1 $ mkMap v 69 | 70 | -- mkMap (SCons x) = M.unionWith (+) (bumpVar 1 $ mkMap x) (bumpVarName $ bumpVar 1 (mkMap y)) 71 | 72 | foo1 :: SVec ('S 'Z) ('S ('S 'Z)) Integer -- level 1, 3 elements 73 | foo1 = SCons (SDCons (SUnit 1) (SDCons (SUnit 2) (SDNil (SUnit 3)))) 74 | 75 | foo :: SVec ('S 'Z) ('S 'Z) Integer -- level 1, 2 elements 76 | foo = SBase (VS 2 (VZ 1)) 77 | bar :: SVec ('S 'Z) 'Z Integer -- level 1, 1 element 78 | bar = SBase (VZ 5) 79 | 80 | baz :: SVec ('S ('S 'Z)) ('S 'Z) Integer -- level 2, 2 elements 81 | baz = SCons (SDCons foo (SDNil bar)) 82 | 83 | quux :: SVec ('S ('S ('S 'Z))) ('S 'Z) Integer -- level 3, 2 elements 84 | quux = SCons (SDCons baz (SDNil (SSingleton 13))) 85 | 86 | bill :: SVec ('S ('S 'Z)) ('S ('S 'Z)) Integer 87 | bill = SCons (SDCons (SBase (VS 5 (VS 7 (VZ 15)))) (SDCons foo (SDNil (SSingleton 45)))) 88 | 89 | 90 | -- asdf = SCons (SDCons baz (SDNil _)) 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | -- v is num of variables, n is number of variables (i.e. level in series) 102 | data Series v n a where 103 | SZ :: a -> Series Z v a 104 | SE :: a -> Series v v a 105 | -- SE :: 106 | SS :: Series v (S n) a 107 | -> Series v n a 108 | -> Series (S v) (S n) a 109 | 110 | seriesSize :: Series v n a -> Int 111 | seriesSize (SZ _) = 1 112 | seriesSize (SE _) = 1 113 | seriesSize (SS a b) = seriesSize a + seriesSize b 114 | 115 | deriving instance Show a => Show (Series v n a) 116 | 117 | 118 | data Binom n k a where 119 | BNull :: Binom n (S n) a 120 | BUnit :: a -> Binom n n a 121 | BUnit' :: a -> Binom n Z a 122 | BS :: Binom n (S k) a -> Binom n k a -> Binom (S n) (S k) a 123 | 124 | 125 | deriving instance Show a => Show (Binom n k a) 126 | 127 | b0 :: Binom Z Z Double 128 | b0 = BUnit 1 129 | 130 | b1_1 :: Binom (S Z) Z Double 131 | b1_1 = BUnit' 1 132 | 133 | b1_2 :: Binom (S Z) (S Z) Double 134 | b1_2 = BUnit 1 135 | 136 | b2_1 :: Binom (S (S Z)) Z Double 137 | b2_1 = BUnit' 1 138 | 139 | b2_2 :: Binom (S (S Z)) (S Z) Double 140 | b2_2 = BS b1_2 b1_1 141 | 142 | b2_3 :: Binom (S (S Z)) (S (S Z)) Double 143 | b2_3 = BUnit 1 144 | 145 | -- b1_1 :: Binom (S Z) Z Double 146 | -- b1_1 = BS BNull _ 147 | --b1_1 = BS BNull (BZ 1) 148 | --b1_1 = BSZ 1 149 | 150 | fac n | n > 0 = n * fac (n - 1) 151 | | otherwise = 1 152 | 153 | choose n k = fac n / (fac k * fac (n - k)) 154 | chooseReplace n k = choose (n + k - 1) k 155 | -------------------------------------------------------------------------------- /trilambda/PlanarC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE TupleSections #-} 8 | 9 | module PlanarC where 10 | import Diagrams.Backend.SVG.CmdLine 11 | import Diagrams.Backend.SVG 12 | import Diagrams.Prelude hiding (shift) 13 | import Diagrams.TwoD.GraphViz 14 | import Data.GraphViz.Attributes.Complete 15 | import Control.Arrow(first) 16 | import Graphics.SVGFonts 17 | import Data.Graph.Planar as P 18 | import qualified Data.Map as M 19 | import Data.List(nub) 20 | import Data.Maybe (fromJust) 21 | 22 | 23 | 24 | import Debug.Trace 25 | 26 | 27 | -- context is generated by zero, extension (add one to the right), usage (move turnstile left), and closure (chop off right side of turnstile). 28 | 29 | data Nat = Z | S Nat deriving (Read, Show, Eq) 30 | 31 | 32 | data C = C [Nat] [Nat] deriving (Read, Show, Eq) 33 | 34 | -- variables used in scope, terms built in scope 35 | emptyStack = C [Z] [Z] 36 | 37 | partitions (S Z) = [(S Z, Z)] 38 | partitions (S x) = (S Z, x) : map (\(a,b) -> (S a, b)) (partitions x) 39 | 40 | intro :: C -> [C] 41 | intro (C (h:hs) ts) = map (\(h1,h2) -> C (h1 : h2 : hs) (Z : ts)) (partitions (S h)) 42 | intro (C h ts) = [C (S Z : h) (Z : ts)] 43 | 44 | shift :: C -> [C] 45 | shift (C (S h : hs) (t:ts)) = [C (h : hs) (S t : ts)] 46 | shift _ = [] 47 | 48 | app :: C -> [C] 49 | app (C h (S (S t) : ts)) = [C h (S t : ts)] 50 | app _ = [] 51 | 52 | close :: C -> [C] 53 | close (C (Z:hs) (S Z:t:ts)) = [C hs (S t : ts)] 54 | close _ = [] 55 | 56 | data Op = CI | CA | CS | CC deriving (Read, Show, Eq, Ord) 57 | 58 | genTerm :: Int -> [[Op]] 59 | genTerm x = map reverse . map snd $ go x (emptyStack,[]) 60 | where go n (c,os) = is ++ ss ++ as ++ cs 61 | where 62 | is | n == 0 = if c == C [Z] [S Z] then [(c,os)] else [] 63 | | otherwise = go (n - 1) . (,CI:os) =<< intro c 64 | as = go n . (,CA:os) =<< app c 65 | ss = go n . (,CS:os) =<< shift c 66 | cs = go n . (,CC:os) =<< close c 67 | 68 | data FOL = Bind String FOL | App FOL FOL | Var String deriving Show 69 | 70 | --termToFOL :: [OP] -> FOL 71 | termToFOL xs = snd $ go ['a'..'z'] [] [] xs 72 | where go ns cxt [t] [] = (([],[],[],[]),t) 73 | go (n:ns) cxt tms (CI:os) = 74 | let ((ns', cxt', tms', os'),body) = go ns (n:cxt) [] os 75 | -- should be cxt == cxt' 76 | in go ns' cxt' ((Bind (n:[]) body) : tms) os' 77 | go ns (v:cxt) tms (CS:os) = go ns cxt ((Var (v:[])):tms) os 78 | go ns (cxt) tms (CA:os) = case tms of 79 | (t1:t2:ts) -> go ns cxt ((App t1 t2) :ts) os 80 | go ns cxt (t:[]) (CC:os) = ((ns,cxt,[],os),t) 81 | 82 | go ns cxt tms os = error $ show (ns, cxt, tms, os) 83 | 84 | 85 | showFOL (Bind s x) = "\\"++s++"."++showFOL x 86 | showFOL (App x y) = "("++showFOL x ++ ")(" ++ showFOL y ++ ")" 87 | showFOL (Var s) = s 88 | 89 | folToGraph = uncurry mkGraph . stripSelfLoop . fst . folToGraphData 90 | 91 | stripSelfLoop (vs,es) = (vs,filter go es) 92 | where go (i,o,_) = i /= o 93 | 94 | folToGraphData 95 | :: FOL -> (([String], [(String, [Char], [Char])]), Integer) 96 | folToGraphData = (first . first) ("in":) . go "in" 0 97 | where 98 | go parent n (Bind s x) = 99 | let lbl = s 100 | ((v1,e1),n1) = go lbl n x 101 | in ((lbl:v1, (lbl,parent,lbl ++ "->" ++ parent):e1),n1) 102 | go parent n (App x y) = 103 | let lbl = show n 104 | ((v1,e1),n1) = go lbl (n+1) x 105 | ((v2,e2),n2) = go lbl n1 y 106 | in ((lbl : (v1 ++ v2), (lbl,parent, lbl ++ "!->" ++ parent) : (e1 ++ e2)),n2) 107 | go parent n (Var s) = 108 | let lbl = s 109 | in (([], (lbl,parent, lbl ++ "!!->" ++ parent) : []),n) 110 | 111 | -- todo control edge positioning? 112 | folToPlanarGraph :: FOL -> PlanarGraph String String 113 | folToPlanarGraph tm = let (nd, gr) = P.addNode "in" P.empty 114 | in go nd gr 0 (M.singleton "in" nd) tm 115 | where 116 | go parent g num env (Bind s x) = 117 | let (n1, g1) = addNode s g 118 | gph = go n1 g1 num (M.insert s n1 env) x 119 | in snd $ addEdge n1 Anywhere parent Anywhere (show (n1,parent)) (show (n1,parent)) gph 120 | go parent g num env (App x y) = 121 | let (n1, g1) = addNode (show num) g 122 | gph = go n1 g1 (num+1) (M.insert (show num) n1 env) x 123 | gph2 = go n1 gph (num+1) (M.insert (show num) n1 env) y 124 | in snd $ addEdge n1 Anywhere parent Anywhere (show (n1,parent)) (show (n1,parent)) gph2 125 | go parent g num env (Var s) = 126 | let Just n1 = M.lookup s env 127 | in snd $ addEdge n1 Anywhere parent Anywhere (show (n1,parent)) (show (n1,parent)) g 128 | 129 | planarToGraph x = rename . stripSelfLoop . fmap nub $ (vs, es) 130 | where 131 | xs = serialise x 132 | vs = map (\(a,_,_)-> a) xs 133 | es = concatMap (\(a,_,e1) -> map (\(_,b,e,_) -> ( a, b,e)) e1) xs 134 | vnames = M.fromList . map (\(a,b,_) -> (a,b)) $ xs 135 | renameVar = fromJust . flip M.lookup vnames 136 | rename (vws,ews) = (map renameVar vws, 137 | map (\(a,b,c) -> (renameVar a, renameVar b, c)) ews) 138 | 139 | --planarToGraph :: PlanarGraph String String -> 140 | 141 | 142 | -- term generation is right, printing algo is probably right but alpha namings can be nonintuitive 143 | sft = map showFOL . map termToFOL . genTerm 144 | 145 | pft = mapM_ putStrLn . sft 146 | 147 | gft = map folToGraph . map termToFOL . genTerm 148 | 149 | 150 | pgft = map folToPlanarGraph . map termToFOL . genTerm 151 | 152 | dualPlanar g = snd $ toDual vlabel elabel (getFaces g) 153 | where elabel _ _ _ = "edge" 154 | vlabel f = show f 155 | 156 | {- 157 | 158 | WOOT ! 159 | 160 | *PlanarC> map length (map genTerm [1..]) 161 | [1,4,32,336,4096,54912, 162 | 163 | -} 164 | 165 | go x y = do 166 | l2 <- lin2 167 | let text' d s = (strokeP $ textSVG' (TextOpts l2 INSIDE_H KERN False d d) s) 168 | # lw none # fc black 169 | 170 | let gph = folToGraph . termToFOL $ genTerm x !! y 171 | print gph 172 | putStrLn (showFOL . termToFOL $ genTerm x !! y) 173 | gr <- layoutGraph Dot (gph) 174 | let dia :: Diagram B 175 | dia = drawGraph 176 | (\lbl loc -> place (text' 6 lbl <> circle 19) loc) 177 | (\_ p1 _ p2 _ p -> arrowBetween' (opts p) p1 p2) 178 | gr 179 | opts p = with & gaps .~ 22 & arrowShaft .~ (unLoc . head $ pathTrails p) 180 | 181 | renderSVG "out.svg" (mkWidth 250) dia 182 | 183 | let gph2 = planarToGraph . folToPlanarGraph . termToFOL $ genTerm x !! y 184 | gr <- layoutGraph Dot (uncurry mkGraph gph2) 185 | let dia :: Diagram B 186 | dia = drawGraph 187 | (\lbl loc -> place (text' 6 lbl <> circle 19) loc) 188 | (\_ p1 _ p2 _ p -> arrowBetween' (opts p) p1 p2) 189 | gr 190 | opts p = with & gaps .~ 22 & arrowShaft .~ (unLoc . head $ pathTrails p) 191 | 192 | renderSVG "out2.svg" (mkWidth 350) dia 193 | 194 | 195 | 196 | main = simpleGraphDiagram Dot (gft 3 !! 7) >>= defaultMain 197 | 198 | {- 199 | main = theGraph >>= defaultMain 200 | where 201 | theGraph :: IO (Diagram B) 202 | theGraph = simpleGraphDiagram Dot hex 203 | -} 204 | 205 | hex = mkGraph [0..19] 206 | ( [ (v, (v+1)`mod`6, ()) | v <- [0..5] ] 207 | ++ [ (v, v+k, ()) | v <- [0..5], k <- [6,12] ] 208 | ++ [ (2,18,()), (2,19,()), (15,18,()), (15,19,()), (18,3,()), (19,3,()) ] 209 | ) 210 | -------------------------------------------------------------------------------- /hlean/rats.hlean: -------------------------------------------------------------------------------- 1 | import types.int algebra.field hit.set_quotient hit.trunc int_order 2 | open eq sigma sigma.ops equiv is_equiv equiv.ops eq.ops int algebra set_quotient is_trunc trunc quotient 3 | 4 | record prerat : Type := (num : ℤ) (denom : ℤ) --(dp : denom > 0) 5 | 6 | inductive rat_rel : prerat → prerat → Type := 7 | | Rmk : Π (a b : prerat), int.mul (prerat.num a) (prerat.denom b) = 8 | int.mul (prerat.num b) (prerat.denom a) 9 | → rat_rel a b 10 | 11 | namespace prerat 12 | 13 | definition of_int (i : int) : prerat := prerat.mk i (of_num 1) 14 | 15 | definition zero : prerat := of_int (of_num 0) 16 | 17 | definition one : prerat := of_int (of_num 1) 18 | 19 | definition add (a b : prerat) : prerat := 20 | prerat.mk (num a * denom b + num b * denom a) (denom a * denom b) 21 | 22 | definition mul (a b : prerat) : prerat := 23 | prerat.mk (num a * num b) (denom a * denom b) 24 | 25 | definition neg (a : prerat) : prerat := 26 | prerat.mk (- num a) (denom a) 27 | 28 | definition rat_rel_refl (a : ℤ) (b : ℤ) : rat_rel (mk a b) (mk a b) := 29 | rat_rel.Rmk (prerat.mk a b) (prerat.mk a b) (refl _) 30 | 31 | theorem of_int_add (a b : ℤ) : rat_rel (of_int (#int a + b)) (add (of_int a) (of_int b)) := 32 | begin 33 | esimp [of_int, add, nat.mul, nat.add, one, zero], 34 | rewrite [+int.mul_one], 35 | fapply rat_rel_refl 36 | end 37 | 38 | theorem of_int_mul (a b : ℤ) : rat_rel (of_int (#int a * b)) (mul (of_int a) (of_int b)) := 39 | begin 40 | esimp [of_int, add, nat.mul, mul], 41 | rewrite [+int.mul_one], 42 | fapply rat_rel_refl 43 | end 44 | 45 | theorem of_int_neg (a : ℤ) : rat_rel (of_int (#int -a)) (neg (of_int a)) := 46 | begin 47 | esimp [neg, of_int], 48 | fapply rat_rel_refl 49 | end 50 | 51 | 52 | theorem of_int.inj {a b : ℤ} : rat_rel (of_int a) (of_int b) → a = b := 53 | begin 54 | intros, 55 | cases a_1 with [a,b,p], 56 | generalize p, 57 | clear p, 58 | esimp [denom], 59 | rewrite[+mul_one], 60 | intros, 61 | exact p 62 | end 63 | 64 | 65 | theorem equiv_zero_of_num_eq_zero {a : prerat} (H : num a = of_num 0) : rat_rel a zero := 66 | rat_rel.Rmk a zero ( 67 | begin 68 | rewrite [H], 69 | esimp [zero, of_int, num], 70 | rewrite[+zero_mul] 71 | end 72 | ) 73 | 74 | theorem num_eq_zero_of_equiv_zero {a : prerat} : rat_rel a zero → num a = 0 := 75 | begin 76 | intros, 77 | cases a_1 with [a,z,p], 78 | generalize p, 79 | clear p, 80 | esimp [denom], 81 | rewrite [zero_mul,mul_one], 82 | exact (λ x, x), 83 | end 84 | 85 | theorem add_rel_add {a1 b1 a2 b2 : prerat} (r1 : rat_rel a1 a2) (r2 : rat_rel b1 b2) : rat_rel (add a1 b1) (add a2 b2) := 86 | rat_rel.cases_on r1 (λ a_1 a_2 H1, 87 | rat_rel.cases_on r2 (λ b_1 b_2 H2, 88 | rat_rel.Rmk (add a_1 b_1) (add a_2 b_2) 89 | (calc 90 | num (add a_1 b_1) * denom (add a_2 b_2) 91 | = (num a_1 * denom b_1 + num b_1 * denom a_1) * (denom a_2 * denom b_2) : by esimp [add] 92 | ... = num a_1 * denom a_2 * denom b_1 * denom b_2 + num b_1 * denom b_2 * denom a_1 * denom a_2 : 93 | by rewrite [mul.right_distrib, *mul.assoc, mul.left_comm (denom b_1), mul.comm (denom b_2), *mul.assoc] 94 | ... = num a_2 * denom a_1 * denom b_1 * denom b_2 + num b_2 * denom b_1 * denom a_1 * denom a_2 : 95 | by rewrite [H1, H2] 96 | ... = (num a_2 * denom b_2 + num b_2 * denom a_2) * (denom a_1 * denom b_1) : 97 | by rewrite [mul.right_distrib, *mul.assoc, *mul.left_comm (denom b_2), *mul.comm (denom b_1), *mul.assoc, mul.left_comm (denom a_2)] 98 | ) 99 | )) 100 | 101 | /- field operations -/ 102 | /-TODO have an ordering on the ints so we can give -/ 103 | /- 104 | definition smul (a : ℤ) (b : prerat) (H : a > 0) : prerat := 105 | prerat.mk (a * num b) (int2nat a H * denom b) 106 | -/ 107 | 108 | 109 | end prerat 110 | 111 | /- 112 | 113 | definition inv : prerat → prerat 114 | | inv (prerat.mk nat.zero d dp) := zero 115 | | inv (prerat.mk (nat.succ n) d dp) := prerat.mk d (nat.succ n) !of_nat_succ_pos 116 | | inv (prerat.mk -[1+n] d dp) := prerat.mk (-d) (nat.succ n) !of_nat_succ_pos 117 | 118 | 119 | theorem inv_zero {d : int} (dp : d > 0) : inv (mk nat.zero d dp) = zero := 120 | begin rewrite [↑inv, ▸*] end 121 | 122 | theorem inv_zero' : inv zero = zero := inv_zero (of_nat_succ_pos nat.zero) 123 | 124 | theorem inv_of_pos {n d : int} (np : n > 0) (dp : d > 0) : inv (mk n d dp) ≡ mk d n np := 125 | obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), 126 | have (#nat n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), 127 | obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, 128 | have d * n = d * nat.succ k, by rewrite [Hn', Hk], 129 | Hn'⁻¹ ▸ (Hk⁻¹ ▸ this) 130 | 131 | theorem inv_neg {n d : int} (np : n > 0) (dp : d > 0) : inv (mk (-n) d dp) ≡ mk (-d) n np := 132 | obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), 133 | have (#nat n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), 134 | obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, 135 | have -d * n = -d * nat.succ k, by rewrite [Hn', Hk], 136 | have H3 : inv (mk -[1+k] d dp) ≡ mk (-d) n np, from this, 137 | have H4 : -[1+k] = -n, from calc 138 | -[1+k] = -(nat.succ k) : rfl 139 | ... = -n : by rewrite [Hk⁻¹, Hn'], 140 | H4 ▸ H3 141 | 142 | theorem inv_of_neg {n d : int} (nn : n < 0) (dp : d > 0) : 143 | inv (mk n d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn) := 144 | have inv (mk (-(-n)) d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn), 145 | from inv_neg (neg_pos_of_neg nn) dp, 146 | !neg_neg ▸ this 147 | 148 | theorem of_int.inj {a b : ℤ} : of_int a ≡ of_int b → a = b := 149 | by rewrite [↑of_int, ↑equiv, *mul_one]; intros; assumption 150 | 151 | -/ 152 | 153 | 154 | /- 155 | the rationals 156 | -/ 157 | namespace rat 158 | 159 | definition rat_rel_trunc (a : prerat) (b : prerat) : hprop := trunctype.mk (trunc -1 (rat_rel a b)) _ 160 | 161 | definition rat := set_quotient rat_rel_trunc 162 | notation `ℚ` := rat 163 | 164 | open nat 165 | definition of_int [coercion] (i : ℤ) : ℚ := set_quotient.class_of rat_rel_trunc (prerat.of_int i) 166 | definition of_nat [coercion] (n : ℕ) : ℚ := n 167 | definition of_num [coercion] [reducible] (n : num) : ℚ := n 168 | definition lift0 (p : prerat) : ℚ := set_quotient.class_of rat_rel_trunc p 169 | 170 | definition prerat_refl (a : prerat) : rat_rel_trunc a a := tr (rat_rel.Rmk a a (refl _)) 171 | definition lift1 {A : Type} [hs : is_hset A] (f : prerat → A) (coh : Π (p q : prerat), rat_rel_trunc p q -> f p = f q) (r : rat) : A := 172 | set_quotient.elim_on rat_rel_trunc r f coh 173 | 174 | /- 175 | lemma ext_c {A B C : Type} {rel_a : A → A → hprop} {rel_b : B → B → hprop} (f : A -> B -> C) (c : Π (a1 a2 : A) (b1 b2 : B) , rel_a a1 a2 → rel_b b1 b2 → f a1 b1 = f a2 b2) : Π (a1 a2 : A), rel_a a1 a2 → f a1 = f a2 := 176 | λ (a1 a2 : A) (myrel : rel_a a1 a2), _ (λ (b : B), (c a1 a2 b b myrel sorry)) 177 | -/ 178 | 179 | set_option formatter.hide_full_terms false 180 | 181 | definition lift2 {A B C : Type} [hs : is_hset C] {rel_a : A → A → hprop} {rel_b : B → B → hprop} (rel_a_refl : Π (a : A), rel_a a a) (f : A -> B -> C) (c : Π (a1 a2 : A) (b1 b2 : B) , rel_a a1 a2 → rel_b b1 b2 → f a1 b1 = f a2 b2) (q1 : set_quotient rel_a) (q2 : set_quotient rel_b) : C := 182 | set_quotient.elim_on 183 | rel_a 184 | q1 185 | (λ a, set_quotient.elim_on rel_b q2 (f a) (begin intros, apply c, exact (rel_a_refl a), assumption end)) 186 | sorry 187 | /- 188 | (λ (a a' : A) (H : rel_a a a'), ap (λ a1, set_quotient.elim_on rel_b q2 (f a1) (begin intros, apply c, exact (rel_a_refl a1), assumption end)) (ext_c f c a a' H)) 189 | -/ 190 | 191 | theorem rat_is_hset : is_hset ℚ := set_quotient.is_hset_set_quotient rat_rel_trunc 192 | 193 | definition lift2rat (f : prerat -> prerat -> ℚ) (c : Π (a1 a2 b1 b2 : prerat), rat_rel_trunc a1 a2 → rat_rel_trunc b1 b2 → f a1 b1 = f a2 b2) := @lift2 prerat prerat ℚ (rat_is_hset) rat_rel_trunc rat_rel_trunc prerat_refl f c 194 | 195 | definition add : ℚ → ℚ → ℚ := 196 | lift2rat 197 | (λ a b : prerat, lift0 (prerat.add a b)) 198 | (begin 199 | intros, 200 | apply (set_quotient.eq_of_rel rat_rel_trunc), 201 | apply (trunc.elim_on a (λ a', trunc.elim_on a_1 (λ a_1', tr (prerat.add_rel_add a' a_1')))) 202 | end) 203 | 204 | end rat 205 | -------------------------------------------------------------------------------- /trilambda/Planar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Planar where 9 | import Debug.Trace 10 | 11 | 12 | -- context is generated by zero, extension (add one to the right), usage (move turnstile left), and closure (chop off right side of turnstile). 13 | 14 | -- for each variable introduced, after the application (or introduction) of which term is it introduced. so a backedge, for each n, some m < n, with no crossing 15 | 16 | {- 17 | type Planar = [Int] 18 | 19 | planars1 = 0 : (ma 20 | 21 | -} 22 | 23 | 24 | {- doesn't work, need more info. Nats to tree. Don't just say can take a var, but which var. -} 25 | -- tree gives vars that a term promises to consume 26 | data C = Z | L C | R C | S C deriving (Read, Show) -- turn into tree of context splittings 27 | 28 | data Planar (takes :: C) where 29 | PBindAppL :: Planar (L a) -> Planar a -> Planar a -- need to use some on left, and some on right 30 | PBindAppR :: Planar a -> Planar (R a) -> Planar a -- need to use some on left, and some on right 31 | PBindNest :: Planar (S a) -> Planar a 32 | PVar :: Planar (S Z) 33 | PVarL :: Planar (L Z) 34 | PVarR :: Planar (R Z) 35 | Yawp :: C -> Planar a 36 | 37 | class RC (a :: C) where 38 | rc :: f a -> C 39 | 40 | instance RC Z where rc _ = Z 41 | instance RC (S a) where rc x = S (rc x) -- reduce 42 | instance RC (R a) where rc x = R (rc x) 43 | 44 | instance RC (L a) where rc x = L (rc x) 45 | 46 | -- rule out twovar case duplication and other symmetries 47 | 48 | deriving instance Show (Planar a) 49 | 50 | -- lambdas need to track what they consume, as do apps 51 | 52 | 53 | -- int is vars allowed/required to intro, nat is vars allowed/required to consume 54 | class GenPlanar (a::C) where 55 | genPlanarZero :: [Planar a] 56 | genPlanar :: Int -> [Planar a] 57 | genPlanar 0 = genPlanarZero 58 | genPlanar n = ss ++ as ++ rs where 59 | -- should be mix of intro and consume, not just intro? 60 | as = do 61 | left <- [0..n-1] 62 | _ <- trace (show left) $ return () 63 | lbind <- genPlanar left 64 | -- _ <- trace (show lbind) $ return () 65 | rbind <- genPlanar (n -left) 66 | -- _ <- trace (show rbind) $ return () 67 | return $ PBindAppL lbind rbind 68 | rs = do 69 | left <- [0..n-1] 70 | lbind <- genPlanar left 71 | rbind <- genPlanar (n - left) 72 | return $ PBindAppR lbind rbind 73 | 74 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 75 | | otherwise = [] 76 | 77 | -- these overlaps suck, need a closed type family ugh 78 | 79 | instance GenPlanar Z where genPlanarZero = [] 80 | instance GenPlanar (S Z) where genPlanarZero = [PVar] 81 | instance GenPlanar (R Z) where genPlanarZero = [PVarR] 82 | instance GenPlanar (L Z) where genPlanarZero = [PVarL] 83 | instance {-# OVERLAPPABLE #-} RC a => GenPlanar a where genPlanarZero = let res = [Yawp (rc $ head res)] in res 84 | {- 85 | instance GenPlanar (S a) where genPlanarZero = [] 86 | instance GenPlanar (L a) where genPlanarZero = [] 87 | instance GenPlanar (R a) where genPlanarZero = [] 88 | -} 89 | {- 90 | 91 | class GenPlanarZero (a::C) where 92 | genPlanarZero :: [Planar a] 93 | 94 | instance GenPlanarZero Z where genPlanarZero = [] 95 | instance GenPlanarZero (S Z) where genPlanarZero = [PVar] 96 | instance GenPlanarZero (R Z) where genPlanarZero = [PVarR] 97 | instance GenPlanarZero (L Z) where genPlanarZero = [PVarL] 98 | instance GenPlanarZero (S a) where genPlanarZero = [] 99 | instance GenPlanarZero (L a) where genPlanarZero = [] 100 | instance GenPlanarZero (R a) where genPlanarZero = [] 101 | 102 | instance GenPlanarZero a => GenPlanar a where 103 | genPlanar 0 = genPlanarZero 104 | genPlanar n = ss ++ as ++ rs where 105 | -- should be mix of intro and consume, not just intro? 106 | as = do 107 | left <- [0..n-1] 108 | _ <- trace (show left) $ return [] 109 | lbind <- genPlanarZero ++ genPlanar left 110 | _ <- trace (show lbind) $ return [] 111 | rbind <- genPlanarZero ++ genPlanar (n - 1 -left) 112 | _ <- trace (show rbind) $ return [] 113 | return $ PBindAppL lbind rbind 114 | 115 | rs = do 116 | left <- [0..n-1] 117 | lbind <- genPlanarZero ++ genPlanar left 118 | rbind <- genPlanarZero ++ genPlanar (n - 1 -left) 119 | return $ PBindAppR lbind rbind 120 | 121 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 122 | | otherwise = [] 123 | -} 124 | {- 125 | instance GenPlanar Z where 126 | genPlanar 0 = [] 127 | genPlanar n = ss ++ as ++ rs where 128 | -- should be mix of intro and consume, not just intro? 129 | res = ss ++ as ++ rs 130 | as = do 131 | left <- [0..n-1] 132 | lbind <- genPlanar left 133 | rbind <- genPlanar (n - 1 -left) 134 | return $ PBindAppL lbind rbind 135 | 136 | rs = do 137 | left <- [0..n-1] 138 | lbind <- genPlanar left 139 | rbind <- genPlanar (n - 1 -left) 140 | return $ PBindAppR lbind rbind 141 | 142 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 143 | | otherwise = [] 144 | 145 | 146 | instance GenPlanar (S Z) where 147 | genPlanar 0 = [PVar] 148 | genPlanar n = ss ++ as ++ rs where 149 | res = ss ++ as ++ rs 150 | as = do 151 | left <- [0..n-1] 152 | lbind <- genPlanar left 153 | rbind <- genPlanar (n - 1 -left) 154 | return $ PBindAppL lbind rbind 155 | 156 | rs = do 157 | left <- [0..n-1] 158 | lbind <- genPlanar left 159 | rbind <- genPlanar (n - 1 -left) 160 | return $ PBindAppR lbind rbind 161 | 162 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 163 | | otherwise = [] 164 | 165 | 166 | instance GenPlanar (S a) where 167 | genPlanar 0 = [] 168 | genPlanar n = ss ++ as ++ rs where 169 | as = do 170 | left <- [0..n-1] 171 | lbind <- genPlanar left 172 | rbind <- genPlanar (n - 1 -left) 173 | return $ PBindAppL lbind rbind 174 | 175 | rs = do 176 | left <- [0..n-1] 177 | lbind <- genPlanar left 178 | rbind <- genPlanar (n - 1 -left) 179 | return $ PBindAppR lbind rbind 180 | 181 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 182 | | otherwise = [] 183 | 184 | instance GenPlanar (L Z) where 185 | genPlanar 0 = [PVarL] 186 | genPlanar n = ss ++ as ++ rs where 187 | as = do 188 | left <- [0..n-1] 189 | lbind <- genPlanar left 190 | rbind <- genPlanar (n - 1 -left) 191 | return $ PBindAppL lbind rbind 192 | 193 | rs = do 194 | left <- [0..n-1] 195 | lbind <- genPlanar left 196 | rbind <- genPlanar (n - 1 -left) 197 | return $ PBindAppR lbind rbind 198 | 199 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 200 | | otherwise = [] 201 | 202 | instance GenPlanar (L a) where 203 | genPlanar 0 = [] 204 | genPlanar n = ss ++ as ++ rs where 205 | as = do 206 | left <- [0..n-1] 207 | lbind <- genPlanar left 208 | rbind <- genPlanar (n - 1 -left) 209 | return $ PBindAppL lbind rbind 210 | 211 | rs = do 212 | left <- [0..n-1] 213 | lbind <- genPlanar left 214 | rbind <- genPlanar (n - 1 -left) 215 | return $ PBindAppR lbind rbind 216 | 217 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 218 | | otherwise = [] 219 | 220 | instance GenPlanar (R Z) where 221 | genPlanar 0 = [] 222 | genPlanar n = ss ++ as ++ rs where 223 | as = do 224 | left <- [0..n-1] 225 | lbind <- genPlanar left 226 | rbind <- genPlanar (n - 1 -left) 227 | return $ PBindAppL lbind rbind 228 | 229 | rs = do 230 | left <- [0..n-1] 231 | lbind <- genPlanar left 232 | rbind <- genPlanar (n - 1 -left) 233 | return $ PBindAppR lbind rbind 234 | 235 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 236 | | otherwise = [] 237 | 238 | instance GenPlanar (R a) where 239 | genPlanar 0 = [] 240 | genPlanar n = ss ++ as ++ rs where 241 | as = do 242 | left <- [0..n-1] 243 | lbind <- genPlanar left 244 | rbind <- genPlanar (n - 1 -left) 245 | return $ PBindAppL lbind rbind 246 | 247 | rs = do 248 | left <- [0..n] 249 | lbind <- genPlanar left 250 | rbind <- genPlanar (n - 1 -left) 251 | return $ PBindAppR lbind rbind 252 | 253 | ss | n > 0 = fmap PBindNest (genPlanar (n - 1)) 254 | | otherwise = [] 255 | -} 256 | gpz :: Int -> [Planar Z] 257 | gpz = genPlanar 258 | 259 | gps :: Int -> [Planar (S Z)] 260 | gps = genPlanar 261 | 262 | gpss :: Int -> [Planar (S (S Z))] 263 | gpss = genPlanar 264 | 265 | lgpz :: Int -> Int 266 | lgpz = length . gpz 267 | 268 | sgpz = mapM_ putStrLn . map showPlanar . gpz 269 | 270 | showPlanar :: Planar Z -> String 271 | showPlanar x = snd $ go (['a'..'z'],['!','!','!']) x 272 | where 273 | go :: ([Char],[Char])-> Planar a -> (([Char],[Char]),String) -- two lists. name store + name used store 274 | go ((n:names),(v:vnames)) p = 275 | case p of 276 | PVar -> ((n:names,vnames),v:[]) 277 | PBindAppL x y -> 278 | let (n1,x1) = go (names,(n:v:vnames)) x 279 | in fmap (\s-> ('\\':n:".") ++ "("++x1++")("++s++")") (go n1 y) 280 | PBindAppR x y -> 281 | let (n1,x1) = go (names,(n:v:vnames)) x 282 | in fmap (\s-> ('\\':n:".") ++ "("++s++")("++x1++")") (go n1 y) 283 | PBindNest x -> fmap (('\\':n:".") ++) $ go (names,n:v:vnames) x 284 | 285 | --need only half the binds 286 | -- need to have left/right because can only use a var in one. BUT can only use vars in right that don't cross left, ugh. -------------------------------------------------------------------------------- /contexts/Cxt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, GADTs, ScopedTypeVariables, RankNTypes #-} 2 | module Cxt where 3 | 4 | -- This module plays with explicit context representations of fully typed terms. 5 | -- The terms have both hoas and nested debruijn binding forms, which may be mixed freely. 6 | -- closed terms form a restricted monad, and open terms a module over that monad. 7 | -- abst . interp (aka reduce) gives normalization by evaluation for closed terms 8 | -- and normalize gives normalization for open terms. 9 | 10 | -- ideas include extending this to handle e.g. region effects or linear structures in the context 11 | -- or to handling typeclasses or other structures in the context. 12 | 13 | -- also, we can attempt to look at the relationship between the hoas and debruijn formulations 14 | -- and demonstrate their equivalence via yoneda. 15 | 16 | -- finally, we can try to turn our contexts into "telescopes" and capture dependent type theory. 17 | 18 | data Type = TyPair Type Type | TyInt | TyArr Type Type | TyUnit 19 | 20 | data Void 21 | 22 | type family Repr t where 23 | Repr TyInt = Int 24 | Repr (TyPair a b) = (Repr a, Repr b) 25 | Repr (TyArr a b) = Repr a -> Repr b 26 | Repr TyUnit = () 27 | 28 | data Cxt = CCons Type Cxt | CNil 29 | 30 | data Term cxt a where 31 | -- common elements 32 | TmPure :: Repr a -> Term cxt a 33 | App :: Term cxt (TyArr a b) -> Term cxt a -> Term cxt b 34 | 35 | -- hoas 36 | 37 | -- Lam represents _admissible_ terms, which includes "exotic" ones only definable in the metalogic. 38 | Lam :: (Term cxt a -> Term cxt b) -> Term cxt (TyArr a b) 39 | 40 | -- PLam internalizes parametricity and only represents _derivable_ terms -- ones that are admissiable in any extension of the context. These correspond to terms that are derivable directly in the target language. 41 | PLam :: (forall c. Term (CCons c cxt) a -> Term (CCons c cxt) b) -> Term cxt (TyArr a b) 42 | 43 | -- Nested syntax formulation 44 | Var :: Term (CCons a cxt) a 45 | Abs :: Term (CCons a cxt) b -> Term cxt (TyArr a b) 46 | Weaken :: Term cxt a -> Term (CCons b cxt) a 47 | 48 | -- primitives 49 | TmPlus :: Term cxt TyInt -> Term cxt TyInt -> Term cxt TyInt 50 | 51 | db2hoas :: Term cxt a -> Term cxt a 52 | db2hoas (Abs body) = Lam $ \x -> subst x body 53 | --TODO etc 54 | 55 | hoas2db :: Term cxt a -> Term cxt a 56 | hoas2db (Lam f) = Abs (foo f Var) 57 | 58 | foo :: (Term cxt a1 -> Term cxt b) 59 | -> Term (CCons a1 cxt) a1 -> Term (CCons a1 cxt) b 60 | foo f x = Weaken $ _ f x -- need to lift all vars in f. 61 | 62 | 63 | -- closed terms form a (restricted) monad 64 | cpure :: Repr a -> Term CNil a 65 | cpure = TmPure 66 | 67 | cbind :: Term CNil a -> (Repr a -> Term CNil b) -> Term CNil b 68 | cbind x f = App (Lam $ f . interp) x 69 | 70 | -- mapCxt witnesses that context are (pro)functorial with regards to weakening 71 | mapCxt:: (forall b. Term cxt1 b -> Term cxt b) 72 | -> (forall b. Term cxt b -> Term cxt1 b) 73 | -> (forall c. Term (CCons c cxt1) b -> Term (CCons c cxt) b) 74 | mapCxt f i (TmPure x) = (TmPure x) 75 | mapCxt f i (App x y) = App (mapCxt f i x) (mapCxt f i y) 76 | mapCxt f i (TmPlus x y) = TmPlus (mapCxt f i x) (mapCxt f i y) 77 | mapCxt f i (Weaken b) = Weaken (f b) 78 | mapCxt f i (Abs b) = Abs ((mapCxt (mapCxt f i) (mapCxt i f)) b) 79 | mapCxt f i (Lam g) = Lam (mapCxt f i . g . mapCxt i f) 80 | mapCxt f i (PLam g) = PLam (mapCxt (mapCxt f i) (mapCxt i f) 81 | . g 82 | . mapCxt (mapCxt i f) (mapCxt f i)) 83 | mapCxt f i Var = Var 84 | 85 | -- abst sends host terms to embedded terms, and interp interprets embedded terms, in the empty context, to host terms in an entirely type safe way. 86 | abst :: Repr a -> Term cxt a 87 | abst = TmPure 88 | 89 | interp :: forall a. Term CNil a -> Repr a 90 | interp (TmPure x) = x 91 | interp (App f x) = (interp f) (interp x) 92 | interp (TmPlus x y) = interp x + interp y 93 | interp (Lam f) = interp . f . abst 94 | interp (PLam f) = interp . contractCxt . f . abst 95 | interp (Abs body) = \x -> interp $ subst (abst x) body 96 | 97 | 98 | -- Interpretation of parametric terms proceeds by taking their results, which are derivable in any context, and instantiating them to our specific context, by chosing the context extension to be Unit, and the contracting away the unit. 99 | contractCxt :: Term (CCons TyUnit cxt) a -> Term cxt a 100 | contractCxt (TmPure x) = TmPure x 101 | contractCxt (App f x) = App (contractCxt f) (contractCxt x) 102 | contractCxt (TmPlus x y) = TmPlus (contractCxt x) (contractCxt y) 103 | contractCxt (Lam f) = Lam (contractCxt . f . Weaken) 104 | contractCxt Var = TmPure () 105 | contractCxt (Weaken x) = x 106 | contractCxt (Abs b) = Abs (mapCxt contractCxt Weaken b) 107 | contractCxt (PLam f) = PLam (mapCxt contractCxt Weaken . f . mapCxt Weaken contractCxt) 108 | 109 | -- open terms form a module over a monad, with subst as the action of the module. 110 | subst :: Term cxt a -> Term (CCons a cxt) b -> Term cxt b 111 | subst tm (TmPure x) = (TmPure x) 112 | subst tm (App f x) = App (subst tm f) (subst tm x) 113 | subst tm (TmPlus x y) = TmPlus (subst tm x) (subst tm y) 114 | subst tm (Lam f) = Lam (subst tm . f . Weaken) 115 | subst tm (PLam f) = PLam (mapCxt (subst tm) Weaken . f . mapCxt Weaken (subst tm)) 116 | subst tm Var = tm 117 | subst tm (Abs body) = Abs (mapCxt (subst tm) Weaken body) 118 | subst tm (Weaken x) = x 119 | 120 | -- abst and interp provide normalization by evaluation in the empty context. 121 | reduce :: Term CNil a -> Term CNil a 122 | reduce x = abst . interp $ x 123 | 124 | -- Normalize brings open terms to whnf. 125 | -- Other strategies are possible based on the choice of _when_ to evaluate _what_ in the case of application. 126 | normalize :: Term cxt a -> Term cxt a 127 | normalize (TmPure x) = (TmPure x) 128 | normalize Var = Var 129 | normalize (Abs b) = Abs (normalize b) 130 | normalize (Weaken b) = Weaken (normalize b) 131 | normalize (Lam f) = (Lam f) 132 | normalize (PLam f) = (PLam f) 133 | normalize (App x y) = case (normalize x, normalize y) of 134 | (TmPure x, TmPure y) -> TmPure $ x y 135 | (Abs b, x) -> normalize $ subst x b 136 | (Lam f, x) -> normalize $ f x 137 | (PLam f, x) -> normalize . contractCxt $ f (Weaken x) 138 | (x,y) -> App x y 139 | normalize (TmPlus x y) = case (normalize x, normalize y) of 140 | (TmPure x, TmPure y) -> TmPure $ x + y 141 | (x,y) -> TmPlus x y 142 | 143 | 144 | -- We can sort of go from hoas to debruijn and back as per atkey, lindley, yallop: http://bentnib.org/unembedding.html 145 | -- relevant cases sketched below. 146 | -- note that PLam makes hoas2db easy, but going from db to hoas via PLam is subtle. 147 | 148 | db2hoas :: Term cxt a -> Term cxt a 149 | db2hoas (Abs b) = Lam $ \x -> subst x b 150 | -- challenge : write this with PLam. 151 | -- this doesn't quite work: PLam $ \x -> subst x (mapCxt Weaken _ b) 152 | 153 | hoas2db :: Term cxt a -> Term cxt a 154 | hoas2db (PLam f) = Abs $ f Var 155 | -- note that this appropriately doesn't work with Lam proper, since it is "too big" 156 | 157 | -- This all should be relatable to yoneda. 158 | 159 | -- examples 160 | 161 | 162 | tm_id :: Term CNil (TyArr TyInt TyInt) 163 | tm_id = Lam $ \x -> x 164 | 165 | tm_pid :: Term CNil (TyArr TyInt TyInt) 166 | tm_pid = PLam $ \x -> x 167 | 168 | tm_polyid :: Term CNil (TyArr a TyInt) 169 | tm_polyid = PLam $ \x -> (TmPure 12) 170 | 171 | tm_admissible :: Term CNil (TyArr TyInt TyInt) 172 | tm_admissible = Lam $ \x -> (abst . (+1) . interp) x 173 | 174 | --Can't write this with PLam. 175 | {- 176 | atm_not_derivable :: Term CNil (TyArr TyInt TyInt) 177 | atm_not_derivable = PLam $ \x -> abst . (+(1::Int)) $ interp (contractCxt x) 178 | -} 179 | 180 | -- gah! does not rule out exotic admissables at all! Just rule out derivables. 181 | tm_should_not_derivable :: Term CNil (TyArr TyInt TyInt) 182 | tm_should_not_derivable = PLam $ \x -> case x of (App _ _) -> TmPure 12; _ -> x 183 | 184 | 185 | 186 | tm_k :: Term CNil (TyArr TyInt (TyArr TyInt TyInt)) 187 | tm_k = Lam $ \x -> Lam $ \_y -> x 188 | 189 | tm_pk :: Term CNil (TyArr TyInt (TyArr TyInt TyInt)) 190 | tm_pk = PLam $ \x -> Lam $ \_y -> x 191 | 192 | tm_flip :: Term CNil (TyArr (TyArr a (TyArr b c)) (TyArr b (TyArr a c))) 193 | tm_flip = Lam $ \f -> Lam $ \x -> Lam $ \y -> App (App f y) x 194 | 195 | tm_s :: Term CNil (TyArr (TyArr TyInt (TyArr TyInt TyInt)) (TyArr (TyArr TyInt TyInt) (TyArr TyInt TyInt))) 196 | tm_s = Lam $ \f -> Lam $ \g -> Lam $ \x -> 197 | App 198 | (App f x) 199 | (App g x) 200 | 201 | 202 | tm_id2 :: Term CNil (TyArr TyInt TyInt) 203 | tm_id2 = Abs Var 204 | 205 | tm_k2 :: Term CNil (TyArr TyInt (TyArr TyInt TyInt)) 206 | tm_k2 = Abs (Abs (Weaken Var)) 207 | 208 | tm_flip2 :: Term CNil (TyArr (TyArr a (TyArr b c)) (TyArr b (TyArr a c))) 209 | tm_flip2 = Abs (Abs (Abs (App (App (Weaken . Weaken $ Var) Var) (Weaken Var)))) 210 | 211 | tm_cons :: Term CNil (TyArr TyInt (TyArr TyInt (TyPair TyInt TyInt))) 212 | tm_cons = Lam $ \x -> Lam $ \y -> TmPure (interp x, interp y) 213 | 214 | tm_fst :: Term CNil (TyArr (TyPair TyInt TyInt) TyInt) 215 | tm_fst = Lam $ \x -> case interp x of (a,b) -> TmPure a 216 | 217 | tm_eta_fst = Abs (App (Weaken tm_fst) Var) 218 | 219 | test = interp tm_s (*) (negate) 12 220 | 221 | test2 = interp (App tm_s (App tm_flip tm_pk)) (+5) 12 222 | 223 | test3 = subst (Weaken (cpure 12 :: Term CNil TyInt)) (TmPlus Var (Weaken Var)) 224 | 225 | test4 = interp $ (App tm_fst (App (App tm_cons (TmPure 12)) (TmPure 22))) 226 | 227 | test5 = interp tm_eta_fst (23,45) 228 | 229 | 230 | -- category/arrow playground 231 | 232 | tmId :: Term (CCons a CNil) a 233 | tmId = Var 234 | -------------------------------------------------------------------------------- /mltt/mltt.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require racket/match) 3 | 4 | ; value formers 5 | (struct lam (var vt body)) 6 | (struct app (fun arg)) 7 | ; primitives 8 | (struct prim (env typ body)) 9 | ;;TODO new-prim alias with empty env. 10 | ; dependency 11 | (struct lam-pi (var vt body)) 12 | (struct sigma (val vt snd)) 13 | 14 | ; type formers 15 | (struct type-fun (dom codom)) 16 | ; one basic type 17 | (define (type-unit) 'type-unit) 18 | ; dependency 19 | (struct type-pi (var dom codom)) 20 | (struct type-sig (var dom codom)) 21 | (define (type-type) 'type) ;; inconsistent! 22 | 23 | (define (cons-env nm typ val env) 24 | (cons (cons nm (cons typ val)) env)) 25 | 26 | (define (find-env nm env) 27 | (match (assoc nm env) 28 | [(cons a b) b] 29 | [_ #f])) 30 | 31 | (define (type? env t) 32 | (match t 33 | [(type-fun a b) (and (type? env a) (type? env b))] 34 | ['type-unit #t] 35 | 36 | [(type-pi var a b) (and (type? env a) (type? (cons-env var a #f env) b))] 37 | [(type-sig val a b) (and (type? env a) (type? (cons-env val a #f env) b))] 38 | ['type #t] 39 | [_ (type?-additional env t)] 40 | )) 41 | 42 | (define (hasType? env x t) 43 | (match x 44 | [(app (lam fvar vt body) arg) 45 | (and (hasType? env arg vt) 46 | (hasType? (cons-env fvar vt arg env) body t))] 47 | [(prim primEnv typ body) (eqType? env typ t)] 48 | 49 | ;dependency 50 | [(app (lam-pi fvar vt body) arg) 51 | (and (hasType? env arg vt) 52 | (hasType? (cons-env fvar vt arg env) body t))] 53 | [(var vname) #:when (symbol? vname) 54 | (eqType? env t (car (find-env vname env)))] 55 | [_ (match t 56 | [(type-fun a b) 57 | (match x 58 | [(lam y yt z) (and (eqType? env yt a) 59 | (hasType? (cons-env y a #f env) z b))])] 60 | ['type-unit (null? x)] 61 | 62 | ;; todo do I need to substitute in the b? what? 63 | ;; todo use beta-eq? how? 64 | [(type-pi fvar a b) 65 | (match x 66 | [(lam-pi y yt z) (and (eqType? env yt a) (eq? fvar y) 67 | (hasType? (cons-env y a #f env) z (reduce (cons-env y a #f env) b)) 68 | )])] 69 | [(type-sig fvar a b) 70 | (match x 71 | [(sigma y yt z) (and (eqType? env yt a) (hasType? y a) 72 | (hasType? (cons-env fvar a y) (reduce b)))])] 73 | [_ (hasType?-additional env x t)] 74 | )] 75 | )) 76 | 77 | ; strict 78 | ;;TODO delete envs from everywhere... 79 | ;;OR pack into a primEnv if you hit a prim, and otherwise don't subst. 80 | ;; i.e. reducing a prim in an env just packs in the env.. 81 | (define (reduce env body) 82 | (match body 83 | [(var vname) #:when (symbol? vname) (match (find-env vname env) [(cons a b) b] [_ body])] 84 | [(app (lam var vt b) arg) (reduce env (subst env var (reduce env arg) b))] ;(reduce (cons-env var vt (reduce env arg) env) b)] 85 | [(app (lam-pi var vt b) arg) (reduce env (subst env var (reduce env arg) b))] ;(reduce (cons-env var vt (reduce env arg) env) b)] 86 | [(app (prim primEnv typ b) arg) (reduce env (b primEnv (reduce env arg)))] 87 | [(app fun arg) (if (symbol? fun) 88 | (match (find-env fun env) [(cons a f) (reduce env (app f arg))] [_ body]) 89 | (reduce env (app (reduce env fun) arg)))] 90 | [_ body] ;;(reduce-additional body)] 91 | )) 92 | 93 | (define (subst env v arg body) 94 | (reduce env (match body 95 | [(type-fun a b) (type-fun (subst env v arg a) (subst env v arg b))] 96 | [(type-pi var a b) (type-pi var (subst env v arg a) (subst env v arg b))] 97 | 98 | [(var vname) #:when (eq? vname v) arg] 99 | [(var vname) #:when (symbol? vname) vname] 100 | 101 | ;; this does not suffice to avoid capture -- what if we're subsituting something that is in the free vars of x? 102 | ;; we'll need to rename... 103 | [(lam var vt b) (lam var vt (if (eq? var v) b (subst env v arg b)))] 104 | [(lam-pi var vt b) (lam-pi var vt (if (eq? var v) b (subst env v arg b)))] 105 | [(app f a) (reduce env (app (subst v arg f) (subst env v arg a)))] 106 | [(prim primEnv typ b) (prim (cons-env v #f arg primEnv) typ b)] 107 | 108 | [_ (subst-additional env v arg body)] 109 | ))) 110 | ;; extensions 111 | 112 | (define type-judgments '()) 113 | (define (type?-additional env t) 114 | (define (iter lst) 115 | (match lst 116 | [(list-rest p ps) (if (p env t) #t (iter ps))] 117 | [_ #f] 118 | )) 119 | (iter type-judgments)) 120 | 121 | (define hasType-judgments '()) 122 | (define (hasType?-additional env x t) 123 | (define (iter lst) 124 | (match lst 125 | [(list-rest p ps) (if (p env x t) #t (iter ps))] 126 | [_ #f] 127 | )) 128 | (iter hasType-judgments)) 129 | 130 | (define subst-rules '()) 131 | (define (subst-additional env v arg body) 132 | (foldl (lambda (f acc) 133 | (f env v arg acc)) 134 | body 135 | subst-rules 136 | )) 137 | 138 | (define reduce-rules '()) 139 | (define (reduce-additional body) 140 | (foldl (lambda (f acc) 141 | (f acc)) 142 | body 143 | reduce-rules 144 | )) 145 | 146 | (define (new-form type-judgment hasType-judgment subst-fun reduce-fun) 147 | (set! type-judgments (cons type-judgment type-judgments)) 148 | (set! hasType-judgments (cons hasType-judgment hasType-judgments)) 149 | (set! subst-rules (cons subst-fun subst-rules)) 150 | (set! reduce-rules (cons reduce-fun reduce-rules))) 151 | 152 | (struct type-and (x y)) 153 | (define and-intro 154 | (lam-pi 'a (type-type) (lam-pi 'b (type-type) 155 | (prim '() 156 | (type-fun 'a (type-fun 'b (type-and 'a 'b))) 157 | (lambda (a) (prim (type-fun 'b (type-and 'a 'b)) 158 | (lambda (b) (cons a b)))))))) 159 | (define and-elim-fst 160 | (lam-pi 'a (type-type) (lam-pi 'b (type-type) (prim '() (type-fun (type-and 'a 'b) 'a) 161 | (lambda (env x) (car x)))))) 162 | (define and-elim-snd 163 | (lam-pi 'a (type-type) (lam-pi 'b (type-type) (prim '() (type-fun (type-and 'a 'b) 'a) 164 | (lambda (env x) (cdr x)))))) 165 | (new-form 166 | (lambda (env t) 167 | (match t 168 | [(type-and a b) (and (type? env a) (type? env b))] 169 | [_ #f])) 170 | (lambda (env x t) 171 | (match t 172 | [(type-and a b) 173 | (match x 174 | [(cons y z) (and (hasType? env y a) 175 | (hasType? env z b))])] 176 | [_ #f])) 177 | (lambda (env v arg x) 178 | (match x 179 | [(cons a b) (cons (subst env v arg a) (subst env v arg b))] 180 | [_ x])) 181 | ;; todo substitution in types 182 | (lambda (x) x)) 183 | 184 | (struct type-or (x y)) 185 | (define or-intro-left 186 | (lam-pi 'a (type-type) (lam-pi 'b (type-type) 187 | (prim '() (type-fun 'a (type-or 'a 'b)) 188 | (lambda (env x) (cons 'l x)))))) 189 | (define or-intro-right 190 | (lam-pi 'a (type-type) (lam-pi 'b (type-type) 191 | (prim '() (type-fun 'b (type-or 'a 'b)) 192 | (lambda (env x) (cons 'r x)))))) 193 | 194 | (define or-elim 195 | (lam-pi 'a (type-type) 196 | (lam-pi 'b (type-type) 197 | (lam-pi 'c (type-type) 198 | (lam 'f (type-fun 'a 'c) 199 | (lam 'g (type-fun 'b 'c) 200 | (prim '() (type-fun (type-or 'a 'b) 'c) 201 | (lambda (env x) (if (eq? (car x) 'l) 202 | (app (cdr (find-env 'f env)) (cdr x)) 203 | (app (cdr (find-env 'g env)) (cdr x))))))))))) 204 | (new-form 205 | (lambda (env t) 206 | (match t 207 | [(type-or a b) (and (type? env a) (type? env b))] 208 | [_ #f])) 209 | (lambda (env x t) 210 | (match t 211 | [(type-or a b) 212 | (match x 213 | [(cons 'l y) (hasType? env y a)] 214 | [(cons 'r z) (hasType? env z b)])] 215 | [_ #f])) 216 | (lambda (env v arg x) 217 | (match x 218 | [(list 'l a) ('l (subst env v arg a))] 219 | [(list 'r a) ('r (subst env v arg a))] 220 | [_ x])) 221 | (lambda (x) x)) 222 | 223 | (define (type-nat) 'type-nat) 224 | (new-form 225 | (lambda (env t) (eqType? t 'type-nat)) 226 | (lambda (env x t) 227 | (and (eqType? t 'type-nat) (integer? x) (>= x 0))) 228 | (lambda (env v arg x) x) 229 | (lambda (x) x)) 230 | 231 | (define (eqType? env t1 t2) (eq? t1 t2)) 232 | (define (eqVal? env typ v1 v2) (eq? v1 v2)) 233 | 234 | (define id-nat (lam 'x (type-nat) 'x)) 235 | (hasType? '() id-nat (type-fun (type-nat) (type-nat))) 236 | ;(reduce '() (app id-nat 5)) 237 | 238 | (define id-forall (lam-pi 'x (type-type) (lam 'y 'x 'y))) 239 | (hasType? '() id-forall (type-pi 'x (type-type) (type-fun 'x 'x))) 240 | ;(reduce '() (app (app id-forall (type-nat)) 5)) 241 | 242 | (define apps 243 | (lambda (fun . args) 244 | (foldl 245 | (lambda (arg acc) (app acc arg)) 246 | fun 247 | args))) 248 | 249 | (define and-intro-test (apps and-intro (type-nat) (type-nat) 2 4)) 250 | ;(reduce '() and-intro-test) 251 | 252 | (define and-elim-test (apps and-elim-fst (type-nat) (type-nat) and-intro-test)) 253 | ;(reduce '() and-elim-test) 254 | 255 | (define or-intro-test (apps or-intro-left (type-nat) (type-unit) 23)) 256 | (reduce '() or-intro-test) 257 | 258 | (define or-elim-test (apps or-elim (type-nat) (type-unit) (type-nat) 259 | (lam 'x (type-nat) 'x) 260 | (lam 'y (type-unit) 15) 261 | or-intro-test)) 262 | (reduce '() or-elim-test) 263 | 264 | (define or-elim-test2 (apps or-elim (type-nat) (type-unit) (type-nat) 265 | (lam 'x (type-nat) 'x) 266 | (lam 'y (type-unit) 15) 267 | (cons 'r '()))) 268 | (reduce '() or-elim-test2) 269 | 270 | 271 | ;; todo -- simplicial equality 272 | ;;todo -- any equality, simplicial types 273 | ;;todo -- example with bools -------------------------------------------------------------------------------- /contexts/Lambek.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, GADTs, ScopedTypeVariables, RankNTypes, PolyKinds, StandaloneDeriving, FlexibleContexts, UndecidableInstances #-} 2 | 3 | module Lambek( 4 | ) where 5 | import Prelude hiding ((.)) 6 | import Control.Category as C 7 | 8 | import Debug.Trace 9 | import System.IO.Unsafe 10 | import Control.Concurrent 11 | 12 | {- 13 | Explorations in lambda terms as elements of presheaves, or generally as slices in a category of contexts. 14 | -} 15 | 16 | -- We begin with objects of cartesian closed categories over some base index of types. 17 | data TCart b = TUnit | TPair (TCart b) (TCart b) | TExp (TCart b) (TCart b) | TBase b 18 | 19 | -- Base indices are mapped to types via Repr 20 | type family Repr a :: * 21 | 22 | -- Cartesian objects over the base are mapped to types via CartRepr 23 | type family CartRepr a :: * 24 | 25 | -- Ty is used to wrap polykinded things up in kind * 26 | data Ty a 27 | 28 | type instance CartRepr (Ty (TBase a)) = Repr (Ty a) 29 | type instance CartRepr (Ty (TPair a b)) = (CartRepr (Ty a), CartRepr (Ty b)) 30 | type instance CartRepr (Ty (TExp a b)) = CartRepr (Ty a) -> CartRepr (Ty b) 31 | type instance CartRepr (Ty TUnit) = () 32 | 33 | data ABase = AInt | AString | ADouble 34 | 35 | type instance Repr (Ty AInt) = Int 36 | type instance Repr (Ty AString) = String 37 | type instance Repr (Ty ADouble) = Double 38 | 39 | 40 | -- A Context b is a list of cartesian objects over base index b 41 | data Cxt b = CCons (TCart b) (Cxt b) | CNil 42 | 43 | 44 | -- We define a category of contexts by providing the morphisms as a GADT 45 | -- These morphisms can also be read in logical terms: 46 | -- 47 | -- CxtArr a b is a judgment a |- b 48 | -- when b contains multiple terms this is a sequent 49 | -- 50 | -- CxtArr a b -> CxtArr c d is an inference rule 51 | -- a |- b 52 | -- --------- 53 | -- c |- d 54 | 55 | -- This category also can be read topologically as having a simplicial structure induced by face and degeneracy maps. 56 | 57 | data CxtArr :: Cxt a -> Cxt a -> * where 58 | -- To be a category we must have id and composition 59 | CXAId :: CxtArr a a 60 | CXACompose :: CxtArr b c -> CxtArr a b -> CxtArr a c 61 | 62 | -- We have a terminal object 63 | CXANil :: CxtArr a CNil 64 | 65 | -- We have face maps 66 | CXAWeaken :: CxtArr (CCons a cxt) cxt 67 | 68 | -- We have degeneracy maps 69 | CXADiag :: CxtArr (CCons a cxt) (CCons a (CCons a cxt)) 70 | 71 | -- We have additional "degeneracy" maps given by every inhabitant of our underlying terms 72 | CXAAtom :: CartRepr (Ty a) -> CxtArr cxt (CCons a cxt) 73 | 74 | -- We also have a cartesian structure 75 | CXAPair :: CxtArr cxt (CCons a c2) -> CxtArr cxt (CCons b c2) -> CxtArr cxt (CCons (TPair a b) c2) 76 | CXAPairProj1 :: CxtArr (CCons (TPair a b) cxt) (CCons a cxt) 77 | CXAPairProj2 :: CxtArr (CCons (TPair a b) cxt) (CCons b cxt) 78 | 79 | -- And a closed structure (aka uncurry and eval) 80 | CXAEval :: CxtArr (CCons (TPair (TExp a b) a) cxt) (CCons b cxt) 81 | CXAAbs :: CxtArr (CCons a cxt) (CCons b c) -> CxtArr cxt (CCons (TExp a b) c) 82 | 83 | -- We also add directly the internal hom in a slice category, which _also_ should give a closed structure. 84 | CXALam :: (forall c. CxtArr c cxt -> CxtArr c (CCons a c2) -> CxtArr c (CCons b c2)) -> CxtArr cxt (CCons (TExp a b) c2) 85 | 86 | -- Todo, some functoriality of contextual operations? i.e. context morphisms should be stable under extension. 87 | 88 | -- A Hacky Show Instance 89 | instance Show (CxtArr a b) where 90 | show CXAId = "CXAId" 91 | show (CXACompose g f) = show g ++ " . " ++ show f 92 | show CXANil = "CXANil" 93 | show (CXAAtom x) = "CXAAtom" 94 | show CXAWeaken = "CXAWeaken" 95 | show CXAEval = "CXAEval" 96 | show (CXALam f) = "CXALam" 97 | show (CXAAbs f) = "CXAAbs (" ++ show f ++ ")" 98 | show (CXAPair f g) = "(" ++ show f ++ ", " ++ show g ++ ")" 99 | show CXAPairProj1 = "CXAPairProj1" 100 | show CXAPairProj2 = "CXAPairProj2" 101 | show CXADiag = "CXADiag" 102 | 103 | -- We give axioms on our category as conditions on coherence of composition 104 | -- As per section 10 of http://arxiv.org/pdf/math/9911073.pdf 105 | cxaCompose :: CxtArr b c -> CxtArr a b -> CxtArr a c 106 | cxaCompose CXAId f = f 107 | cxaCompose f CXAId = f 108 | cxaCompose CXANil _ = CXANil 109 | cxaCompose CXAEval (CXAPair (CXALam f) g) = f CXAId g 110 | cxaCompose CXAPairProj1 (CXAPair a b) = a 111 | cxaCompose CXAPairProj2 (CXAPair a b) = b 112 | 113 | -- TODO: further rules for weaken or diag, in interaction with eval in particular? 114 | cxaCompose CXAWeaken CXADiag = CXAId 115 | 116 | cxaCompose h (CXACompose g f) = CXACompose (cxaCompose h g) f 117 | 118 | -- with this we can get stuck. ideally we'll never hit it. 119 | cxaCompose f g = CXACompose f g 120 | 121 | 122 | -- CxtArr indeed gives a category 123 | instance Category CxtArr where 124 | id = CXAId 125 | (.) = cxaCompose 126 | 127 | -- Terms here are elements or fibers of presheaves. Alternately, terms of type A are elements of the slice category over the context containing only A. 128 | -- That is, a term is a sequent judgment which corresponds to a natural judgement (has only one consequent). 129 | data Term cxt a where 130 | Term :: CxtArr cxt (CCons a CNil) -> Term cxt a 131 | -- An experiment in progress 132 | -- LamTerm :: (forall c. CxtArr c cxt -> CxtArr c (CCons d cxt) -> CxtArr c (CCons b cxt)) -> Term cxt (TExp d b) 133 | 134 | instance Show (Term cxt a) where 135 | show (Term x) = show x 136 | -- show (LamTerm f) = "LamTerm" 137 | 138 | unTerm :: Term cxt a -> CxtArr cxt (CCons a CNil) 139 | unTerm (Term x) = x 140 | -- unTerm (LamTerm f) = CXAAbs (f CXAWeaken _) 141 | 142 | -- We can now write lam, app etc over terms just as we would in a typical embedding 143 | 144 | lamTerm :: (forall c. CxtArr c cxt -> Term c a -> Term c b) -> Term cxt (TExp a b) 145 | --lamTerm f = LamTerm (\m x -> unTerm (f m (Term x))) 146 | lamTerm f = Term (CXALam (\m x -> unTerm (f m (Term x)))) 147 | 148 | appTerm :: Term cxt (TExp a b) -> Term cxt a -> Term cxt b 149 | appTerm f x = Term (CXAEval . (CXAPair (unTerm f) (unTerm x))) 150 | 151 | -- in the slice, weaken gives the inverse image along a face 152 | weakenTerm :: Term cxt a -> Term (CCons b cxt) a 153 | weakenTerm = Term . (. CXAWeaken) . unTerm 154 | 155 | -- and abs gives a form of inverse image along a degeneracy? 156 | absTerm :: Term (CCons a cxt) b -> Term cxt (TExp a b) 157 | absTerm = Term . CXAAbs . unTerm 158 | 159 | liftTerm :: Term CNil a -> Term cxt a 160 | liftTerm = Term . (. CXANil) . unTerm 161 | 162 | contractTerm :: Term (CCons a (CCons a cxt)) b -> Term (CCons a cxt) b 163 | contractTerm = Term . (. CXADiag) . unTerm 164 | 165 | varTerm :: Term (CCons a CNil) a 166 | varTerm = Term CXAId 167 | 168 | appArrow :: CxtArr c d -> Term d a -> Term c a 169 | appArrow h (Term g) = Term $ g . h 170 | 171 | 172 | -- Abstraction (in the sense of nbe) is a free operation 173 | abst :: CartRepr (Ty a) -> Term CNil a 174 | abst = Term . CXAAtom 175 | 176 | -- Interpretation does the obvious thing 177 | interp' :: Term CNil a -> CartRepr (Ty a) 178 | interp' (Term (CXAAtom x)) = x 179 | interp' (Term (CXAPair f g)) = (interp (Term f), interp (Term g)) 180 | interp' (Term (CXALam f)) = interp . Term . f CXAId . unTerm . abst 181 | interp' (Term (CXAAbs f)) = interp (Term (CXALam $ \_ x -> f . x)) 182 | 183 | --Again we should never need explicit composition 184 | --interp' (Term (CXACompose f g)) = interp (Term (f . g)) 185 | 186 | -- Here again is a partial experiment 187 | --interp' (LamTerm f) = interp . Term . f CXAId . CXAAtom 188 | --interp' (Term (CXAAbs f)) = interp (LamTerm $ \_ x -> f . x) 189 | 190 | -- Here we wrap interpretation for tracing evaluation 191 | interp :: Term CNil a -> CartRepr (Ty a) 192 | interp x = unsafePerformIO (threadDelay 100000) `seq` traceShow x (interp' x) 193 | 194 | -- And nbe does what we want 195 | nbe :: Term CNil a -> Term CNil a 196 | nbe = abst . interp 197 | 198 | subst :: Term (CCons a cxt) t -> Term cxt a -> Term cxt t 199 | subst = appTerm . absTerm 200 | 201 | -- Substitution gives a module over a relative monad 202 | runit :: Term cxt a -> Term (CCons b cxt) a 203 | runit = weakenTerm 204 | 205 | rmap :: Term cxt (TExp a b) -> Term cxt a -> Term cxt b 206 | rmap = appTerm 207 | 208 | rjoin :: Term (CCons b (CCons b cxt)) a -> Term (CCons b cxt) a 209 | rjoin = contractTerm 210 | 211 | 212 | -- To be done, explore if LamTerm gives proper derivability vs. admissibility rule 213 | -- Todo -- see if we want to distinguish the simplicial structure of contexts from the value stucture? 214 | 215 | 216 | -- Some examples 217 | tmInt :: Int -> Term CNil (TBase AInt) 218 | tmInt i = Term (CXAAtom i) 219 | 220 | lam :: (forall c. Term c a -> Term c b) -> Term cxt (TExp a b) 221 | lam f = lamTerm $ \ h -> f 222 | 223 | lamt :: (forall c. CxtArr c cxt -> Term c a -> Term c b) -> Term cxt (TExp a b) 224 | lamt f = lamTerm f 225 | 226 | tm_id = lam $ \x -> x 227 | 228 | tm_id2 = Term (CXAAbs CXAId) 229 | 230 | tm_k = lam $ \x -> lamTerm $ \g y -> appArrow g x 231 | 232 | tm_s = lamt $ \h f -> lamt $ \h1 g -> lamt $ \h2 x -> appTerm (appTerm (appArrow (h1 . h2) f) x) (appTerm (appArrow h2 g) x) 233 | 234 | tm_comp :: Term cxt (TExp (TExp a1 b) (TExp (TExp a a1) (TExp a b))) 235 | tm_comp = lamt $ \h f -> lamt $ \h1 g -> lamt $ \h2 x -> appTerm (appArrow (h1 . h2) f) (appTerm (appArrow h2 g) x) 236 | 237 | tm_f :: Term CNil (TExp (TExp a b) (TExp a a)) 238 | tm_f = appTerm tm_s tm_k 239 | 240 | 241 | -- Testing the interpreter 242 | test = (interp (tm_id :: Term cxt (TExp (TBase AInt) (TBase AInt)))) $ 12 243 | test2 = (interp (tm_id2 :: Term CNil (TExp (TBase AInt) (TBase AInt)))) $ 12 244 | 245 | itm_f :: (Double -> String) -> (Double -> Double) 246 | itm_f = interp (tm_f :: Term CNil (TExp (TExp (TBase ADouble) (TBase AString)) (TExp (TBase ADouble) (TBase ADouble)))) -- necessary because we don't have injective type families 247 | 248 | -- The above structure can perhaps be treated perhaps as a Category with Attributes where we don't have "real" contexts, but instead can "push" all our contexts [a,b,c] |- d into Nil |- (a,b,c) -> d, as the types don't depend on elements of the context. Introduction of genuine Pi types should screw this possibility up in interesting ways. -------------------------------------------------------------------------------- /hlean/basics.hlean: -------------------------------------------------------------------------------- 1 | import types.int algebra.field hit.set_quotient hit.trunc 2 | open eq sigma sigma.ops equiv is_equiv equiv.ops eq.ops int algebra nat set_quotient is_trunc trunc quotient 3 | 4 | 5 | record prerat : Type := (num : ℤ) (denom : ℕ) 6 | 7 | namespace prerat 8 | 9 | inductive rat_rel : prerat → prerat → Type := 10 | | Rmk : Π (a b : prerat), int.mul (num a) (denom b + int.of_num 1) = int.mul (num b) (denom a + int.of_num 1) → rat_rel a b 11 | 12 | 13 | /- field operations -/ 14 | 15 | definition of_int (i : int) : prerat := prerat.mk i (of_num 0) 16 | 17 | definition zero : prerat := of_int (of_num 0) 18 | 19 | definition one : prerat := of_int (of_num 1) 20 | 21 | definition add (a b : prerat) : prerat := 22 | prerat.mk (num a * (denom b + of_num 1) + num b * (denom a + of_num 1)) 23 | (nat.add 24 | (nat.add 25 | (nat.mul (denom a) (denom b)) 26 | (denom a)) 27 | (denom b)) 28 | 29 | definition mul (a b : prerat) : prerat := 30 | prerat.mk (num a * num b) (nat.add 31 | (nat.add 32 | (nat.mul (denom a) (denom b)) 33 | (denom a)) 34 | (denom b)) 35 | /- 36 | (denom a + 1) * (denom b + 1) - 1 37 | denom a * denom b + denom a + denom b 38 | -/ 39 | 40 | -- why lord 41 | -- ((nat.mul (denom a) (denom b)) + denom a + denom b) 42 | 43 | definition neg (a : prerat) : prerat := 44 | prerat.mk (- num a) (denom a) 45 | 46 | /-TODO have an ordering on the ints so we can give -/ 47 | 48 | /- 49 | definition smul (a : ℤ) (b : prerat) (H : a > 0) : prerat := 50 | prerat.mk (a * num b) (int2nat a H * denom b) 51 | -/ 52 | 53 | 54 | definition rat_rel_refl (a : ℤ) (b : ℕ) : rat_rel (mk a b) (mk a b) := 55 | rat_rel.Rmk (prerat.mk a b) (prerat.mk a b) (refl _) 56 | 57 | theorem of_int_add (a b : ℤ) : rat_rel (of_int (#int a + b)) (add (of_int a) (of_int b)) := 58 | begin 59 | esimp [of_int, add, nat.mul, nat.add, one, zero], 60 | rewrite [int.zero_add, +int.mul_one], 61 | fapply rat_rel_refl 62 | end 63 | 64 | theorem of_int_mul (a b : ℤ) : rat_rel (of_int (#int a * b)) (mul (of_int a) (of_int b)) := 65 | begin 66 | esimp [of_int, add, nat.mul, mul], 67 | rewrite [+nat.zero_add], 68 | fapply rat_rel_refl 69 | end 70 | 71 | theorem of_int_neg (a : ℤ) : rat_rel (of_int (#int -a)) (neg (of_int a)) := 72 | begin 73 | esimp [neg, of_int], 74 | fapply rat_rel_refl 75 | end 76 | 77 | 78 | theorem of_int.inj {a b : ℤ} : rat_rel (of_int a) (of_int b) → a = b := 79 | begin 80 | intros, 81 | cases a_1 with [a,b,p], 82 | generalize p, 83 | clear p, 84 | esimp [denom], 85 | rewrite[zero_add, +mul_one], 86 | intros, 87 | exact p 88 | end 89 | 90 | 91 | --set_option pp.all true 92 | 93 | theorem equiv_zero_of_num_eq_zero {a : prerat} (H : num a = of_num 0) : rat_rel a zero := 94 | rat_rel.Rmk a zero ( 95 | begin 96 | rewrite [H], 97 | esimp [zero, of_int, num], 98 | rewrite[+zero_mul] 99 | end 100 | ) 101 | 102 | theorem num_eq_zero_of_equiv_zero {a : prerat} : rat_rel a zero → num a = 0 := 103 | begin 104 | intros, 105 | cases a_1 with [a,z,p], 106 | generalize p, 107 | clear p, 108 | esimp [of_num], 109 | rewrite [zero_add, zero_mul, mul_one], 110 | intros, 111 | exact p 112 | end 113 | 114 | 115 | lemma halp {x y : nat} : x * y + x + y + (nat.of_num 1) = nat.mul (nat.add x (nat.of_num 1)) (nat.add y (nat.of_num 1)) := 116 | begin 117 | rewrite [nat.mul.right_distrib, *nat.mul.left_distrib, *nat.mul_one, nat.one_mul] 118 | end 119 | 120 | set_option unifier.max_steps 100000 121 | 122 | 123 | theorem add_rel_add {a1 b1 a2 b2 : prerat} (r1 : rat_rel a1 a2) (r2 : rat_rel b1 b2) : rat_rel (add a1 b1) (add a2 b2) := 124 | rat_rel.cases_on r1 (λ a_1 a_2 H1, 125 | rat_rel.cases_on r2 (λ b_1 b_2 H2, 126 | rat_rel.Rmk (add a_1 b_1) (add a_2 b_2) 127 | (calc 128 | num (add a_1 b_1) * of_nat (denom (add a_2 b_2) + 1) 129 | = num (add a_1 b_1) * of_nat (denom a_2 * denom b_2 + denom a_2 + denom b_2 + 1) : by trivial 130 | ... = num (add a_1 b_1) * of_nat ((denom a_2 + 1) * (denom b_2 + 1)) : halp 131 | ... = (num a_1 * (denom b_1 + 1) + num b_1 * (denom a_1 + 1)) * of_nat ((denom a_2 + 1) * (denom b_2 + 1)) : by trivial 132 | --num (add a_2 b_2) * (denom (add a_1 b_1) + 1) : by rewrite [halp] 133 | ) 134 | ) 135 | ) 136 | 137 | /- 138 | begin 139 | cases r1 with [a_1, a_2,H1], 140 | cases r2 with [b_1, b_2,H2], 141 | clear [a1,a2,b1,b2], 142 | apply rat_rel.Rmk, 143 | esimp [add], 144 | rewrite [@halp (denom a_2) (denom b_2)] 145 | --rewrite [*mul.right_distrib, *mul.left_distrib, *mul_one, int.mul.comm], 146 | /-exact ( 147 | calc 148 | (num a_1 * (denom b_1 + 1) + num b_1 * (denom a_1 + 1)) * (denom a_2 * denom b_2 + denom a_2 + denom b_2 + 1) 149 | = (num a_2 * (denom 150 | b_2 + 1) + num b_2 * (denom a_2 + 1)) * (denom a_1 * denom b_1 + denom a_1 + denom b_1 + 1) : by rewrite [mul.right_distrib] 151 | )-/ 152 | end 153 | -/ 154 | 155 | /- 156 | theorem add_equiv_add {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) : 157 | add a1 b1 ≡ add a2 b2 := 158 | calc 159 | (num a1 * denom b1 + num b1 * denom a1) * (denom a2 * denom b2) 160 | = num a1 * denom a2 * denom b1 * denom b2 + num b1 * denom b2 * denom a1 * denom a2 : 161 | by rewrite [mul.right_distrib, *mul.assoc, mul.left_comm (denom b1), 162 | mul.comm (denom b2), *mul.assoc] 163 | ... = num a2 * denom a1 * denom b1 * denom b2 + num b2 * denom b1 * denom a1 * denom a2 : 164 | by rewrite [↑equiv at *, eqv1, eqv2] 165 | ... = (num a2 * denom b2 + num b2 * denom a2) * (denom a1 * denom b1) : 166 | by rewrite [mul.right_distrib, *mul.assoc, *mul.left_comm (denom b2), 167 | *mul.comm (denom b1), *mul.assoc, mul.left_comm (denom a2)] 168 | -/ 169 | 170 | end prerat 171 | 172 | /- 173 | 174 | definition inv : prerat → prerat 175 | | inv (prerat.mk nat.zero d dp) := zero 176 | | inv (prerat.mk (nat.succ n) d dp) := prerat.mk d (nat.succ n) !of_nat_succ_pos 177 | | inv (prerat.mk -[1+n] d dp) := prerat.mk (-d) (nat.succ n) !of_nat_succ_pos 178 | 179 | 180 | theorem inv_zero {d : int} (dp : d > 0) : inv (mk nat.zero d dp) = zero := 181 | begin rewrite [↑inv, ▸*] end 182 | 183 | theorem inv_zero' : inv zero = zero := inv_zero (of_nat_succ_pos nat.zero) 184 | 185 | theorem inv_of_pos {n d : int} (np : n > 0) (dp : d > 0) : inv (mk n d dp) ≡ mk d n np := 186 | obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), 187 | have (#nat n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), 188 | obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, 189 | have d * n = d * nat.succ k, by rewrite [Hn', Hk], 190 | Hn'⁻¹ ▸ (Hk⁻¹ ▸ this) 191 | 192 | theorem inv_neg {n d : int} (np : n > 0) (dp : d > 0) : inv (mk (-n) d dp) ≡ mk (-d) n np := 193 | obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), 194 | have (#nat n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), 195 | obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, 196 | have -d * n = -d * nat.succ k, by rewrite [Hn', Hk], 197 | have H3 : inv (mk -[1+k] d dp) ≡ mk (-d) n np, from this, 198 | have H4 : -[1+k] = -n, from calc 199 | -[1+k] = -(nat.succ k) : rfl 200 | ... = -n : by rewrite [Hk⁻¹, Hn'], 201 | H4 ▸ H3 202 | 203 | theorem inv_of_neg {n d : int} (nn : n < 0) (dp : d > 0) : 204 | inv (mk n d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn) := 205 | have inv (mk (-(-n)) d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn), 206 | from inv_neg (neg_pos_of_neg nn) dp, 207 | !neg_neg ▸ this 208 | 209 | theorem of_int.inj {a b : ℤ} : of_int a ≡ of_int b → a = b := 210 | by rewrite [↑of_int, ↑equiv, *mul_one]; intros; assumption 211 | 212 | -/ 213 | 214 | 215 | /- 216 | the rationals 217 | -/ 218 | 219 | definition rat_rel_trunc (a : prerat) (b : prerat) : hprop := trunctype.mk (trunc -1 (prerat.rat_rel a b)) _ 220 | 221 | definition rat := set_quotient rat_rel_trunc 222 | notation `ℚ` := rat 223 | 224 | definition of_int [coercion] (i : ℤ) : ℚ := set_quotient.class_of rat_rel_trunc (prerat.of_int i) 225 | definition of_nat [coercion] (n : ℕ) : ℚ := n 226 | definition of_num [coercion] [reducible] (n : num) : ℚ := n 227 | definition lift0 (p : prerat) : ℚ := set_quotient.class_of rat_rel_trunc p 228 | 229 | definition prerat_refl (a : prerat) : rat_rel_trunc a a := tr (prerat.rat_rel.Rmk a a (refl _)) 230 | definition lift1 {A : Type} [hs : is_hset A] (f : prerat → A) (coh : Π (p q : prerat), rat_rel_trunc p q -> f p = f q) (r : rat) : A := 231 | set_quotient.elim_on rat_rel_trunc r f coh 232 | 233 | /- 234 | lemma ext_c {A B C : Type} {rel_a : A → A → hprop} {rel_b : B → B → hprop} (f : A -> B -> C) (c : Π (a1 a2 : A) (b1 b2 : B) , rel_a a1 a2 → rel_b b1 b2 → f a1 b1 = f a2 b2) : Π (a1 a2 : A), rel_a a1 a2 → f a1 = f a2 := 235 | λ (a1 a2 : A) (myrel : rel_a a1 a2), _ (λ (b : B), (c a1 a2 b b myrel sorry)) 236 | -/ 237 | 238 | set_option formatter.hide_full_terms false 239 | 240 | definition lift2 {A B C : Type} [hs : is_hset C] {rel_a : A → A → hprop} {rel_b : B → B → hprop} (rel_a_refl : Π (a : A), rel_a a a) (f : A -> B -> C) (c : Π (a1 a2 : A) (b1 b2 : B) , rel_a a1 a2 → rel_b b1 b2 → f a1 b1 = f a2 b2) (q1 : set_quotient rel_a) (q2 : set_quotient rel_b) : C := 241 | set_quotient.elim_on 242 | rel_a 243 | q1 244 | (λ a, set_quotient.elim_on rel_b q2 (f a) (begin intros, apply c, exact (rel_a_refl a), assumption end)) 245 | sorry 246 | /- 247 | (λ (a a' : A) (H : rel_a a a'), ap (λ a1, set_quotient.elim_on rel_b q2 (f a1) (begin intros, apply c, exact (rel_a_refl a1), assumption end)) (ext_c f c a a' H)) 248 | -/ 249 | 250 | definition lift2rat (f : prerat -> prerat -> ℚ) (c : Π (a1 a2 b1 b2 : prerat), rat_rel_trunc a1 a2 → rat_rel_trunc b1 b2 → f a1 b1 = f a2 b2) := @lift2 prerat prerat ℚ (sorry : is_hset ℚ) rat_rel_trunc rat_rel_trunc prerat_refl f c 251 | 252 | 253 | definition add : ℚ → ℚ → ℚ := 254 | lift2rat 255 | (λ a b : prerat, lift0 (prerat.add a b)) 256 | sorry 257 | /- 258 | (begin 259 | intros, 260 | apply (set_quotient.eq_of_rel rat_rel_trunc), 261 | esimp [prerat.add], 262 | end) 263 | -/ 264 | -- (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.add_equiv_add H1 H2)) 265 | 266 | /- 267 | 268 | protected definition lift₂ [reducible] 269 | (f : A → B → C)(c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) 270 | (q₁ : quot s₁) (q₂ : quot s₂) : C := 271 | quot.lift 272 | (λ a₁, lift (λ a₂, f a₁ a₂) (λ a b H, c a₁ a a₁ b (setoid.refl a₁) H) q₂) 273 | (λ a b H, ind (λ a', proof c a a' b a' H (setoid.refl a') qed) q₂) 274 | q₁ 275 | 276 | definition add : ℚ → ℚ → ℚ := 277 | quot.lift₂ 278 | (λ a b : prerat, ⟦prerat.add a b⟧) 279 | (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.add_equiv_add H1 H2)) 280 | 281 | 282 | constant lift : Π {A B : Type} [s : setoid A] (f : A → B), (∀ a b, a ≈ b → f a = f b) → quot s → B 283 | 284 | -/ 285 | 286 | /- 287 | definition lift2 (f : prerat → prerat → prerat) (coh1 : Π (p q r : prerat), rat_rel_trunc p q → f p r = f q r) (coh2 : Π (p q r : prerat), rat_rel_trunc p q → f r p = f r q) (r1 r2 : ℚ) : ℚ := 288 | @set_quotient.elim_on prerat rat_rel_trunc rat r1 sorry (λ x, @set_quotient.elim_on prerat rat_rel_trunc rat r2 sorry (λ y, lift_prerat (f x y)) 289 | (λ (a a' : prerat) (myrel: rat_rel_trunc a a'), ap lift_prerat (coh2 a a' x myrel)) 290 | ) 291 | (begin 292 | intros, 293 | esimp at *, 294 | --rewrite [▸*, -coh1 !a !a' !H] 295 | --rewrite [▸*], 296 | --esimp [lift_prerat, set_quotient.elim_on, set_quotient.elim, set_quotient.rec, trunc.rec_on], 297 | --rewrite [▸*], 298 | end) 299 | -/ 300 | /- 301 | (λ (a a' : prerat) (myrel : rat_rel_trunc a a'), 302 | ap (λ z, @set_quotient.elim_on prerat rat_rel_trunc r2 sorry (λ (y : prerat), (lift_prerat (z y))) 303 | (λ (a1 a2 : prerat) (myrel : rat_rel_trunc a1 a2), ap lift_prerat (coh2 a1 a2 a myrel))) 304 | (coh1 a a' myrel)) 305 | -/ 306 | /- 307 | Π ⦃a a' : prerat⦄, 308 | trunctype.carrier (rat_rel_trunc a a') → 309 | set_quotient.elim_on rat_rel_trunc r2 (λ (y : prerat), lift_prerat (f a y)) 310 | (λ (a_1 a' : prerat) (myrel : trunctype.carrier (rat_rel_trunc a_1 a')), ap lift_prerat (coh2 a_1 a' a myrel)) = set_quotient.elim_on 311 | rat_rel_trunc 312 | r2 313 | (λ (y : prerat), lift_prerat (f a' y)) 314 | (λ (a a'_1 : prerat) (myrel : trunctype.carrier (rat_rel_trunc a a'_1)), ap lift_prerat (coh2 a a'_1 a' myrel)) 315 | 316 | 317 | definition lift2' {A : Type} [hs: is_hset A] (f : prerat → ℚ → A) (coh : Π (p q : prerat), Π (p1 q1 : ℚ), (rat_rel_trunc p q → f p p1 = f q q1)) (r1 : rat) (r2 : rat) : A := lift1 (λ x, f x r2) 318 | (begin 319 | intros, 320 | fapply coh, 321 | assumption 322 | end) 323 | r1 324 | 325 | definition lift_two {A : Type} [hs: is_hset A] (f : prerat → prerat → A) (coh : Π (p q : prerat), (rat_rel_trunc p q → f p = f q)) (r1 : rat) : prerat → A := @lift1 (prerat → A) sorry f 326 | (begin 327 | intros, 328 | fapply coh, 329 | assumption 330 | end) 331 | r1 332 | 333 | set_option formatter.hide_full_terms false 334 | 335 | lemma halp {A : Type} [hs: is_hset A] (f : prerat → prerat → A) (coh : Π (p1 q1), rat_rel_trunc p1 q1 → f p1 = f q1) (r1 : rat) (coh2 : Π (r p1 q1: prerat), f r p1 = f r q1) (p q : prerat) (rel : rat_rel_trunc p q) : lift_two f coh r1 p = lift_two f coh r1 q := 336 | let foo := lift_two f coh r1 in 337 | begin 338 | fapply elim_eq_of_rel, 339 | end 340 | 341 | 342 | definition lift2 {A : Type} [hs: is_hset A] (f : prerat → prerat → A) (coh : Π (p1 q1), rat_rel_trunc p1 q1 → f p1 = f q1) (coh2 : Π (r p1 q1: prerat), f r p1 = f r q1) (r1 : rat) (r2 : rat) : A := 343 | lift1 (lift_two f coh r1) 344 | ( 345 | begin 346 | intros, 347 | fapply halp, 348 | fapply coh2, 349 | assumption 350 | end 351 | ) 352 | r2 353 | -/ 354 | /- 355 | ( 356 | begin 357 | intros, 358 | apply coh 359 | end 360 | ) 361 | r2 362 | -/ 363 | /- 364 | definition lift2 {A : Type} [hs: is_hset A] (f : prerat → prerat → A) (coh : Π (p1 q1 p2 q2: prerat), rat_rel_trunc p1 q1 → rat_rel_trunc p2 q2 → f p1 p2 = f q1 q2) (r1 : rat) (r2 : rat) : A := 365 | begin 366 | fapply lift1, 367 | rotate 2, 368 | exact r1, 369 | clear r1, 370 | fapply lift1 371 | end 372 | -/ 373 | --set_quotient.elim_on rat_rel_trunc r1 (@lift1 (prerat → A) _ f r2) _ 374 | --@lift1 (ℚ → A) sorry (@lift1 f) _ r1 r2 375 | 376 | 377 | 378 | /- 379 | (λ x : prerat, set_quotient.elim_on rat_rel_trunc r2 (f x) 380 | (begin 381 | intros, 382 | apply coh, 383 | fapply prerat_refl, 384 | assumption 385 | end)) 386 | sorry 387 | -/ 388 | /- 389 | (begin 390 | intros, 391 | end) 392 | -/ 393 | 394 | --definition add : ℚ → ℚ → ℚ := 395 | -------------------------------------------------------------------------------- /infinitraverse/predictable.bib: -------------------------------------------------------------------------------- 1 | @inproceedings{nakano2000modality, 2 | title={A modality for recursion}, 3 | author={Nakano, Hiroshi}, 4 | booktitle={Proceedings Fifteenth Annual IEEE Symposium on Logic in Computer Science (Cat. No. 99CB36332)}, 5 | pages={255--266}, 6 | year={2000}, 7 | organization={IEEE} 8 | } 9 | 10 | @inproceedings{nakano2001fixed, 11 | title={Fixed-point logic with the approximation modality and its Kripke completeness}, 12 | author={Nakano, Hiroshi}, 13 | booktitle={International Symposium on Theoretical Aspects of Computer Software}, 14 | pages={165--182}, 15 | year={2001}, 16 | organization={Springer} 17 | } 18 | 19 | @article{mcbride2008applicative, 20 | title={Applicative programming with effects}, 21 | author={McBride, Conor and Paterson, Ross}, 22 | journal={Journal of functional programming}, 23 | volume={18}, 24 | number={1}, 25 | pages={1--13}, 26 | year={2008}, 27 | publisher={Cambridge University Press} 28 | } 29 | 30 | @inproceedings{bird2013understanding, 31 | title={Understanding idiomatic traversals backwards and forwards}, 32 | author={Bird, Richard and Gibbons, Jeremy and Mehner, Stefan and Voigtl{\"a}nder, Janis and Schrijvers, Tom}, 33 | booktitle={Proceedings of the 2013 ACM SIGPLAN symposium on Haskell}, 34 | pages={25--36}, 35 | year={2013} 36 | } 37 | 38 | @article{jaskelioff2015representation, 39 | title={A representation theorem for second-order functionals}, 40 | author={Jaskelioff, Mauro and O'Connor, Russell}, 41 | journal={Journal of functional programming}, 42 | volume={25}, 43 | year={2015}, 44 | publisher={Cambridge University Press} 45 | } 46 | 47 | @article{gibbons2009essence, 48 | title={The essence of the iterator pattern}, 49 | author={Gibbons, Jeremy and Oliveira, Bruno C d S}, 50 | journal={Journal of functional programming}, 51 | volume={19}, 52 | number={3-4}, 53 | pages={377--402}, 54 | year={2009}, 55 | publisher={Cambridge University Press} 56 | } 57 | 58 | @article{atkey2013productive, 59 | title={Productive coprogramming with guarded recursion}, 60 | author={Atkey, Robert and McBride, Conor}, 61 | journal={ACM SIGPLAN Notices}, 62 | volume={48}, 63 | number={9}, 64 | pages={197--208}, 65 | year={2013}, 66 | publisher={ACM New York, NY, USA} 67 | } 68 | 69 | @article{jaskelioff2012investigation, 70 | title={An investigation of the laws of traversals}, 71 | author={Jaskelioff, Mauro and Rypacek, Ondrej}, 72 | journal={arXiv preprint arXiv:1202.2919}, 73 | year={2012} 74 | } 75 | 76 | @inproceedings{ahman2014update, 77 | title={Update monads: cointerpreting directed containers}, 78 | author={Ahman, Danel and Uustalu, Tarmo}, 79 | booktitle={Proc. of 19th Int. Conf. on Types for Proofs and Programs, TYPES}, 80 | volume={13}, 81 | pages={1--23}, 82 | year={2014} 83 | } 84 | 85 | @article{pirog2013monads, 86 | title={Monads for behaviour}, 87 | author={Pir{\'o}g, Maciej and Gibbons, Jeremy}, 88 | journal={Electronic Notes in Theoretical Computer Science}, 89 | volume={298}, 90 | pages={309--324}, 91 | year={2013}, 92 | publisher={Elsevier} 93 | } 94 | 95 | @inproceedings{birkedal2011first, 96 | title={First steps in synthetic guarded domain theory: step-indexing in the topos of trees}, 97 | author={Birkedal, Lars and Mogelberg, Rasmus Ejlers and Schwinghammer, Jan and Stovring, Kristian}, 98 | booktitle={2011 IEEE 26th Annual Symposium on Logic in Computer Science}, 99 | pages={55--64}, 100 | year={2011}, 101 | organization={IEEE} 102 | } 103 | 104 | 105 | @article{birkedal2017guarded, 106 | title={The guarded lambda-calculus: Programming and reasoning with guarded recursion for coinductive types}, 107 | author={Birkedal, Lars and Grathwohl, Hans Bugge and Bizjak, Ale{\v{s}} and Clouston, Ranald}, 108 | journal={Logical Methods in Computer Science}, 109 | volume={12}, 110 | year={2017}, 111 | publisher={Episciences. org} 112 | } 113 | 114 | @inproceedings{guatto:2018, 115 | author = {Guatto, Adrien}, 116 | booktitle = {Proceedings of the 33rd Annual {ACM/IEEE} Symposium on Logic in Computer Science, {LICS} 2018, Oxford, UK, July 09-12, 2018}, 117 | year = {2018}, 118 | doi = {10.1145/3209108.3209148}, 119 | pages = {482--491}, 120 | title = {A Generalized Modality for Recursion}, 121 | } 122 | 123 | @phdthesis{paviotti:2016, 124 | author = {Paviotti, Marco}, 125 | language = {English}, 126 | address = {Denmark}, 127 | school = {IT-Universitetet i K{\o{}}benhavn}, 128 | year = {2016}, 129 | isbn = {978-87-7949-345-2}, 130 | series = {ITU-DS}, 131 | title = {Denotational semantics in Synthetic Guarded Domain Theory}, 132 | } 133 | 134 | @inproceedings{mogelberg-paviotti:2016, 135 | author = {M\o{}gelberg, Rasmus Ejlers and Paviotti, Marco}, 136 | address = {New York, NY, USA}, 137 | publisher = {Association for Computing Machinery}, 138 | booktitle = {Proceedings of the 31st Annual ACM/IEEE Symposium on Logic in Computer Science}, 139 | year = {2016}, 140 | doi = {10.1145/2933575.2934516}, 141 | isbn = {978-1-4503-4391-6}, 142 | pages = {317--326}, 143 | title = {Denotational Semantics of Recursive Types in Synthetic Guarded Domain Theory}, 144 | } 145 | 146 | @inproceedings{gratzer-birkedal:2022, 147 | author = {Gratzer, Daniel and Birkedal, Lars}, 148 | editor = {Felty, Amy}, 149 | address = {Dagstuhl, Germany}, 150 | publisher = {Schloss Dagstuhl--Leibniz-Zentrum fuer Informatik}, 151 | url = {https://jozefg.github.io/papers/a-stratified-approach-to-lob-induction.pdf}, 152 | booktitle = {7th International Conference on Formal Structures for Computation and Deduction (FSCD 2022)}, 153 | year = {2022}, 154 | month = aug, 155 | doi = {10.4230/LIPIcs.FSCD.2022.3}, 156 | series = {Leibniz International Proceedings in Informatics (LIPIcs)}, 157 | title = {A Stratified Approach to {L\"{o}b} Induction}, 158 | volume = {228}, 159 | } 160 | 161 | @article{mogelberg-veltri:2019, 162 | author = {M\o{}gelberg, Rasmus Ejlers and Veltri, Niccol\`{o}}, 163 | address = {New York, NY, USA}, 164 | publisher = acm, 165 | year = {2019}, 166 | month = jan, 167 | doi = {10.1145/3290317}, 168 | journal = {Proceedings of the ACM on Programming Languages}, 169 | number = {POPL}, 170 | title = {Bisimulation as Path Type for Guarded Recursive Types}, 171 | volume = {3}, 172 | } 173 | 174 | @inproceedings{veltri-vezzosi:2020, 175 | author = {Veltri, Niccol\`{o} and Vezzosi, Andrea}, 176 | address = {New Orleans, LA, USA}, 177 | publisher = {Association for Computing Machinery}, 178 | booktitle = {Proceedings of the 9th ACM SIGPLAN International Conference on Certified Programs and Proofs}, 179 | year = {2020}, 180 | doi = {10.1145/3372885.3373814}, 181 | isbn = {978-1-4503-7097-4}, 182 | keywords = {ticked cubical type theory,denotational semantics,guarded recursion,pi-calculus}, 183 | pages = {270--283}, 184 | title = {Formalizing $\pi$-Calculus in {Guarded Cubical Agda}}, 185 | } 186 | 187 | @inproceedings{sterling-harper:2018, 188 | author = {Sterling, Jonathan and Harper, Robert}, 189 | title = {Guarded Computational Type Theory}, 190 | booktitle = {Proceedings of the 33rd Annual ACM/IEEE Symposium on Logic in Computer Science}, 191 | series = {LICS '18}, 192 | year = {2018}, 193 | isbn = {978-1-4503-5583-4}, 194 | location = {Oxford, United Kingdom}, 195 | pages = {879--888}, 196 | numpages = {10}, 197 | url = {http://doi.acm.org/10.1145/3209108.3209153}, 198 | doi = {10.1145/3209108.3209153}, 199 | acmid = {3209153}, 200 | publisher = {ACM}, 201 | address = {New York, NY, USA}, 202 | keywords = {clocks, dependent types, guarded recursion, operational semantics, type theory}, 203 | } 204 | 205 | @article{paviotti-mogelberg-birkedal:2015, 206 | author = {Paviotti, Marco and M\o{}gelberg, Rasmus Ejlers and Birkedal, Lars}, 207 | year = {2015}, 208 | doi = {10.1016/j.entcs.2015.12.020}, 209 | issn = {1571-0661}, 210 | journal = {Electronic Notes in Theoretical Computer Science}, 211 | keywords = {Denotational semantics,guarded recursion,type theory,PCF,synthetic domain theory}, 212 | note = {The 31st Conference on the Mathematical Foundations of Programming Semantics (MFPS XXXI)}, 213 | number = {Supplement C}, 214 | pages = {333--349}, 215 | title = {A Model of {PCF} in {Guarded Type Theory}}, 216 | volume = {319}, 217 | } 218 | 219 | @article{bbcgsv:2019, 220 | author = {Birkedal, Lars and Bizjak, Ale\v{s} and Clouston, Ranald and Grathwohl, Hans Bugge and Spitters, Bas and Vezzosi, Andrea}, 221 | year = {2019}, 222 | doi = {10.1007/s10817-018-9471-7}, 223 | journal = {Journal of Automated Reasoning}, 224 | number = {2}, 225 | pages = {211--253}, 226 | title = {Guarded Cubical Type Theory}, 227 | volume = {63}, 228 | } 229 | 230 | @article{bizjak2020denotational, 231 | title={Denotational semantics for guarded dependent type theory}, 232 | author={Bizjak, Ale{\v{s}} and M{\o}gelberg, Rasmus Ejlers}, 233 | journal={Mathematical Structures in Computer Science}, 234 | volume={30}, 235 | number={4}, 236 | pages={342--378}, 237 | year={2020}, 238 | publisher={Cambridge University Press} 239 | } 240 | 241 | @unpublished{palombi-sterling:2022, 242 | author = {Palombi, Daniele and Sterling, Jonathan}, 243 | url = {https://www.jonmsterling.com/papers/palombi-sterling:2022.pdf}, 244 | year = {2022}, 245 | month = mar, 246 | note = {Unpublished manuscript}, 247 | title = {Classifying topoi in synthetic guarded domain theory}, 248 | } 249 | 250 | 251 | 252 | @article{hermida_reddy_robinson_santamaria_2022, title={Bisimulation as a logical relation}, DOI={10.1017/S0960129522000020}, journal={Mathematical Structures in Computer Science}, publisher={Cambridge University Press}, author={Hermida, Claudio and Reddy, Uday and Robinson, Edmund and Santamaria, Alessio}, year={2022}, pages={1–30}} 253 | 254 | @article{hur2012marriage, 255 | title={The marriage of bisimulations and Kripke logical relations}, 256 | author={Hur, Chung-Kil and Dreyer, Derek and Neis, Georg and Vafeiadis, Viktor}, 257 | journal={ACM SIGPLAN Notices}, 258 | volume={47}, 259 | number={1}, 260 | pages={59--72}, 261 | year={2012}, 262 | publisher={ACM New York, NY, USA} 263 | } 264 | 265 | @article{kavvos2017intensionality, 266 | title={Intensionality, Intensional Recursion, and the Gödel-Löb axiom}, 267 | author={Kavvos, GA}, 268 | journal={arXiv preprint arXiv:1703.01288}, 269 | year={2017} 270 | } 271 | 272 | @inproceedings{kavvos2017semantics, 273 | title={On the semantics of intensionality}, 274 | author={Kavvos, GA}, 275 | booktitle={International Conference on Foundations of Software Science and Computation Structures}, 276 | pages={550--566}, 277 | year={2017}, 278 | organization={Springer} 279 | } 280 | 281 | @inproceedings{chen-ko:2022, 282 | author = {Chen, Liang-Ting and Ko, Hsiang-Shang}, 283 | editor = {Manea, Florin and Simpson, Alex}, 284 | address = {Dagstuhl, Germany}, 285 | publisher = {Schloss Dagstuhl -- Leibniz-Zentrum f\"{u}r Informatik}, 286 | booktitle = {30th EACSL Annual Conference on Computer Science Logic (CSL 2022)}, 287 | year = {2022}, 288 | doi = {10.4230/LIPIcs.CSL.2022.14}, 289 | isbn = {978-3-95977-218-1}, 290 | issn = {1868-8969}, 291 | pages = {14:1--14:17}, 292 | series = {Leibniz International Proceedings in Informatics (LIPIcs)}, 293 | title = {{Realising Intensional S4 and GL Modalities}}, 294 | volume = {216}, 295 | } 296 | 297 | @article{capretta2005general, 298 | title={General recursion via coinductive types}, 299 | author={Capretta, Venanzio}, 300 | journal={Logical Methods in Computer Science}, 301 | volume={1}, 302 | year={2005}, 303 | publisher={Episciences. org} 304 | } 305 | 306 | @article{chapman2019quotienting, 307 | title={Quotienting the delay monad by weak bisimilarity}, 308 | author={Chapman, James and Uustalu, Tarmo and Veltri, Niccol{\`o}}, 309 | journal={Mathematical Structures in Computer Science}, 310 | volume={29}, 311 | number={1}, 312 | pages={67--92}, 313 | year={2019}, 314 | publisher={Cambridge University Press} 315 | } 316 | @inproceedings{uustalu2017delay, 317 | title={The delay monad and restriction categories}, 318 | author={Uustalu, Tarmo and Veltri, Niccol{\`o}}, 319 | booktitle={International Colloquium on Theoretical Aspects of Computing}, 320 | pages={32--50}, 321 | year={2017}, 322 | organization={Springer} 323 | } 324 | 325 | 326 | @inproceedings{altenkirch2017partiality, 327 | title={Partiality, revisited}, 328 | author={Altenkirch, Thorsten and Danielsson, Nils Anders and Kraus, Nicolai}, 329 | booktitle={International Conference on Foundations of Software Science and Computation Structures}, 330 | pages={534--549}, 331 | year={2017}, 332 | organization={Springer} 333 | } 334 | 335 | @InProceedings{induction-with-effects, 336 | title = {Fibrational Induction Meets Effects}, 337 | author = {Robert Atkey and Neil Ghani and Bart Jacobs and Patricia Johann}, 338 | year = {2012}, 339 | doi = {10.1007/978-3-642-28729-9_3}, 340 | booktitle = {Foundations of Software Science and Computational Structures}, 341 | series = {Lecture Notes in Computer Science}, 342 | editor = {Lars Birkedal}, 343 | publisher = {Springer}, 344 | pages = {42-57}, 345 | volume = {7213}} 346 | 347 | @Article{interleaving, 348 | title = {Interleaving data and effects}, 349 | author = {Robert Atkey and Patricia Johann}, 350 | year = {2015}, 351 | doi = {10.1017/S0956796815000209}, 352 | journal = {Journal of Functional Programming}, 353 | volume = {25}} 354 | 355 | @article{spivak2022reference, 356 | title={A reference for categorical structures on Poly}, 357 | author={Spivak, David I}, 358 | journal={arXiv preprint arXiv:2202.00534}, 359 | year={2022} 360 | } 361 | 362 | @article{danielsson2006fast, 363 | title={Fast and loose reasoning is morally correct}, 364 | author={Danielsson, Nils Anders and Hughes, John and Jansson, Patrik and Gibbons, Jeremy}, 365 | journal={ACM SIGPLAN Notices}, 366 | volume={41}, 367 | number={1}, 368 | pages={206--217}, 369 | year={2006}, 370 | publisher={ACM New York, NY, USA} 371 | } 372 | 373 | #incollection{vickers1993geometric, 374 | title={Geometric logic in computer science}, 375 | author={Vickers, Steve}, 376 | booktitle={Theory and Formal Methods 1993}, 377 | pages={37--54}, 378 | year={1993}, 379 | publisher={Springer} 380 | } 381 | #inproceedings{escardo2007infinite, 382 | title={Infinite sets that admit fast exhaustive search}, 383 | author={Escard{\'o}, Mart{\'\i}n}, 384 | booktitle={22nd Annual IEEE Symposium on Logic in Computer Science (LICS 2007)}, 385 | pages={443--452}, 386 | year={2007}, 387 | organization={IEEE} 388 | } 389 | 390 | -------------------------------------------------------------------------------- /algebra-of-programming/Algebraically.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module Algebraically where 4 | import Control.Arrow 5 | import Data.List (inits, tails) 6 | 7 | 8 | {- 9 | *** 10 | Notes and Exercises in Algebraic Program Derivation 11 | Gershom Bazerman, May 2015 12 | *** 13 | 14 | Tested with: GHC 7.10, GHC 7.8 15 | 16 | The following are a set of notes and exercises to introduce the very basic notions of program derivation in the style of "The Algebra of Programming" (Bird and de Moor, 1997). That book provides the best account of this material and much more. However, there is a long and storied history of work in this field. See for instance: 17 | 18 | "Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire" and follow on work by Meijer, Fokkinga and Paterson (1991) 19 | "Algorithmics -- Towards programming as a mathematical activity" (Meertens, 1987) 20 | "An Exploration of the Bird-Meertens Formalism" (Backhouse, 1989) 21 | "Algebraic Data Types and Program Transformation" (Malcolm, 1990) 22 | "Upwards and downwards accumulations on trees" (Gibbons, 1992) 23 | 24 | -} 25 | 26 | {- --- --- --- --- --- --- 27 | "I practice till the difficult becomes easy; the easy becomes habit; and the habit becomes beautiful." 28 | --- --- --- --- --- --- -} 29 | 30 | -------------------------------------------------------------- 31 | 32 | -- Part 1: Fixpoints of Functors, and Algebras on Functors 33 | 34 | -- equational reasoning requires equations 35 | -- level up equational reasoning by studying equations more powerful than simple substitutions. 36 | -- data types and functions on them come equipped with laws beyond the obvious. 37 | 38 | -- strictly positive recursive types can be written as the fixpoints of "signature functors" like so. 39 | 40 | data NatF r = ZeroF | SuccF r 41 | 42 | data ListF a r = NilF | ConsF a r 43 | 44 | data TreeF a r = LeafF a | BranchF r r 45 | 46 | data FixF f = FixF {unRoll :: f (FixF f)} 47 | 48 | -- Isomorphism between algebras as sets of things to do in each case, and functions out of a functor that encompasses all cases. 49 | 50 | type LAlg a b = (a -> b -> b, b) 51 | 52 | listFold :: LAlg a b -> ListF a b -> b 53 | listFold (c, z) NilF = z 54 | listFold (c, z) (ConsF a r) = c a r 55 | 56 | mkListAlg :: (ListF a b -> b) -> LAlg a b 57 | mkListAlg f = (\x xs -> f (ConsF x xs) , f NilF) 58 | 59 | {- 60 | Exercise: Show this is an isomorphism 61 | 62 | Exercise: Write the same thing for Trees 63 | -} 64 | 65 | 66 | listMap :: (a -> b) -> ListF c a -> ListF c b 67 | listMap f NilF = NilF 68 | listMap f (ConsF x y) = ConsF x (f y) 69 | 70 | fold :: (a -> b -> b, b) -> [a] -> b 71 | fold (c, z) = foldr c z 72 | 73 | a = ((:),[]) 74 | 75 | {- 76 | exercise: write as pair algebras 77 | 78 | 1: Sum 79 | 2: Length 80 | 81 | Now, write them as functor algebras (ListF Int Int -> Int) 82 | 83 | substitute and convince yourself these are the same. 84 | -} 85 | 86 | -- Part 2: Universal Properties of Folds and equational reasoning 87 | 88 | {- 89 | universal property of folds 90 | 91 | if h = fold f 92 | <==> 93 | h . listFold a = listFold f . listMap h 94 | -} 95 | 96 | lfa :: ListF a [a] -> [a] 97 | lfa = listFold a 98 | 99 | up1 :: ([a] -> b) -> LAlg a b -> ListF a [a] -> b 100 | up1 h f = h . listFold a 101 | 102 | up2 :: ([a] -> b) -> LAlg a b -> ListF a [a] -> b 103 | up2 h f = listFold f . listMap h 104 | 105 | -- Substitute h for fold f, and the following are clearly an identity 106 | 107 | up3 :: LAlg a b -> ListF a [a] -> b 108 | up3 f = fold f . listFold a 109 | 110 | up4 :: LAlg a b -> ListF a [a] -> b 111 | up4 f = listFold f . listMap (fold f) 112 | 113 | -- the universal property shows that this goes the other direction 114 | 115 | {- 116 | exercise: 117 | 118 | show that up3 and up4 are necessarily the same 119 | -} 120 | 121 | {- 122 | exercise: 123 | fold a = id 124 | -} 125 | 126 | {- 127 | fold fusion: 128 | 129 | h . listFold f = listFold g . listMap h 130 | ==> 131 | h . fold f = fold g 132 | -} 133 | 134 | ff1 h f g = h . listFold f 135 | 136 | ff2 h f g = listFold g . listMap h 137 | 138 | {- 139 | *Algebraically> :t ff1 140 | ff1 :: (b -> c) -> LAlg a b -> t -> ListF a b -> c 141 | 142 | *Algebraically> :t ff2 143 | 144 | ff2 :: (a1 -> c) -> t -> LAlg a c -> ListF a a1 -> c 145 | 146 | *Algebraically> :t ff1 `asTypeOf` ff2 147 | 148 | ff1 `asTypeOf` ff2 :: (b -> c) -> LAlg a b -> LAlg a c -> ListF a b -> c 149 | 150 | h :: b -> c 151 | f :: LALg a b 152 | g :: LAlg a c 153 | 154 | 155 | h . fold f :: [a] -> c 156 | fold g :: [a] -> c 157 | -} 158 | 159 | {- 160 | Exercise: Take h to be show, f to be sum. 161 | 162 | Determine g. 163 | 164 | -} 165 | 166 | sumAlg = ((+),0) 167 | ffex1 :: ListF Integer Integer -> String 168 | ffex1 = show . listFold sumAlg 169 | 170 | ffex2 :: ListF Integer Integer -> String 171 | ffex2 = g . listMap (show :: Integer -> String) 172 | where g :: ListF Integer String -> String 173 | g = undefined -- ? 174 | 175 | {- 176 | exercise: show that 177 | 178 | listFold a . fold (mkListAlg (listMap (listFold a))) == id 179 | 180 | fold (mkListAlg (listMap (listFold a))) . listFold a == id 181 | -} 182 | 183 | -------------------------------------------------------------- 184 | -- Part 3: The Banana Split Threorem 185 | 186 | bs1, bs2, bs3, bs4, bs5, bs6 :: LAlg a b -> LAlg a c -> ListF a [a] -> (b,c) 187 | bs1 c1 c2 = (fold c1 &&& fold c2) . listFold a 188 | -- split fusion 189 | bs2 c1 c2 = fold c1 . listFold a &&& fold c2 . listFold a 190 | -- properties of fold 191 | bs3 c1 c2 = listFold c1 . listMap (fold c1) &&& listFold c2 . listMap (fold c2) 192 | -- split expansion 193 | bs4 c1 c2 = listFold c1 . listMap (fst . (fold c1 &&& fold c2)) &&& 194 | listFold c2 . listMap (snd . (fold c1 &&& fold c2)) 195 | -- functor splitting 196 | bs5 c1 c2 = listFold c1 . listMap fst . listMap (fold c1 &&& fold c2) &&& 197 | listFold c2 . listMap snd . listMap (fold c1 &&& fold c2) 198 | -- split fusion (backwards) 199 | bs6 c1 c2 = (listFold c1 . listMap fst &&& listFold c2 . listMap snd) . listMap (fold c1 &&& fold c2) 200 | 201 | {- 202 | by the universal property of lists, bs1 == bs6 implies that 203 | (fold c1 &&& fold c2) === fold (listFold c1 . listMap fst &&& listFold c2 . listMap snd) 204 | -} 205 | bsResult1, bsResult2 :: LAlg a b -> LAlg a c -> [a] -> (b,c) 206 | bsResult1 c1 c2 = fold c1 &&& fold c2 207 | bsResult2 c1 c2 = fold (mkListAlg (listFold c1 . listMap fst &&& listFold c2 . listMap snd)) 208 | 209 | 210 | {- 211 | exercise, use the banana split theorem to write a single pass average. 212 | -} 213 | 214 | {- 215 | exercise: write the bs theorem as an operation on LAlg explicitly, and argue why it is the same. 216 | -} 217 | 218 | -------------------------------------------------------------- 219 | -- Part 4: Maximum Segment Sum 220 | -- inspired heavily by http://www.iis.sinica.edu.tw/~scm/2010/maximum-segment-sum-origin-and-derivation/ 221 | 222 | -- A) list homomorphisms 223 | 224 | concatList :: [[a]] -> [a] 225 | concatList = foldr (++) [] 226 | -- concatList is a natural transformation -- i.e. 227 | -- map f . concatList = concatList . map (map f) 228 | 229 | {- 230 | h :: [a] -> a 231 | 232 | h [h xs, h ys] == h (xs ++ ys) 233 | ==> 234 | h . concat = h . map h 235 | 236 | In such a circumstance, we say h is a "list homomorphism" and it is a special fold that is associative and with a zero element. -- i.e. it is given by the action of a monoid. 237 | 238 | Other homomorphism laws: 239 | 240 | define m xs ys = h [xs,ys] 241 | 242 | now, h = foldr m z . map (\x -> h [x]) 243 | 244 | (where foldr itself may be executed in parallel as it is a fold over a monoidal operation) 245 | 246 | Observe: list homomorphisms are subject to _map_ and _reduce_. 247 | -} 248 | 249 | {- 250 | Exercise: Give examples of list homomorphisms, and write algebras for them. 251 | 252 | Hint: Look at Data.Monoid 253 | -} 254 | 255 | -- B) Scanr, inits fusion fusion 256 | 257 | tailsAlg :: LAlg a [[a]] 258 | tailsAlg = (go,[[]]) 259 | where go x [] = [[x]] 260 | go x (y:ys) = (x : y) : y : ys 261 | 262 | {- 263 | fold tailsAlg [1,2,3,4] 264 | 265 | [[1,2,3,4],[2,3,4],[3,4],[4],[]] 266 | -} 267 | 268 | -- note this is reversed from a typical scanr. 269 | scanRight :: LAlg a b -> LAlg a [b] 270 | scanRight (c,z) = (go,[z]) 271 | where go x [] = [c x z] 272 | go x (y:ys) = c x y : y : ys 273 | 274 | {- 275 | By inspection, tails is initial with regards to rightward scans. 276 | 277 | scanRight alg = map (fold alg) . fold tailsAlg 278 | 279 | rememember fusion 280 | h . listFold f = listFold g . listMap h 281 | 282 | take: 283 | h = map (fold alg) 284 | f = tailsAlg 285 | g = scanRight alg 286 | 287 | and we see 288 | 289 | map (fold alg) . listFold tailsAlg :: ListF a [[a]] -> [a] 290 | listFold (scanRight alg) . listMap (map (fold alg)) :: ListF a [[a]] -> [a] 291 | 292 | the two are equal, and therefore by fusion, scanRight alg = map (fold alg) . tailsAlg 293 | 294 | Or: 295 | 296 | scanr f e = map (foldr f e) . tails 297 | 298 | -} 299 | 300 | {- 301 | note this is an inefficient inits and scan.. 302 | -} 303 | 304 | initsAlg :: LAlg a [[a]] 305 | initsAlg = (go,[]) 306 | where go x [] = [] : [x] : [] 307 | go x xs = [] : map (x:) xs 308 | {- 309 | *Algebraically> fold initsAlg [1,2,3,4,5] 310 | [[1],[1,2],[1,2,3],[1,2,3,4],[1,2,3,4,5]] 311 | -} 312 | 313 | scanLeft :: LAlg a b -> LAlg a [b] 314 | scanLeft (c,z) = (go,[]) 315 | where go x [] = [z,c x z] 316 | go x ys = z : map (c x) ys 317 | 318 | 319 | {- 320 | inits fusion 321 | 322 | map (fold alg) . fold initsAlg :: ListF a [[a]] -> [a] 323 | listFold (scanLeft alg) . listMap (map (fold alg)) :: ListF a [[a]] -> [a] 324 | 325 | these two are equal, therefore by fusion, scanLeft alg = map (fold alg) . initsAlg 326 | 327 | Or: 328 | 329 | scanl f e = map (foldl f e) . inits 330 | -} 331 | 332 | -- C) The problem 333 | 334 | testData :: [Integer] 335 | testData = [1,2,3,5,-100,5,1000,-1000,-4,25] 336 | 337 | segments :: [Integer] -> [[Integer]] 338 | segments = concat . map inits . tails 339 | 340 | mss0 :: [Integer] -> Integer 341 | mss0 = maximum . map sum . segments 342 | 343 | 344 | 345 | mss1, mss2, mss3, mss4 :: [Integer] -> Integer 346 | --inline segments 347 | mss1 = maximum . map sum . concatList . map inits . tails 348 | -- by naturality of concat 349 | mss2 = maximum . concatList . map (map sum) . map inits . tails 350 | -- by maximum being a list homomorphism 351 | mss3 = maximum . map maximum . map (map sum) . map inits . tails 352 | -- by map functorality / fusion 353 | mss4 = maximum . map (maximum . map sum . inits) . tails 354 | 355 | -- We now denote maximum . map sum . tails as maximum prefix sum 356 | -- maximum segment sum is the maximum of the prefix sums of the tails 357 | -- we wish to manipulate mps into a fold, so that we can use scanr fusion. 358 | 359 | mps0,mps1,mps2,mps3,mps4 :: [Integer] -> Integer 360 | mps0 = maximum . map sum . inits 361 | 362 | --inits fusion 363 | 364 | mps1 = maximum . scanl (+) 0 365 | 366 | --expand maximum 367 | 368 | mps2 = foldr max 0 . scanl (+) 0 369 | 370 | --fold/scan fusion 371 | 372 | {- 373 | I believe the following is correct: 374 | 375 | if h and g are list homomorphisms, and 376 | g x (h y z) = h (g x y) (g x z) -- i.e. h distributes over g 377 | 378 | then 379 | 380 | foldr h z . scanr g z = foldr (\x y -> h (g x y) z) 381 | 382 | If it is not, then it holds in this specific case, and can be carried through by reasoning directly on (+) and max. 383 | -} 384 | 385 | mps3 = foldr (\x y -> max 0 (x + y)) 0 386 | 387 | zmax x y = max 0 (x + y) 388 | 389 | mps4 = foldr zmax 0 390 | 391 | 392 | mss5,mss6 :: [Integer] -> Integer 393 | 394 | --subsitute in the new mps 395 | mss5 = maximum . map (foldr zmax 0) . tails 396 | 397 | -- tails fusion 398 | mss6 = maximum . scanr zmax 0 399 | 400 | -- we've gone from quadratic time to linear time! 401 | 402 | {- 403 | Exercise: observe that while zmax is derived from two list homomorphisms, zmax itself is not a list homomorphism. Argue why. 404 | -} 405 | 406 | -------------------------------------------------------------- 407 | -- Part 5: Parallel Prefix Sum 408 | 409 | {- 410 | Recall that inits as we gave it had complexity O(N^2). 411 | 412 | Note that as a foldl, inits may have complexity O(N), and tails does have such complexity as given. 413 | 414 | Can we do better? 415 | 416 | One school says, obviously not. 417 | 418 | Another says, think parallel! 419 | 420 | For simplicity we work with suffix sums (generalized scanr), and assume an O(1) list concatenation 421 | 422 | -} 423 | 424 | {- 425 | Exercise 1: given an arbitrary operator "op" and an arbitrary z, (scanr op z) is not a list homomorphism. Name a counterexample. 426 | -} 427 | 428 | {- 429 | Recall: a list homomorphism is a function h and an operator `op` such that: 430 | 431 | h xs `op` h ys = h (xs ++ ys) -- i.e. you can combine then translate, or translate than combine. 432 | 433 | This induces a monoid with `op` as the action, and h [] as the unit. 434 | 435 | Now we wish to define a function of type 436 | 437 | scanOp :: (a -> a -> a) -> [a] -> [a] -> [a] 438 | 439 | this function obeys the property that: 440 | 441 | scanOp op (scanr op z xs) (scanr op z ys) = scanr op z (xs ++ ys) 442 | 443 | -- i.e. we want scanOp to be the monoidal operation induced by "scanr op z" 444 | 445 | -} 446 | 447 | scanOp :: (a -> a -> a) -> [a] -> [a] -> [a] 448 | -- obvious 449 | scanOp op xs [] = xs 450 | scanOp op [] ys = ys 451 | 452 | -- scanOp op xs ys = ? 453 | {- 454 | 455 | By the laws of scanr, we know that: 456 | 457 | scanr op z (x:xs) = op x (head (scanr op z xs)) : scanr op z xs 458 | 459 | We also know that: 460 | 461 | scanr op z (xs ++ ys) = _ + scanr op z ys 462 | 463 | From this we can conclude that if op is associative, 464 | 465 | scanr op z (xs ++ ys) = map (`op` (head (scanr op z ys))) (init $ scanr op z xs) ++ scanr op z ys 466 | 467 | From this property we can write our scanOp as desired. 468 | 469 | -} 470 | 471 | scanOp op xs (y:ys) = map (`op` y) (init xs) ++ (y:ys) 472 | 473 | {- 474 | Checking some cases we see that indeed for (op,z) a monoid algebra: 475 | 476 | foldr (scanOp op) [] . map (scanr op z) === scanr op z 477 | 478 | and hence scanr may be written as a map reduce, and parallelized. 479 | 480 | Note that this is not a very good parallel prefix sum, due to the map. Deriving a genuinely efficient one in this manner, yielding O(log n) complexity, takes a fair amount more work. 481 | 482 | See: "Extracting and implementing list homomorphisms in parallel program development" (Gorlatch, 1999). 483 | 484 | This includes an application of a generalized method to turn maximum segment sum into a homomorphism as well. 485 | -} 486 | -------------------------------------------------------------------------------- /hlean/int_order.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2014 Floris van Doorn. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Authors: Floris van Doorn, Jeremy Avigad 5 | 6 | The order relation on the integers. We show that int is an instance of linear_comm_ordered_ring 7 | and transfer the results. 8 | -/ 9 | import types.int.basic algebra.ordered_ring types algebra.group 10 | open nat 11 | open decidable 12 | open eq.ops sum algebra prod eq 13 | open int 14 | 15 | namespace int 16 | 17 | -- Things to Add to Nat 18 | theorem of_nat_add (n m : nat) : of_nat (n + m) = of_nat n + of_nat m := rfl 19 | theorem of_nat_mul (n m : ℕ) : of_nat (n * m) = of_nat n * of_nat m := rfl 20 | 21 | --Things to Add to Int 22 | protected definition prio : num := num.pred std.priority.default 23 | 24 | -- Main 25 | private definition nonneg (a : ℤ) : Type.{0} := int.cases_on a (take n, unit) (take n, empty) 26 | definition le (a b : ℤ) : Type.{0} := nonneg (b - a) 27 | definition lt (a b : ℤ) : Type.{0} := le (int.add a (of_nat (nat.succ nat.zero))) b 28 | 29 | infix [priority int.prio] - := int.sub 30 | infix [priority int.prio] <= := int.le 31 | infix [priority int.prio] ≤ := int.le 32 | infix [priority int.prio] < := int.lt 33 | 34 | local attribute nonneg [reducible] 35 | private definition decidable_nonneg [instance] (a : ℤ) : decidable (nonneg a) := int.cases_on a _ _ 36 | definition decidable_le [instance] (a b : ℤ) : decidable (a ≤ b) := decidable_nonneg _ 37 | definition decidable_lt [instance] (a b : ℤ) : decidable (a < b) := decidable_nonneg _ 38 | 39 | private theorem nonneg.elim {a : ℤ} : nonneg a → Σn : ℕ, a = n := 40 | int.cases_on a (take n H, sigma.mk n rfl) (take n', empty.elim) 41 | 42 | private theorem nonneg_or_nonneg_neg (a : ℤ) : nonneg a ⊎ nonneg (-a) := 43 | int.cases_on a (take n, sum.inl unit.star) (take n, sum.inr unit.star) 44 | 45 | theorem le.intro {a b : ℤ} {n : ℕ} (H : a + n = b) : a ≤ b := 46 | have n = b - a, from eq_add_neg_of_add_eq (!add.comm ▸ H), 47 | show nonneg (b - a), from this ▸ unit.star 48 | 49 | theorem le.elim {a b : ℤ} (H : a ≤ b) : Σn : ℕ, int.add a n = b := --TODO note this is terrible 50 | obtain (n : ℕ) (H1 : b - a = n), from nonneg.elim H, 51 | sigma.mk n (!add.comm ▸ add_eq_of_eq_add_neg (H1⁻¹)) 52 | 53 | theorem le.total (a b : ℤ) : a ≤ b ⊎ b ≤ a := 54 | begin 55 | cases (nonneg_or_nonneg_neg (b - a)), 56 | apply sum.inl, 57 | exact a_1, 58 | apply sum.inr, 59 | exact (transport nonneg (neg_sub b a) a_1) 60 | end 61 | 62 | 63 | theorem of_nat_le_of_nat_of_le {m n : ℕ} (H : #nat m ≤ n) : of_nat m ≤ of_nat n := 64 | obtain (k : ℕ) (Hk : m + k = n), from nat.le.elim H, 65 | le.intro (Hk ▸ (of_nat_add m k)⁻¹) 66 | 67 | theorem le_of_of_nat_le_of_nat {m n : ℕ} (H : of_nat m ≤ of_nat n) : (#nat m ≤ n) := 68 | obtain (k : ℕ) (Hk : of_nat m + of_nat k = of_nat n), from le.elim H, 69 | have m + k = n, from of_nat.inj (of_nat_add m k ⬝ Hk), 70 | nat.le.intro this 71 | 72 | theorem of_nat_le_of_nat (m n : ℕ) : of_nat m ≤ of_nat n ↔ m ≤ n := 73 | iff.intro le_of_of_nat_le_of_nat of_nat_le_of_nat_of_le 74 | 75 | theorem lt_add_succ (a : ℤ) (n : ℕ) : a < a + succ n := 76 | le.intro (show a + 1 + n = a + succ n, from 77 | calc 78 | a + 1 + n = a + (1 + n) : add.assoc 79 | ... = a + (n + 1) : nat.add.comm 80 | ... = a + succ n : rfl) 81 | 82 | theorem lt.intro {a b : ℤ} {n : ℕ} (H : a + succ n = b) : a < b := 83 | H ▸ lt_add_succ a n 84 | 85 | set_option pp.all true 86 | 87 | --protected definition int_has_one [instance] [reducible] : has_one ℤ := has_one.mk (of_nat (nat.succ nat.zero)) 88 | 89 | theorem lt.elim {a b : ℤ} (H : a < b) : Σn : ℕ, int.add a (succ n) = b := 90 | begin 91 | cases (le.elim H), 92 | esimp [succ], 93 | fapply sigma.mk, 94 | assumption, 95 | rewrite [add.comm a_1 (of_nat (nat.succ nat.zero)), (add.assoc a (of_nat (nat.succ nat.zero)) a_1)⁻¹], 96 | assumption 97 | end 98 | 99 | 100 | 101 | theorem of_nat_lt_of_nat (n m : ℕ) : of_nat n < of_nat m ↔ n < m := 102 | calc 103 | of_nat n < of_nat m ↔ of_nat n + 1 ≤ of_nat m : iff.refl 104 | ... ↔ of_nat (nat.succ n) ≤ of_nat m : of_nat_succ n ▸ !iff.refl 105 | ... ↔ nat.succ n ≤ m : of_nat_le_of_nat 106 | ... ↔ n < m : iff.symm (lt_iff_succ_le _ _) 107 | 108 | theorem lt_of_of_nat_lt_of_nat {m n : ℕ} (H : of_nat m < of_nat n) : #nat m < n := iff.mp !of_nat_lt_of_nat H 109 | 110 | theorem of_nat_lt_of_nat_of_lt {m n : ℕ} (H : #nat m < n) : of_nat m < of_nat n := iff.mp' !of_nat_lt_of_nat H 111 | 112 | /- show that the integers form an ordered additive group -/ 113 | 114 | theorem le.refl (a : ℤ) : a ≤ a := 115 | le.intro (add_zero a) 116 | 117 | theorem le.trans {a b c : ℤ} (H1 : a ≤ b) (H2 : b ≤ c) : a ≤ c := 118 | obtain (n : ℕ) (Hn : a + n = b), from le.elim H1, 119 | obtain (m : ℕ) (Hm : b + m = c), from le.elim H2, 120 | have a + of_nat (n + m) = c, from 121 | calc 122 | a + of_nat (n + m) = a + (of_nat n + m) : {of_nat_add n m} 123 | ... = a + n + m : (add.assoc a n m)⁻¹ 124 | ... = b + m : {Hn} 125 | ... = c : Hm, 126 | le.intro this 127 | 128 | theorem le.antisymm : Π {a b : ℤ}, a ≤ b → b ≤ a → a = b := 129 | take a b : ℤ, assume (H₁ : a ≤ b) (H₂ : b ≤ a), 130 | obtain (n : ℕ) (Hn : a + n = b), from le.elim H₁, 131 | obtain (m : ℕ) (Hm : b + m = a), from le.elim H₂, 132 | have a + of_nat (n + m) = a + 0, from 133 | calc 134 | a + of_nat (n + m) = a + (of_nat n + m) : of_nat_add 135 | ... = a + n + m : add.assoc 136 | ... = b + m : Hn 137 | ... = a : Hm 138 | ... = a + 0 : add_zero, 139 | have of_nat (n + m) = of_nat 0, from add.left_cancel this, 140 | have n + m = 0, from of_nat.inj this, 141 | have n = 0, from nat.eq_zero_of_add_eq_zero_right this, 142 | show a = b, from 143 | calc 144 | a = a + 0 : add_zero 145 | ... = a + n : this 146 | ... = b : Hn 147 | 148 | theorem lt.irrefl (a : ℤ) : ¬ a < a := 149 | (suppose a < a, 150 | obtain (n : ℕ) (Hn : a + succ n = a), from lt.elim this, 151 | have a + succ n = a + 0, from 152 | Hn ⬝ !add_zero⁻¹, 153 | !succ_ne_zero (of_nat.inj (add.left_cancel this))) 154 | 155 | theorem ne_of_lt {a b : ℤ} (H : a < b) : a ≠ b := 156 | (suppose a = b, absurd (this ▸ H) (lt.irrefl b)) 157 | 158 | theorem le_of_lt {a b : ℤ} (H : a < b) : a ≤ b := 159 | obtain (n : ℕ) (Hn : a + succ n = b), from lt.elim H, 160 | le.intro Hn 161 | 162 | theorem lt_iff_le_and_ne (a b : ℤ) : a < b ↔ (a ≤ b × a ≠ b) := 163 | iff.intro 164 | (assume H, pair (le_of_lt H) (ne_of_lt H)) 165 | (assume H, 166 | have a ≤ b, from prod.pr1 H, 167 | have a ≠ b, from prod.pr2 H, 168 | obtain (n : ℕ) (Hn : a + n = b), from le.elim `a ≤ b`, 169 | have n ≠ 0, from (assume H' : n = 0, `a ≠ b` (!add_zero ▸ H' ▸ Hn)), 170 | obtain (k : ℕ) (Hk : n = nat.succ k), from nat.exists_eq_succ_of_ne_zero this, 171 | lt.intro (Hk ▸ Hn)) 172 | 173 | theorem le_iff_lt_or_eq (a b : ℤ) : a ≤ b ↔ (a < b ⊎ a = b) := 174 | iff.intro 175 | (assume H, 176 | by_cases 177 | (suppose a = b, sum.inr this) 178 | (suppose a ≠ b, 179 | obtain (n : ℕ) (Hn : a + n = b), from le.elim H, 180 | have n ≠ 0, from (assume H' : n = 0, `a ≠ b` (!add_zero ▸ H' ▸ Hn)), 181 | obtain (k : ℕ) (Hk : n = nat.succ k), from nat.exists_eq_succ_of_ne_zero this, 182 | sum.inl (lt.intro (Hk ▸ Hn)))) 183 | (assume H, 184 | sum.rec_on H 185 | (assume H1, le_of_lt H1) 186 | (assume H1, H1 ▸ !le.refl)) 187 | 188 | theorem lt_succ (a : ℤ) : a < a + 1 := 189 | le.refl (a + 1) 190 | 191 | theorem add_le_add_left {a b : ℤ} (H : a ≤ b) (c : ℤ) : c + a ≤ c + b := 192 | obtain (n : ℕ) (Hn : a + n = b), from le.elim H, 193 | have H2 : c + a + n = c + b, from 194 | calc 195 | c + a + n = c + (a + n) : add.assoc c a n 196 | ... = c + b : {Hn}, 197 | le.intro H2 198 | 199 | theorem add_lt_add_left {a b : ℤ} (H : a < b) (c : ℤ) : c + a < c + b := 200 | let H' := le_of_lt H in 201 | (iff.mp' (lt_iff_le_and_ne _ _)) (pair (add_le_add_left H' _) 202 | (take Heq, let Heq' := add_left_cancel Heq in 203 | !lt.irrefl (Heq' ▸ H))) 204 | 205 | theorem mul_nonneg {a b : ℤ} (Ha : 0 ≤ a) (Hb : 0 ≤ b) : 0 ≤ a * b := 206 | obtain (n : ℕ) (Hn : 0 + n = a), from le.elim Ha, 207 | obtain (m : ℕ) (Hm : 0 + m = b), from le.elim Hb, 208 | le.intro 209 | (inverse 210 | (calc 211 | a * b = (0 + n) * b : Hn 212 | ... = n * b : nat.zero_add 213 | ... = n * (0 + m) : {Hm⁻¹} 214 | ... = n * m : nat.zero_add 215 | ... = 0 + n * m : zero_add)) 216 | 217 | theorem mul_pos {a b : ℤ} (Ha : 0 < a) (Hb : 0 < b) : 0 < a * b := 218 | obtain (n : ℕ) (Hn : 0 + nat.succ n = a), from lt.elim Ha, 219 | obtain (m : ℕ) (Hm : 0 + nat.succ m = b), from lt.elim Hb, 220 | lt.intro 221 | (inverse 222 | (calc 223 | a * b = (0 + nat.succ n) * b : Hn 224 | ... = nat.succ n * b : nat.zero_add 225 | ... = nat.succ n * (0 + nat.succ m) : {Hm⁻¹} 226 | ... = nat.succ n * nat.succ m : nat.zero_add 227 | ... = of_nat (nat.succ n * nat.succ m) : of_nat_mul 228 | ... = of_nat (nat.succ n * m + nat.succ n) : nat.mul_succ 229 | ... = of_nat (nat.succ (nat.succ n * m + n)) : nat.add_succ 230 | ... = 0 + nat.succ (nat.succ n * m + n) : zero_add)) 231 | 232 | 233 | theorem zero_lt_one : (0 : ℤ) < 1 := unit.star 234 | 235 | theorem not_le_of_gt {a b : ℤ} (H : a < b) : ¬ b ≤ a := 236 | assume Hba, 237 | let Heq := le.antisymm (le_of_lt H) Hba in 238 | !lt.irrefl (Heq ▸ H) 239 | 240 | theorem lt_of_lt_of_le {a b c : ℤ} (Hab : a < b) (Hbc : b ≤ c) : a < c := 241 | let Hab' := le_of_lt Hab in 242 | let Hac := le.trans Hab' Hbc in 243 | (iff.mp' !lt_iff_le_and_ne) (pair Hac 244 | (assume Heq, not_le_of_gt (Heq ▸ Hab) Hbc)) 245 | 246 | theorem lt_of_le_of_lt {a b c : ℤ} (Hab : a ≤ b) (Hbc : b < c) : a < c := 247 | let Hbc' := le_of_lt Hbc in 248 | let Hac := le.trans Hab Hbc' in 249 | (iff.mp' !lt_iff_le_and_ne) (pair Hac 250 | (assume Heq, not_le_of_gt (Heq⁻¹ ▸ Hbc) Hab)) 251 | 252 | section migrate_algebra 253 | open [classes] algebra 254 | 255 | --print fields linear_ordered_comm_ring 256 | 257 | protected definition linear_ordered_comm_ring [reducible] : 258 | algebra.linear_ordered_comm_ring int := 259 | ⦃algebra.linear_ordered_comm_ring, int.integral_domain, 260 | le := le, 261 | le_refl := le.refl, 262 | le_trans := @le.trans, 263 | le_antisymm := @le.antisymm, 264 | lt := lt, 265 | -- le_of_lt := @le_of_lt, 266 | -- lt_irrefl := lt.irrefl, 267 | -- lt_of_lt_of_le := @lt_of_lt_of_le, 268 | -- lt_of_le_of_lt := @lt_of_le_of_lt, 269 | add_le_add_left := @add_le_add_left, 270 | mul_nonneg := @mul_nonneg, 271 | mul_pos := @mul_pos, 272 | lt_iff_le_and_ne := lt_iff_le_and_ne, 273 | le_iff_lt_or_eq := le_iff_lt_or_eq, 274 | le_total := le.total, 275 | zero_ne_one := zero_ne_one 276 | -- zero_lt_one := zero_lt_one, 277 | -- add_lt_add_left := @add_lt_add_left 278 | ⦄ 279 | 280 | protected definition decidable_linear_ordered_comm_ring [reducible] : 281 | algebra.decidable_linear_ordered_comm_ring int := 282 | ⦃algebra.decidable_linear_ordered_comm_ring, 283 | int.linear_ordered_comm_ring, 284 | decidable_lt := decidable_lt⦄ 285 | 286 | local attribute int.integral_domain [instance] 287 | local attribute int.linear_ordered_comm_ring [instance] 288 | local attribute int.decidable_linear_ordered_comm_ring [instance] 289 | 290 | definition ge [reducible] (a b : ℤ) := algebra.has_le.ge a b 291 | definition gt [reducible] (a b : ℤ) := algebra.has_lt.gt a b 292 | infix >= := int.ge 293 | infix ≥ := int.ge 294 | infix > := int.gt 295 | definition decidable_ge [instance] (a b : ℤ) : decidable (a ≥ b) := 296 | show decidable (b ≤ a), from _ 297 | definition decidable_gt [instance] (a b : ℤ) : decidable (a > b) := 298 | show decidable (b < a), from _ 299 | -- definition min : ℤ → ℤ → ℤ := algebra.min 300 | -- definition max : ℤ → ℤ → ℤ := algebra.max 301 | definition abs : ℤ → ℤ := algebra.abs 302 | definition sign : ℤ → ℤ := algebra.sign 303 | 304 | migrate from algebra with int 305 | replacing has_le.ge → ge, has_lt.gt → gt, dvd → dvd, sub → sub, -- min → min, max → max, 306 | abs → abs, sign → sign 307 | 308 | attribute le.trans ge.trans lt.trans gt.trans [trans] 309 | attribute lt_of_lt_of_le lt_of_le_of_lt gt_of_gt_of_ge gt_of_ge_of_gt [trans] 310 | end migrate_algebra 311 | 312 | /- more facts specific to int -/ 313 | 314 | theorem of_nat_nonneg (n : ℕ) : 0 ≤ of_nat n := unit.star 315 | 316 | theorem of_nat_pos {n : ℕ} (Hpos : #nat n > 0) : of_nat n > 0 := 317 | of_nat_lt_of_nat_of_lt Hpos 318 | 319 | theorem of_nat_succ_pos (n : nat) : of_nat (nat.succ n) > 0 := 320 | of_nat_pos !nat.succ_pos 321 | 322 | theorem exists_eq_of_nat {a : ℤ} (H : 0 ≤ a) : Σn : ℕ, a = of_nat n := 323 | obtain (n : ℕ) (H1 : 0 + of_nat n = a), from le.elim H, 324 | sigma.mk n (!zero_add ▸ (H1⁻¹)) 325 | 326 | theorem exists_eq_neg_of_nat {a : ℤ} (H : a ≤ 0) : Σn : ℕ, a = -(of_nat n) := 327 | have -a ≥ 0, from iff.mp' !neg_nonneg_iff_nonpos H, 328 | obtain (n : ℕ) (Hn : -a = of_nat n), from exists_eq_of_nat this, 329 | sigma.mk n (eq_neg_of_eq_neg (Hn⁻¹)) 330 | 331 | theorem of_nat_nat_abs_of_nonneg {a : ℤ} (H : a ≥ 0) : of_nat (nat_abs a) = a := 332 | obtain (n : ℕ) (Hn : a = of_nat n), from exists_eq_of_nat H, 333 | Hn⁻¹ ▸ ap of_nat (nat_abs_of_nat n) 334 | 335 | theorem of_nat_nat_abs_of_nonpos {a : ℤ} (H : a ≤ 0) : of_nat (nat_abs a) = -a := 336 | have -a ≥ 0, from iff.mp' !neg_nonneg_iff_nonpos H, 337 | calc 338 | of_nat (nat_abs a) = of_nat (nat_abs (-a)) : nat_abs_neg 339 | ... = -a : of_nat_nat_abs_of_nonneg this 340 | 341 | theorem of_nat_nat_abs (b : ℤ) : nat_abs b = abs b := 342 | sum.rec_on (le.total 0 b) 343 | (assume H : b ≥ 0, of_nat_nat_abs_of_nonneg H ⬝ (abs_of_nonneg H)⁻¹) 344 | (assume H : b ≤ 0, of_nat_nat_abs_of_nonpos H ⬝ (abs_of_nonpos H)⁻¹) 345 | 346 | theorem nat_abs_abs (a : ℤ) : nat_abs (abs a) = nat_abs a := 347 | abs.by_cases rfl !nat_abs_neg 348 | 349 | theorem lt_of_add_one_le {a b : ℤ} (H : int.add a (of_nat (nat.succ nat.zero)) ≤ b) : a < b := 350 | obtain n (H1 : int.add (int.add a (of_nat (nat.succ nat.zero))) n = b), from le.elim H, 351 | have a + succ n = b, by rewrite [-H1, add.assoc, add.comm (of_nat (nat.succ nat.zero))], 352 | lt.intro this 353 | 354 | theorem add_one_le_of_lt {a b : ℤ} (H : a < b) : int.add a (of_nat (nat.succ nat.zero)) ≤ b := 355 | obtain n (H1 : int.add a (succ n) = b), from lt.elim H, 356 | have int.add (int.add a 1) n = b, by rewrite [-H1, add.assoc, add.comm 1], 357 | le.intro this 358 | 359 | theorem lt_add_one_of_le {a b : ℤ} (H : a ≤ b) : a < b + 1 := 360 | lt_add_of_le_of_pos H unit.star 361 | 362 | theorem le_of_lt_add_one {a b : ℤ} (H : a < b + 1) : a ≤ b := 363 | have H1 : a + 1 ≤ b + 1, from add_one_le_of_lt H, 364 | le_of_add_le_add_right H1 365 | 366 | theorem sub_one_le_of_lt {a b : ℤ} (H : a ≤ b) : a - 1 < b := 367 | lt_of_add_one_le (!sub_add_cancel⁻¹ ▸ H) 368 | 369 | theorem lt_of_sub_one_le {a b : ℤ} (H : a - 1 < b) : a ≤ b := 370 | !sub_add_cancel ▸ add_one_le_of_lt H 371 | 372 | theorem le_sub_one_of_lt {a b : ℤ} (H : a < b) : a ≤ b - 1 := 373 | le_of_lt_add_one (!sub_add_cancel⁻¹ ▸ H) 374 | 375 | theorem lt_of_le_sub_one {a b : ℤ} (H : a ≤ b - 1) : a < b := 376 | !sub_add_cancel ▸ (lt_add_one_of_le H) 377 | 378 | theorem sign_of_succ (n : nat) : sign (nat.succ n) = 1 := 379 | sign_of_pos (of_nat_pos !nat.succ_pos) 380 | 381 | theorem exists_eq_neg_succ_of_nat {a : ℤ} : a < 0 → Σm : ℕ, a = int.neg_succ_of_nat m := 382 | int.cases_on a 383 | (take m H, absurd (of_nat_nonneg m : 0 ≤ m) (not_le_of_gt H)) 384 | (take m H, sigma.mk m rfl) 385 | 386 | theorem eq_one_of_mul_eq_one_right {a b : ℤ} (H : a ≥ 0) (H' : a * b = 1) : a = 1 := 387 | have a * b > 0, by rewrite H'; apply unit.star, 388 | have b > 0, from pos_of_mul_pos_left this H, 389 | have a > 0, from pos_of_mul_pos_right `a * b > 0` (le_of_lt `b > 0`), 390 | sum.rec_on (le_or_gt a 1) 391 | (suppose a ≤ 1, 392 | show a = 1, from le.antisymm this (add_one_le_of_lt `a > 0`)) 393 | (suppose a > 1, 394 | assert a * b ≥ 2 * 1, 395 | from mul_le_mul (add_one_le_of_lt `a > 1`) (add_one_le_of_lt `b > 0`) unit.star H, 396 | have empty, by rewrite [H' at this]; exact this, 397 | empty.elim this) 398 | 399 | theorem eq_one_of_mul_eq_one_left {a b : ℤ} (H : b ≥ 0) (H' : a * b = 1) : b = 1 := 400 | eq_one_of_mul_eq_one_right H (!mul.comm ▸ H') 401 | 402 | theorem eq_one_of_mul_eq_self_left {a b : ℤ} (Hpos : a ≠ 0) (H : b * a = a) : b = 1 := 403 | eq_of_mul_eq_mul_right Hpos (H ⬝ (one_mul a)⁻¹) 404 | 405 | theorem eq_one_of_mul_eq_self_right {a b : ℤ} (Hpos : b ≠ 0) (H : b * a = b) : a = 1 := 406 | eq_one_of_mul_eq_self_left Hpos (!mul.comm ▸ H) 407 | 408 | theorem eq_one_of_dvd_one {a : ℤ} (H : a ≥ 0) (H' : a ∣ 1) : a = 1 := 409 | dvd.elim H' 410 | (take b, 411 | suppose 1 = a * b, 412 | eq_one_of_mul_eq_one_right H this⁻¹) 413 | 414 | end int 415 | -------------------------------------------------------------------------------- /infinitraverse/IT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, StandaloneDeriving, UndecidableInstances, PolyKinds, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, RankNTypes, TupleSections #-} 2 | 3 | module IT where 4 | import Control.Monad.Identity 5 | import Control.Monad.Reader 6 | import Control.Monad.Writer 7 | import Control.Monad.State 8 | import Data.Functor.Compose 9 | import Debug.Trace 10 | import Control.Applicative 11 | 12 | 13 | {- 14 | traversal needs to be with a free monoid in the topos of trees 15 | http://comonad.com/reader/2015/free-monoids-in-haskell/ 16 | 17 | in the topos of trees should still be a corresp between poly endofunctor and containers 18 | 19 | what subset of containers gets picked out by guarded recursive datatypes 20 | 21 | Later f a -> f Later a 22 | 23 | "predict" 24 | 25 | Predictable applicatives -- credit james 26 | 27 | Unpredictable traversals can't be infinite 28 | 29 | Last applicative over a biinfinite list 30 | 31 | -} 32 | 33 | -- Nakhano's later modality for guarded recursion, as an applicative functor a la "Productive Coprogramming with Guarded Recursion": https://bentnib.org/productive.pdf 34 | newtype Later a = Later a deriving (Functor, Show) 35 | 36 | instance Applicative Later where 37 | pure = Later 38 | Later f <*> Later x = Later (f x) 39 | 40 | lfix :: (Later a -> a) -> a 41 | lfix f = fix (f . Later) -- let x = f (pure x) in x 42 | 43 | data Stream a = Nil | Cons a (Later (Stream a)) deriving (Functor, Show) 44 | 45 | sinterleave :: Stream a -> Stream a -> Stream a 46 | sinterleave = lfix $ \f s1 s2 -> case s1 of 47 | (Cons x xs) -> Cons x (f <*> pure s2 <*> xs) 48 | _ -> s2 49 | 50 | szip :: Stream a -> Stream b -> Stream (a, b) 51 | szip = lfix $ \f s1 s2 -> case (s1, s2) of 52 | (Cons x xs, Cons y ys) -> Cons (x,y) (f <*> xs <*> ys) 53 | _ -> Nil 54 | 55 | class EvalLater a where 56 | type Result a 57 | leval :: a -> Result a 58 | 59 | instance EvalLater a => EvalLater (Later a) where 60 | type Result (Later a) = Result a 61 | leval (Later a) = leval a 62 | 63 | instance EvalLater Int where 64 | type Result Int = Int 65 | leval = id 66 | 67 | {- 68 | instance EvalLater a => EvalLater [a] where 69 | type Result [a] = [Result a] 70 | leval = fmap leval 71 | -} 72 | 73 | instance (EvalLater a, EvalLater b) => EvalLater (a, b) where 74 | type Result (a, b) = (Result a, Result b) 75 | leval (x, y) = (leval x, leval y) 76 | 77 | instance EvalLater a => EvalLater (Stream a) where 78 | type Result (Stream a) = [Result a] 79 | leval Nil = [] 80 | leval (Cons x xs) = leval x : leval xs 81 | 82 | data Delay a = Now a | Wait (Later (Delay a)) deriving (Show, Functor) 83 | 84 | instance Applicative Delay where 85 | 86 | slast :: Stream a -> Delay (Maybe a) 87 | slast = go Nothing 88 | where go = lfix $ \f def s1 -> 89 | case s1 of 90 | (Cons x xs) -> Wait $ f <*> pure (Just x) <*> xs 91 | Nil -> Now def 92 | 93 | 94 | data PStream a = 95 | PNil 96 | | PWait (Later (PStream a)) 97 | | PCons a (PStream a) 98 | 99 | instance EvalLater a => EvalLater (Delay a) where 100 | type Result (Delay a) = Result a 101 | leval (Now x) = leval x 102 | leval (Wait x) = leval x 103 | 104 | instance EvalLater a => EvalLater (PStream a) where 105 | type Result (PStream a) = [Result a] 106 | leval PNil = [] 107 | leval (PWait x) = leval x 108 | leval (PCons x xs) = leval x : leval xs 109 | 110 | class EvalLater a => LiftLater a where 111 | llift :: Result a -> a 112 | {- 113 | instance LiftLater a => LiftLater [a] where 114 | llift = fmap llift 115 | -} 116 | instance (LiftLater a, EvalLater b) => EvalLater (a -> b) where 117 | type Result (a -> b) = Result a -> Result b 118 | leval f = leval . f . llift 119 | 120 | instance (LiftLater a, LiftLater b) => LiftLater (a -> b) where 121 | llift f = llift . f . leval 122 | 123 | instance (LiftLater a) => LiftLater (Later a) where 124 | llift = Later . llift 125 | 126 | instance (LiftLater a, LiftLater b) => LiftLater (a, b) where 127 | llift (x, y) = (llift x, llift y) 128 | 129 | instance LiftLater Int where 130 | llift = id 131 | 132 | instance LiftLater a => LiftLater (Delay a) where 133 | llift = Now . llift 134 | 135 | {- 136 | predict' :: (Applicative f, Predict f, LiftLater (f a)) => Later (f a) -> f (Later a) 137 | predict' x = 138 | let s = ssequence (Cons (pure undefined) (fmap (\z -> Cons z (Later Nil)) x)) 139 | in fmap (\z -> case z of (Cons _ q) -> fmap (\r -> case r of (Cons t _) -> t) q) s 140 | -} 141 | 142 | sequenceL :: Applicative f => [f a] -> f [a] 143 | sequenceL = fix $ \rec x -> case x of 144 | [] -> pure [] 145 | (x:xs) -> (:) <$> x <*> rec xs 146 | 147 | sequenceS :: (Applicative f, Predict f) => Stream (f a) -> f (Stream a) 148 | sequenceS = lfix $ \rec x -> case x of 149 | Nil -> pure Nil 150 | Cons a s -> 151 | Cons 152 | <$> a 153 | <*> predict (rec <*> s) 154 | 155 | sequenceS' :: (a ~ Result a, EvalLater a, Applicative f, Predict f) => Stream (f a) -> f [a] 156 | sequenceS' z = fmap leval $ (fix $ \rec x -> case x of 157 | Nil -> pure Nil 158 | Cons a s -> 159 | Cons 160 | <$> a 161 | <*> predict (rec <$> s)) z 162 | 163 | 164 | sequenceS'' :: (LiftLater (Stream a), a ~ Result a, EvalLater a, Applicative f, Predict f) => Stream (f a) -> f [a] 165 | sequenceS'' z = (fix $ \rec x -> fmap leval $ case x of -- first outside then inside 166 | Nil -> pure Nil 167 | Cons a s -> 168 | Cons 169 | <$> a 170 | <*> predict (fmap llift . rec <$> s)) z 171 | 172 | sequenceS''' :: (LiftLater (Stream a), a ~ Result a, Result (f [a]) ~ f [a], EvalLater (f [a]), EvalLater a, Applicative f, Predict f) => Stream (f a) -> f [a] 173 | sequenceS''' = fix $ \rec x -> case x of -- first outside then inside 174 | Nil -> pure [] 175 | Cons a s -> 176 | (:) 177 | <$> a 178 | <*> leval (rec <$> s) 179 | 180 | 181 | sequenceS4 :: (Applicative f, EvalLater (f [a]), Result (f [a]) ~ f [a]) => Stream (f a) -> f [a] 182 | sequenceS4 = fix $ \rec x -> case x of -- first outside then inside 183 | Nil -> pure [] 184 | Cons a s -> 185 | (:) 186 | <$> a 187 | <*> leval (rec <$> s) 188 | 189 | {- 190 | sequenceS' :: (Applicative f, Predict f) => Stream (f Int) -> f [Int] 191 | sequenceS' = fix $ \rec x -> case x of 192 | Nil -> pure [] 193 | Cons a s -> 194 | (:) 195 | <$> a 196 | <*> fmap leval (predict (rec <$> s)) 197 | -} 198 | {- 199 | predict' x = 200 | let s = (lsl) (Cons (pure undefined) (fmap (\z -> Cons z (Later Nil)) x)) 201 | in fmap (\z -> case z of (Cons _ q) -> fmap (\r -> case r of (Cons t _) -> t) q) s 202 | -} 203 | {- 204 | sequenceS = fix $ \rec x -> case x of 205 | Nil -> pure Nil 206 | Cons a s -> Cons <$> a <*> predict ((rec . Later) <*> s) 207 | -} 208 | 209 | -- predictCont :: Later ((a -> Int) -> Int) -> (Later a -> Int) -> Int 210 | -- predictCont x = \k -> _ (x <*> _ k) 211 | 212 | 213 | -- not really a monoid at all, its a tensor over later?? also we have Stream (Later a) -> Later (Stream a) 214 | -- so its f a -> f (Later a) -> f a 215 | -- can write append in terms of that 216 | -- can write as stream = a : Later a : Later Later a, etc 217 | 218 | -- actually, given a stream of length n, we can cons on a stream with n laters, so its bi-indexed objects (length and later depth) and the result is the length of the two summed. -- 219 | 220 | -- it becomes a graded monoid if we lift the left until it fits, but then you get this weird indexing summation. 221 | -- so its abolutely Not Free. 222 | 223 | instance Semigroup a => Semigroup (Stream a) where 224 | (<>) = lfix $ \f x y -> 225 | case (x, y) of 226 | (Nil, _) -> y 227 | (_, Nil) -> x 228 | (Cons a s, Cons b s') -> Cons (a <> b) (f <*> s <*> s') 229 | 230 | instance Monoid a => Monoid (Stream a) where 231 | mempty = Cons mempty (Later Nil) 232 | 233 | shiftStream :: Monoid a => Later (Stream a) -> Stream a 234 | shiftStream = Cons mempty 235 | 236 | 237 | -- can we use lattice theory to get infinite monoid generalizations? 238 | 239 | -- can we sequence a stream of streams? 240 | 241 | -- credit for name predict to James Deikun 242 | 243 | class Predict f where 244 | predict :: Later (f a) -> f (Later a) 245 | -- can't give check :: f (Later a) -> Later (f a) because of reader. 246 | -- this really blows up in the case of the update monad. 247 | -- we can factorize out the delay in the state, but that's sort of uninteresting 248 | -- delay :: f a -> f a 249 | 250 | -- we need an evaluate morphism :: f a -> Eventually (f a) and the property that delay . evaluate = id. delay should be uniquely defined by the predict . pure equation. 251 | 252 | -- the law should be an interaction with applicative 253 | -- fmap Later . liftA2 (,) x == liftA2 (,) x . predict . Later !!!! 254 | 255 | -- or rather 256 | -- \x y -> (fmap (fmap Later) . liftA2 (,) x) y == (liftA2 (,) x . predict . Later) y 257 | 258 | testProp x y = (fmap (fmap Later) . liftA2 (,) x) y == (liftA2 (,) x . predict . Later) y 259 | 260 | testProp1 x y = (fmap (fmap Later) . liftA2 (,) x) y 261 | 262 | testProp2 x y = (liftA2 (,) x . predict . Later) y 263 | 264 | w1 = tell (Cons 1 (Later Nil)) :: Writer (Stream (Sum Int)) () 265 | w2 = tell (Cons 3 (Later Nil)) :: Writer (Stream (Sum Int)) () 266 | 267 | -- sidenote: we can anti-commute a reader over finite but not in general 268 | foo :: (Bool -> Later a) -> Later (Bool -> a) 269 | foo f = (\t f x -> if x then t else f) <$> (f True) <*> (f False) 270 | 271 | -- predict . pure = fmap Later . delay 272 | -- sequence . fmap pure = delay^n . pure ? 273 | 274 | -- check :: f a -> Eventually f a 275 | -- check . delay =~ id 276 | -- recover . predict =~ id 277 | 278 | -- law for diff. not exactly if you erase laters you get the same thing. 279 | -- take law for traversals, put in this setting, induce a law for Predict 280 | -- distributive law, sort of? 281 | 282 | -- we can state the traversable law with delay, but we need recover or the like to state the full diff law! 283 | 284 | -- any structure that's traversable is infinitely traversable, prove this 285 | 286 | instance Predict Later where 287 | predict = id 288 | 289 | instance Predict Identity where 290 | predict = Identity . fmap runIdentity 291 | 292 | instance Predict (Reader r) where 293 | predict x = reader $ \r -> fmap (($ r) . runReader) x 294 | 295 | instance Monoid w => Predict (Writer (Stream w)) where 296 | predict x = writer $ (fst . runWriter <$> x, shiftStream $ snd . runWriter <$> x) 297 | 298 | 299 | instance Monoid w => Monoid (Delay w) where 300 | instance Semigroup w => Semigroup (Delay w) where 301 | 302 | instance Monoid w => Predict (Writer (Delay w)) where 303 | predict x = writer $ (fst . runWriter <$> x, Wait $ snd . runWriter <$> x) 304 | 305 | 306 | instance Monoid (PStream a) 307 | instance Semigroup (PStream a) 308 | instance Predict (Writer (PStream a)) where 309 | predict x = writer $ (fst . runWriter <$> x, PWait $ snd . runWriter <$> x) 310 | 311 | class Sequence t where 312 | ssequence :: (Applicative f, Predict f) => t (f a) -> f (t a) 313 | 314 | instance Sequence Stream where 315 | ssequence = lfix $ \rec x -> case x of 316 | Nil -> pure Nil 317 | Cons a s -> Cons <$> a <*> predict (rec <*> s) 318 | 319 | data Tree a = TNil | TBranch a (Later (Tree a)) (Later (Tree a)) deriving (Functor, Show) 320 | 321 | instance Sequence Tree where 322 | ssequence = lfix $ \rec x -> case x of 323 | TNil -> pure TNil 324 | TBranch a x y -> TBranch <$> a <*> predict (rec <*> x) <*> predict (rec <*> y) 325 | 326 | instance (Functor f, Predict f, Predict g) => Predict (Compose f g) where 327 | predict = Compose . fmap predict . predict . fmap getCompose 328 | 329 | {- 330 | data Update s a = Update {runUpdate :: (Stream s -> (Stream s,a))} deriving Functor -- stream of s to single s 331 | 332 | instance Monoid s => Applicative (Update s) where 333 | pure x = Update $ \s -> (s, x) 334 | f <*> x = ap f x 335 | 336 | instance Monoid s => Monad (Update s) where 337 | Update x >>= f = Update $ \s -> let (u, x') = x s in runUpdate (f x') (u <> s) 338 | 339 | instance Monoid s => Predict (Update s) where 340 | predict x = Update $ \s -> let rxs = fmap (($ s) . runUpdate) x in 341 | (shiftStream (fmap fst rxs), fmap snd rxs) 342 | 343 | -} 344 | 345 | listToStream (x:xs) = Cons x . Later $ listToStream xs 346 | listToStream [] = Nil 347 | 348 | finiteStream :: Stream Int 349 | finiteStream = Cons 1 . Later . Cons 2 . Later . Cons 4 . Later $ Nil 350 | 351 | headS (Cons a _) = a 352 | headS Nil = mempty 353 | 354 | tailS (Cons _ x) = x 355 | tailS Nil = Later Nil 356 | 357 | {- 358 | updateStream :: Stream (Update (Sum Int) Int) 359 | updateStream = listToStream [getU $ getSum . headS, putU 1 2, getU $ getSum . headS, putU 4 6, getU $ getSum . headS] 360 | 361 | putU :: a -> b -> Update a b 362 | putU x b = Update $ \s -> (Cons x $ Later Nil, b) 363 | 364 | getU :: (Stream s -> a) -> Update s a 365 | getU f = Update $ \s -> (Nil, f s) 366 | 367 | goU (Update f) = f Nil 368 | -} 369 | 370 | 371 | instance Monoid s => Predict (State (Stream s)) where 372 | predict x = state $ \s -> let rs = fmap (`runState` s) x 373 | in (fmap fst rs, shiftStream (fmap snd rs)) 374 | 375 | instance Predict (State s) where 376 | predict x = state $ \s -> let rs = fmap (`runState` s) x 377 | in (fmap fst rs, undefined (fmap snd rs)) 378 | 379 | 380 | one :: a -> Stream a 381 | one x = Cons x $ Later Nil 382 | 383 | stateStream :: Stream (State (Stream (Sum Int)) Int) 384 | stateStream = listToStream [getSum . headS <$> get, put (one 1) >> pure 2, getSum . headS <$> get, put (one 4) >> pure 6, getSum . headS <$> get] 385 | 386 | straverse g = ssequence . fmap g 387 | 388 | data Update p s a = Update {runUpdate :: s -> (p, a)} deriving Functor 389 | 390 | class (Monoid p) => ApplyAction p s 391 | where 392 | applyAction :: p -> s -> s 393 | 394 | instance (ApplyAction p s) => Applicative (Update p s) where 395 | pure a = Update $ \_ -> (mempty, a) 396 | Update u <*> Update t = 397 | Update $ \s 398 | -- Run the first 'Update' with the initial state 399 | -- and get the monoidal action and the function out 400 | -> 401 | let (p, f) = u s 402 | -- Run the second 'Update' with a state which has been altered by 403 | -- the first action to get the 'a' and another action 404 | (p', a) = t (applyAction p s) 405 | -- Combine the actions together and run the function 406 | in (p' <> p, f a) 407 | 408 | instance (ApplyAction p s) => Monad (Update p s) where 409 | Update u >>= f = 410 | Update $ \s 411 | -- Run the first 'Update' with the initial state 412 | -- and get the monoidal action and the function out 413 | -> 414 | let (p, a) = u s 415 | -- Run the given function over our resulting value to get our next Update 416 | Update t = f a 417 | -- Run our new 'Update' over the altered state 418 | (p', a') = t (applyAction p s) 419 | -- Combine the actions together and return the result 420 | in (p <> p', a') 421 | 422 | 423 | instance Predict (Update p s) where 424 | predict x = Update $ \s -> ppair (($s) . runUpdate <$> x) 425 | where 426 | ppair :: Later (p, a) -> (p, Later a) 427 | ppair p = (undefined (fst <$> p), snd <$> p) 428 | 429 | 430 | -- update is better than state. 431 | 432 | -- Eventually vs. Stream. "partial accumulation over time" 433 | 434 | -- interesting example -- iterate over a stream of data, producing a stream of of observation and also output data 435 | 436 | -- this is precisely stream transducers 437 | 438 | -- nb, can predict necessarily infinite streams, but not possibly terminating ones -- gotta write a distinct stram type 439 | 440 | instance Applicative Stream where 441 | pure a = Cons a . Later $ pure a 442 | (<*>) = lfix $ \rec s1 s2 -> case (s1, s2) of 443 | (Cons x xs, Cons y ys) -> Cons (x y) (rec <*> xs <*> ys) 444 | (Nil,_) -> Nil 445 | (_,Nil) -> Nil 446 | 447 | {- 448 | -- can't work because we only do infinite streams, and the "crossy" stream applicative is necessarily not infinite given the pure instance 449 | instance Applicative Stream where 450 | pure a = Cons a . Later $ Nil 451 | (<*>) = lfix $ \rec s1 s2 -> case (s1, s2) of 452 | (Nil,_) -> Nil 453 | (_,Nil) -> Nil 454 | (Cons x xs, _) -> fmap x s2 `sappend` (rec <*> xs <*> Later s2) 455 | where sappend :: Stream a -> Later (Stream a) -> Stream a 456 | sappend xs (Later ys) = trace "sappend" $ listToStream (streamToList xs <> streamToList ys) 457 | -} 458 | 459 | instance Predict Stream where 460 | predict x = Cons (fmap headPartial x) (fmap (predict . tailPartial) x) -- not using lfix? 461 | where headPartial (Cons e _) = e 462 | headPartial _ = error "headPartial" -- works for infinite streams but not normal streams. 463 | tailPartial (Cons x xs) = xs 464 | tailPartial Nil = error "nil" 465 | 466 | tfS = listToStream [True, False] 467 | 468 | streamToList Nil = [] 469 | streamToList (Cons a (Later b)) = a : streamToList b 470 | 471 | -- on infinite streams, can transpose an infinite stream of infinite streams using the zip applicative. 472 | 473 | -- can we even speak of the list applicative? 474 | 475 | -- ssequence . listToStream $ repeat tfS 476 | 477 | {- 478 | 479 | we've shown diff -> ssequence 480 | can we show ssequence -> diff? 481 | 482 | lseq :: Later (f a) -> f (Later a) -- i.e. diff is precisely sequence for Later (show it obeys laws??) 483 | 484 | -- given any x :: a, we have fmap (shead . stail) (cons (pure x) (fmap ssingleton z)) 485 | 486 | 487 | -} 488 | 489 | {- 490 | Laws for ssequence: 491 | ssequence . fmap Identity = Identity 492 | ssequence . fmap Compose = Compose . fmap ssequence . sseqence 493 | t . ssequence = ssequence . fmap t for every applicative transformation t or perhaps differential applicative transformation 494 | 495 | *IT> straverse pure finiteStream :: Writer (Stream Any) (Stream Int) 496 | WriterT (Identity (Cons 1 (Later (Cons 2 (Later (Cons 4 (Later Nil))))),Cons (Any {getAny = False}) (Later (Cons (Any {getAny = False}) (Later (Cons (Any {getAny = False}) (Later Nil))))))) 497 | 498 | -- we get a stream of results, but pure gives a single result! 499 | 500 | 501 | instance Sequence Stream where 502 | ssequence = lfix $ \rec x -> case x of 503 | Nil -> pure Nil 504 | Cons a s -> Cons <$> a <*> predict (rec <*> s) 505 | 506 | instance (Functor f, Diff f, Diff g) => Diff (Compose f g) where 507 | predict = Compose . fmap predict . predict . fmap getCompose 508 | 509 | -- sequence of a composed stream 510 | ssequence = case x of 511 | Nil -> pure Nil 512 | Cons a s -> Cons <$> a <*> (Compose . fmap predict . predict . fmap getCompose) (ssequence s) 513 | 514 | -- sequence of a plain stream 515 | ssequence = case x of 516 | Nil -> pure Nil 517 | Cons a s -> Cons <$> a <*> predict (ssequence s) 518 | 519 | -- fmap of sequence of a plain stream -- we substitute in the case on the created stream 520 | ssequence = case Cons a (predict (ssequence s)) of 521 | Cons a s1 -> Cons <$> a <*> predict (ssequence s1) 522 | 523 | -- substitute 524 | ssequence = case Cons a (predict (ssequence s)) of 525 | Cons a s1 -> Cons <$> a <*> predict (ssequence ((predict (ssequence s)))) 526 | 527 | -- ssequence doubled should somehow turn into needing to fmap the predict into it. 528 | 529 | -- equationally this should work, somehow 530 | 531 | -- naturality is tricky! 532 | 533 | -- can we prove a "representation theorem" for infinite traversals? 534 | https://www.cs.ox.ac.uk/jeremy.gibbons/publications/uitbaf.pdf 535 | 536 | -- predict . unpredict 537 | -} 538 | {- 539 | 540 | junk 541 | 542 | class LApplicative f i where 543 | lpure :: a -> f i a 544 | lap :: f i (a -> b) -> f (Compose Later i) a -> f i b 545 | 546 | class LDiff f where 547 | lpredict :: Later (f i a) -> f (Compose Later i) (Later a) 548 | lunpredict :: f i a -> f (Compose Later i) a 549 | 550 | class Sequence t where 551 | ssequence :: (Functor (f i), LApplicative f i, LDiff f) => t (f i a) -> f i (t a) 552 | 553 | -- sequence instances 554 | instance Sequence Stream where 555 | ssequence = lfix $ \rec x -> case x of 556 | Nil -> lpure Nil 557 | Cons a s -> (Cons <$> a) `lap` (lpredict $ rec <*> s) 558 | 559 | data Tree a = TNil | TBranch a (Later (Tree a)) (Later (Tree a)) deriving (Functor, Show) 560 | 561 | instance Sequence Tree where 562 | ssequence = lfix $ \rec x -> case x of 563 | TNil -> lpure TNil 564 | TBranch a x y -> (TBranch <$> a) `lap` (lpredict $ rec <*> x) `lap` (lpredict $ rec <*> y) 565 | 566 | 567 | -- lapplicative instances 568 | data IReader r i a = IReader {runIReader :: (r -> a)} 569 | 570 | instance LApplicative (IReader r) i where 571 | lpure = IReader . const 572 | lap (IReader f) (IReader x) = IReader $ \r -> (f r) (x r) 573 | 574 | instance LDiff (IReader r) where 575 | lpredict x = IReader $ \r -> fmap (($ r) . runIReader) x 576 | lunpredict (IReader x) = IReader x 577 | 578 | -- can pushindexing in to writer, get rid of it. 579 | 580 | data IWriter w i a = IWriter {runIWriter :: (i (Stream w), a)} 581 | 582 | 583 | instance (Monoid w, Applicative i, Diff i) => LApplicative (IWriter w) i where 584 | lpure x = IWriter (pure mempty, x) 585 | lap (IWriter (s, f)) (IWriter (s', x)) = IWriter (mappend <$> s <*> (fmap shiftStream . predict . getCompose $ s'), f x) 586 | 587 | -} 588 | -- what algebraic structure corresponds to trees? -------------------------------------------------------------------------------- /mltt/hott-mess.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ; HoTT MESS 3 | ; Homotopy Type Theory Mechanical Evaluator Specification and Simulator 4 | ; (c) Gershom Bazerman, 2015 5 | ; BSD(3) Licensed 6 | 7 | (require racket/match) 8 | 9 | ; a value is a basic space if it is 10 | ; a collection of basepoints and a sequence of higher paths 11 | ; conceptually (Objects : Int or Inf, Paths : (Count, Level -> (Count, Int -> (Int,Int)) 12 | ; a path is two functions, one going one way on values, one going the other... 13 | 14 | ; a type is a tag denoting a space and denoting a level 15 | 16 | ; a value is a point in a space if it is a pair (Int, Int) with the first tag the level and the second the index 17 | 18 | ; a space can also be a function. A function is a type tag, a level, and a function Int -> (Int,Int) 19 | ; with the two indicies being the level in the target type and the index of the new value 20 | 21 | ; an application is just a pair of a function and an argument as before 22 | 23 | ; a value is judged to be a type if it 24 | ; is a tag which corresponds to a space _or_ 25 | ; is a product of such tags either as a function or a pair _or_ 26 | ; it is a tag and a mapping of such tags to values judged as types (as a function or as a pair) 27 | ; is a tag and a pair of values and the index, in their type, of the path between them (an equality type) 28 | 29 | ; value formers 30 | (struct lam-pi (var vt body pathbody) #:transparent) 31 | (struct app-n (fun lvl arg) #:transparent) 32 | ; primitives 33 | (struct closure (typ body) #:transparent) 34 | (struct trustme (typ body) #:transparent) 35 | 36 | ; type formers 37 | (struct type-fun (dom codom) #:transparent) 38 | ; one basic type 39 | (define type-unit 'type-unit) 40 | (define unit-val 0) 41 | ; dependency 42 | (struct type-pi (var dom codom) #:transparent) 43 | (define type-type 'type) ;; inconsistent! 44 | ;paths 45 | (struct type-eq (type v1 v2) #:transparent) 46 | 47 | ; contexts 48 | (define (find-cxt nm cxt) 49 | (match (assoc nm cxt) [(cons a b) b] [_ #f])) 50 | 51 | (define (fresh-var nm cxt) 52 | (if (assoc nm cxt) (fresh-var (string->symbol (string-append (symbol->string nm) "'")) cxt) nm)) 53 | 54 | (define-syntax-rule (extend-cxt var vt cxt (newvar newcxt) body) 55 | (let* ([newvar (fresh-var var cxt)] 56 | [newcxt (cons (cons newvar vt) cxt)]) 57 | body)) 58 | 59 | ; a reduction of a value in a context creates a term where "app" is not in the head position. 60 | ; this is "weak head normal form" call-by-name reduction 61 | ; we call a term in such a form "reduced" or simply a "value" 62 | (define/match (reduce cxt body) 63 | ; To reduce an application of a function to an argument 64 | ; we confirm that the argument is compatible with the function 65 | ; and we produce the application of the function to the argument 66 | ; (if we omit the type check, we get nuprl semantics) 67 | [(_ (app-n (lam-pi var vt b pb) 0 arg)) 68 | (if (hasType? cxt arg vt) (reduce cxt (b arg)) 69 | (raise-arguments-error 'bad-type "bad type" 70 | "cxt" cxt "arg" arg "vt" vt "app" (lam-pi var vt b pb)))] 71 | [(_ (app-n (lam-pi var vt b pb) lvl arg)) 72 | (if (hasType? cxt arg vt) (reduce cxt (pb lvl arg)) 73 | (raise-arguments-error 'bad-type "bad type" 74 | "cxt" cxt "arg" arg "vt" vt "app" (lam-pi var vt b pb)))] 75 | ; To reduce an application of a closure to an argument, we produce a closure 76 | ; whose type is the application of the closure type to the argument type 77 | ; and whose body is the application of the closure body to the argument 78 | [(_ (app-n (closure ty b) lvl arg)) 79 | (closure (app-type cxt (red-eval cxt ty) lvl arg) (lambda (cxt) (app-n (b cxt) lvl arg)))] 80 | ; To reduce an application of anything else to an argument, we first reduce the thing itself 81 | ; and then attempt to again reduce the application of the result 82 | [(_ (app-n fun lvl arg)) (if (or (not fun) (symbol? fun)) 83 | (raise-arguments-error 'stuck "reduction stuck" 84 | "fun" fun "arg" arg) 85 | (reduce cxt (app-n (reduce cxt fun) lvl arg)))] 86 | [(_ _) body]) 87 | 88 | ; A red-eval of a term in a context creates a term where neither "app" nor "closure" are in the head position 89 | ; we call a term in such a form "evaluated" (or also, where evident, a "value"). 90 | (define (red-eval cxt x) 91 | (match (reduce cxt x) 92 | ; To red-eval a closure, we red-eval the application of the bbody of the closure to the context 93 | [(closure typ b) (red-eval cxt (b cxt))] 94 | [v v])) 95 | 96 | ; An application of a type to a term confirms the term is compatible with the type 97 | ; and if so, removes provides the new type that is the result of applying a term 98 | ; with the type to a term with the type of the argument 99 | (define/match (app-type cxt fun lvl arg) 100 | [(_ (type-fun a b) 0 _) 101 | (if (hasType? cxt arg a) b 102 | (raise-arguments-error 'bad-type "bad type applying in closure" "cxt" cxt "fun" fun "arg" arg))] 103 | [(_ (type-fun a b) n (type-eq argeq _ _)) 104 | (app-type cxt fun (- n 1) argeq)] 105 | [(_ (type-pi a at b) 0 _) 106 | (if (hasType? cxt arg a) (b arg) 107 | (raise-arguments-error 'bad-type "bad pi type applying in closure" "cxt" cxt "fun" fun "arg" arg))] 108 | [(_ (type-pi a at b) n (type-eq argeq _ _)) 109 | (app-type cxt fun (- n 1) argeq)] 110 | [(_ _ _ _) (raise-arguments-error 'bad-type "can't apply type in closure (fun and arg don't match)" "cxt" cxt "fun" fun "lvl" lvl "arg" arg)]) 111 | 112 | ; In all the following, judgment may be read as "verification" 113 | ; and "to judge" may be read as "to verify," "to know" or "two confirm" 114 | 115 | ; We may judge that an evaluated term is a type by the following rules 116 | (define (type? cxt t) 117 | (match (red-eval cxt t) 118 | ; We know a value is a type if we know that it is tagged type-fun 119 | ; and furthermore we know that its domain is a type and its codomain is a type 120 | [(type-fun a b) (and (type? cxt a) (type? cxt b))] 121 | ; We know a value is a type if it has the symbol 'type-unit 122 | ['type-unit #t] 123 | ; We know a value is a type in a context if it is a symbol and that context assigns it a type of type 124 | [(? symbol? vname) #:when (eq? type-type (find-cxt vname cxt)) #t] 125 | ; We know a value is a type if we know that it is tagged type-pi 126 | ; and furthermore we know that its domain is a type and in a context where 127 | ; its domain is assigned the proper type, its body can send the domain to a type. 128 | [(type-pi var a b) 129 | (and (type? cxt a) (extend-cxt var a cxt (newvar newcxt) (type? newcxt (b newvar))))] 130 | ; We know a value is a type if it has the symbol 'type 131 | ['type #t] 132 | ; We know a value is a type if it is an equality at a type TODO 133 | [(type-eq vt a b) 134 | (and (type? cxt vt) (hasType? cxt a vt) (hasType? cxt b vt))] 135 | ; Or, we know a value is a type if any other rules let us make such a judgment 136 | [t1 (type?-additional cxt t1)] 137 | )) 138 | 139 | ; We may judge that a reduced value has an evaluated type by the following rules 140 | (define (hasType? cxt x1 t1) 141 | (match* ((reduce cxt x1) (red-eval cxt t1)) 142 | ; To know a closure is of a type is to know that the type of the closure is equal to the desired type 143 | [((closure typ b) t) (eqType? cxt typ t)] 144 | ; To know a primitive is of a type is to know the type claimed by the primitive is equal to the desired type 145 | [((trustme typ b) t) (eqType? cxt typ t)] 146 | ; To know that a symbol has a type in a context is to know that the context assigns the symbol a type equal to the desired type 147 | [((? symbol? x) t) #:when (eqType? cxt t (find-cxt x cxt)) #t] 148 | ; To know that a lambda has type function is to know that 149 | ; the domain of the function type is equal to the input type of the body and to know that 150 | ; in a context where the argument is assigned the proper domain type 151 | ; the body in turn has a type of the codomain of the function type 152 | [((lam-pi vn vt body pb) (type-fun a b)) 153 | (and (eqType? cxt vt a) 154 | (extend-cxt vn vt cxt (newvar newcxt) (hasType? newcxt (body newvar) b)))] 155 | ; To know that a term has type unit is to know that it is the unit value 156 | [(x 'type-unit) (equal? x unit-val)] 157 | ; To know that a lambda has type pi is to know that 158 | ; the domain of the function type is equal to the input type of the body and to know that 159 | ; in a context where the argument is assigned the proper domain type 160 | ; the body in turn has a type of the codomain of the function type, as viewed in the same context 161 | ; todo match pathbodies? 162 | [((lam-pi vn vt body pb) (type-pi _ a b)) 163 | (and (eqType? cxt vt a) 164 | (extend-cxt vn vt cxt (newvar newcxt) 165 | (hasType? newcxt (body newvar) (reduce newcxt (b newvar)))))] 166 | ; To know that a term has type type is to know that the term may be judged a type 167 | [(x 'type) (type? cxt x)] 168 | ; To know that a value has type-eq is to know that 169 | ; there is some mechanism by which the value validates the equality 170 | [(x (type-eq vt a b)) 171 | (isPath? cxt x vt a b)] 172 | ; Or, to know that a term has any other type is to follow any additional rules 173 | ; on how we may judge the types of terms 174 | [(x t) (hasType?-additional cxt x t)])) 175 | 176 | ; We may judge that two evaluated values are equal as types by the following rules 177 | (define (eqType? cxt t1 t2) 178 | (match* ((red-eval cxt t1) (red-eval cxt t2)) 179 | ; To know two types tagged type-fun are equal is to know that 180 | ; they have terms equal as types in their domains and 181 | ; they have terms equal as types in their codomains 182 | [((type-fun a b) (type-fun a1 b1)) 183 | (and (eqType? cxt a a1) (eqType? cxt b b1))] 184 | ; To know two types tagged type-pi are equal is to know that 185 | ; they have terms equal as types in their domains and 186 | ; in a context where their arguments are assigned the proper domain type 187 | ; then their codomains also equal as types 188 | [((type-pi v a b) (type-pi v1 a1 b1)) 189 | (and (eqType? cxt a a1) 190 | (extend-cxt v a cxt (newvar newcxt) 191 | (eqType? newcxt (b newvar) (b1 newvar))))] 192 | ; To know two symbols are equal as types is to know that they are the same symbol 193 | [((? symbol? vname) (? symbol? vname1)) (eq? vname vname1)] 194 | ; To know that two types tagged as equalities are equal as types is to know that 195 | ; the types they equate are equal as types and 196 | ; their first values are equal at that type and 197 | ; their second values are equal at that type 198 | [((type-eq vt a b) (type-eq vt1 a1 b1)) 199 | (and (eqType? cxt vt vt1) 200 | (eqVal? cxt vt a a1) 201 | (eqVal? cxt vt1 b b1))] 202 | ; Or to know any other two values are equal as types is to follow any 203 | ; additional rules on how we may judge the equality of terms as types 204 | [(a b) (and a b (or (eqType?-additional cxt a b) 205 | (begin (printf "not equal\n ~a\n ~a\n cxt: ~a\n" a b cxt) #f)))])) 206 | 207 | ; We may judge that two evaluated values are equal at an evaluated type types by the following rules 208 | (define (eqVal? cxt typ v1 v2) 209 | (match* ((red-eval cxt typ) (red-eval cxt v1) (red-eval cxt v2)) 210 | ; To know two lambda terms are equal at a function type is to know that 211 | ; their domains are equal as types to the domain of the function type and 212 | ; in a context where their domains are assigned the proper input type 213 | ; then their bodies are equal at the type of the codomain 214 | ; TODO match path bodies? 215 | [((type-fun a b) (lam-pi x xt body pb) (lam-pi y yt body2 pb2)) 216 | (and (eqType? cxt a xt) (eqType? cxt a yt) 217 | (extend-cxt x xt cxt (newv newcxt) 218 | (eqVal? newcxt b (body newv) (body2 newv))))] 219 | ; To know two lambda terms are equal at a pi type is to know that 220 | ; their domains are equal as types to the domain of the function type and 221 | ; in a context where their domains are assigned the proper input type 222 | ; then their bodies are equal at the type of the codomain, as viewed in the same context 223 | ; TODO match path bodies? 224 | [((type-pi v a b) (lam-pi x xt body pb) (lam-pi y yt body2 pb2)) 225 | (and (eqType? cxt a xt) (eqType? cxt a yt) 226 | (extend-cxt x xt cxt (newv newcxt) 227 | (eqVal? newcxt (b newv) (body newv) (body2 newv))))] 228 | ; To know two values are equal at unit type 229 | ; requires knowing nothing else -- it is always known 230 | [('type-unit _ _) #t] 231 | ; To know two values are equal at a given equality type 232 | ; is _REALLY_ hard -- they must take equal points to equal points 233 | ; and also take equal paths to equal paths, etc. 234 | [((type-eq vt a b) x y) 235 | (eqPaths? cxt vt a b x y)] 236 | ; To know two values are equal at type type is to know that they are equal as types 237 | [('type a b) (eqType? cxt a b)] 238 | ; To know two symbols are equal at any type is to know that they are equal as symbols 239 | [(_ (? symbol? x) (? symbol? y)) #:when (eq? x y) #t] 240 | ; To know two primitives are equal at any type is to know their types are equal and know that 241 | ; their bodies are equal by primitive recursive comparison 242 | [(_ (trustme t v) (trustme t1 v1)) (and (eqType? cxt t t1) (equal? v v1))] ;if all else fails use primitive equality 243 | ; Or to know any other two values are equal at any other type is to follow any 244 | ; additional rules on how we may judge the equality of terms at types 245 | [(rtyp x y) (eqVal?-additional cxt rtyp x y)])) 246 | 247 | (define type-judgments '()) 248 | (define (type?-additional cxt t) 249 | (for/or ([p type-judgments]) (p cxt t))) 250 | 251 | (define hasType-judgments '()) 252 | (define (hasType?-additional cxt x t) 253 | (for/or ([p hasType-judgments]) (p cxt x t))) 254 | 255 | (define eqType-judgments '()) 256 | (define (eqType?-additional cxt t1 t2) 257 | (for/or ([p eqType-judgments]) (p cxt t1 t2))) 258 | 259 | (define eqVal-judgments '()) 260 | (define (eqVal?-additional cxt typ v1 v2) 261 | (for/or ([p eqVal-judgments]) (p cxt typ v1 v2))) 262 | 263 | ; To introduce a new type is to 264 | ; extend the ways to know a value is a type 265 | ; give a way to know a value has that type 266 | ; extend the ways to know two values are equal as types 267 | ; give a way to know two values are equal at that type 268 | 269 | (define (new-form type-judgment hasType-judgment eqType-judgment eqVal-judgment) 270 | (cond [type-judgment (set! type-judgments (cons type-judgment type-judgments))]) 271 | (cond [hasType-judgment (set! hasType-judgments (cons hasType-judgment hasType-judgments))]) 272 | (cond [eqType-judgment (set! eqType-judgments (cons eqType-judgment eqType-judgments))]) 273 | (cond [eqVal-judgment (set! eqVal-judgments (cons eqVal-judgment eqVal-judgments))]) 274 | ) 275 | 276 | 277 | (define isPath-judgments '()) 278 | (define (isPath? cxt typ path v1 v2) 279 | (for/or ([p isPath-judgments]) (p cxt typ path v1 v2))) 280 | 281 | (define eqPaths-judgments '()) 282 | (define (eqPaths? cxt typ v1 v2 p1 p2) 283 | (for/or ([p eqPaths-judgments]) (p cxt typ v1 v2 p1 p2))) 284 | 285 | (define (add-isPath isPath-judgment) 286 | (set! isPath-judgments (cons isPath-judgment isPath-judgments))) 287 | (define (add-eqPath eqPaths-judgment) 288 | (set! eqPaths-judgments (cons eqPaths-judgment eqPaths-judgments))) 289 | 290 | (struct path (constr pstart pend) #:transparent) 291 | 292 | ; Correct to use this? 293 | (define const-pb (lambda (f) 294 | (letrec ([go (lambda (lvl p) 295 | (if (<= lvl 0) 296 | (path 'refl (f (path-start p) (path-end p))) 297 | (path 'refl (go (- lvl 1) (path-start p)) (go (- lvl 1) (path-end p)))))]) 298 | go))) 299 | 300 | (define refl (pi (a type-type) (pi (x a) 301 | (close (type-eq a x x) (lambda (cxt) (path 'refl (red-eval cxt x) (red-eval cxt x))))))) 302 | 303 | (define-syntax-rule (lam (x t) body) (lam-pi (quote x) t (lambda (x) body) (const-pb (lambda (x) body)))) 304 | (define-syntax-rule (pi (x t) body) (lam-pi (quote x) t (lambda (x) body) (const-pb (lambda (x) body)))) 305 | (define-syntax-rule (pi-ty (x t) body) (type-pi (quote x) t (lambda (x) body))) 306 | (define-syntax-rule (close t body) (closure t body)) 307 | 308 | (define-syntax-rule (app f x) (app-n f 0 x)) 309 | 310 | (define apps 311 | (lambda (fun . args) 312 | (foldl (lambda (arg acc) (app acc arg)) fun args))) 313 | 314 | 315 | (add-isPath 316 | (match-lambda** 317 | [(cxt typ (path 'refl _ _) v1 v2) 318 | (eqVal? cxt typ v1 v2)] 319 | [(_ _ _ _ _) #f])) 320 | 321 | (add-eqPath 322 | (match-lambda** 323 | [(cxt typ v1 v2 (path 'refl _ _) (path 'refl _ _)) 324 | #t] 325 | [(_ _ _ _ _ _) #f])) 326 | 327 | ; S1 328 | 329 | (new-form 330 | (lambda (cxt t) (eq? t 'type-s1)) 331 | (lambda (cxt x t) (and (eq? t 'type-s1) (eq? x 'base-s1))) 332 | #f 333 | (lambda (cxt t x y) (and (eq? t 'type-bool) (eq? x y)))) 334 | 335 | (add-isPath 336 | (match-lambda** 337 | [(cxt 'type-s1 (path 'loop-s1 _ _) v1 v2) #t] 338 | [(_ _ _ _ _) #f])) 339 | 340 | ; Explicit groupoids. 341 | 342 | (struct inv (p) #:transparent) 343 | 344 | (define/match (path-start p) 345 | [('()) 'any] ; error -- path-start on nil 346 | [((path _ s _)) s] 347 | [((inv p)) (path-end p)] 348 | [((cons p _)) (path-start p)] 349 | ) 350 | 351 | (define/match (path-end p) 352 | [('()) 'any] ; error -- path-end on nil 353 | [((path _ _ e)) e] 354 | [((inv p)) (path-start p)] 355 | [((cons p '())) (path-end p)] 356 | [((cons _ ps)) (path-end ps)] 357 | ) 358 | 359 | (add-eqPath 360 | (match-lambda** 361 | [(cxt 'type-s1 t1 t2 (path 'loop-s1 _ _) (path 'loop-s1 _ _)) #t] 362 | [(_ _ _ _ _ _) #f])) 363 | 364 | (add-isPath 365 | (match-lambda** 366 | [(cxt typ '() v1 v2) #t] 367 | [(cxt typ (cons p '()) v1 v2) 368 | (isPath? cxt typ p v1 v2)] 369 | [(cxt typ (cons p ps) v1 v2) 370 | (and (isPath? cxt typ p v1 (path-start ps)) 371 | (isPath? cxt typ ps (path-end p) v2))] 372 | [(_ _ _ _ _) #f])) 373 | 374 | (add-isPath 375 | (match-lambda** 376 | [(cxt typ (inv p) v1 v2) (isPath? cxt typ p v2 v1)] 377 | [(_ _ _ _ _) #f])) 378 | 379 | (add-eqPath 380 | (match-lambda** 381 | [(cxt typ v1 v2 '() '()) #t] 382 | [(cxt typ v1 v2 (cons p ps) (cons p1 ps1)) 383 | (and (eqPaths? cxt typ v1 (path-start ps) p p1) 384 | (eqPaths? cxt typ (path-end p) v2 ps ps1))] 385 | [(_ _ _ _ _ _) #f])) 386 | 387 | (add-eqPath 388 | (match-lambda** 389 | [(cxt typ v1 v2 (inv p) (inv p1)) 390 | (eqPaths? cxt typ v2 v1 p p1)] 391 | [(_ _ _ _ _ _) #f])) 392 | 393 | ; todo axioms for refl-intro/elim, inversion, concatination? 394 | 395 | (define equal-induct 396 | (pi (a type-type) 397 | (pi (m a) 398 | (pi (n a) 399 | (pi (m-eq-n (type-eq a m n)) 400 | 401 | (pi (c (pi-ty (x a) (pi-ty (y a) (type-fun (type-eq a x y) type-type)))) 402 | (lam (f (pi-ty (z a) (apps c z z 'refl))) 403 | ; ignores m-eq-n 404 | (close (apps c m n m-eq-n) (lambda (cxt) (app f m)))))))))) 405 | 406 | ;HALP 407 | 408 | ;(close (apps c m n m-eq-n) 409 | ; (lambda (cxt) 410 | ; (let [refl-eq-m-eq-n xxx] 411 | ; (apply-path (app-n (apps c m n) 1 (m-eq-n-eq-refl)) (app f m)))))))))))) 412 | ; doesn't work, need to app c to (m,n,m-eq-n-eq-refl) 413 | 414 | (define transport 415 | (pi (a type-type) 416 | (pi (p (pi-ty (v a) type-type)) 417 | (pi (x a) 418 | (pi (y a) 419 | (lam (x-eq-y (type-eq a x y)) 420 | (lam (px (app p x)) 421 | ; ignores x-eq-y 422 | ; (close (app p y) (lambda (cxt) px))))))))) 423 | (close (app p y) 424 | (lambda (cxt) (transport-val (app-n (red-eval cxt p) 1 (red-eval cxt x-eq-y)) px)))))))))) 425 | 426 | ; Takes a path between types and picks out a fiber across which we transport a particular val 427 | (define/match (transport-val p x) 428 | [('() _) x] 429 | [((path _ _ _) _) x] 430 | [((cons p ps) _) (transport-val ps (transport-val p x))] 431 | [((inv '()) _ ) x] 432 | [((inv (path _ _ _)) _) x] 433 | [((inv (cons p ps)) _) (transport-val (inv p) (transport-val (inv ps) x))]) 434 | 435 | 436 | ; todo add UA? 437 | 438 | 439 | 440 | ; x - x-eq-y -> y 441 | ; | | 442 | ; p p 443 | ; | | 444 | ; v v 445 | ; p x - ? --> p y 446 | 447 | ; fill x = y --> p x = p y 448 | 449 | (define fill 450 | (pi (a type-type) 451 | (pi (p (pi-ty (v a) type-type)) 452 | (pi (x a) 453 | (pi (y a) 454 | (lam (x-eq-y (type-eq a x y)) 455 | (close (type-eq type-type (app p x) (app p y)) 456 | (lambda (cxt) (app-n (red-eval cxt p) 1 (red-eval cxt x-eq-y)))))))))) 457 | 458 | ; TODO interval 459 | ; TODO contraction 460 | ; TODO derive J 461 | 462 | ; do ap 463 | ; do apd 464 | 465 | ; coe is equal -> equiv 466 | ; ua is equiv -> equal 467 | 468 | ; TODO compute paths 469 | 470 | 471 | 472 | (displayln "id-unit: is type, has type") 473 | (define id-unit (lam (x type-unit) x)) 474 | ; (define id-unit (lam 'x type-unit (lambda (x) x))) 475 | (define id-unit-type (type-fun type-unit type-unit)) 476 | (type? '() id-unit-type) 477 | (hasType? '() id-unit id-unit-type) 478 | 479 | (displayln "id-forall: is type, has type") 480 | (define id-forall (pi (t type-type) (lam (x t) x))) 481 | ; (define id-forall (lam 'x type-type (lambda (x) (lam 'y x (lambda (y) y))))) 482 | (define id-forall-type (pi-ty (tau type-type) (type-fun tau tau))) 483 | ; (define id-forall-type (type-pi 'tau type-type (lambda (tau) (type-fun tau tau)))) 484 | (type? '() id-forall-type) 485 | (hasType? '() id-forall id-forall-type) 486 | 487 | (displayln "id-forall: application typechecks") 488 | (hasType? '() (app id-forall type-unit) id-unit-type) 489 | (hasType? '() (apps id-forall type-unit unit-val) type-unit) 490 | 491 | (displayln "k-comb: is type, has type") 492 | (define k-comb 493 | (pi (a type-type) (lam (x a) (pi (b type-type) (lam (y b) x))))) 494 | (define k-comb-type 495 | (pi-ty (a type-type) (type-fun a (pi-ty (b type-type) (type-fun b a))))) 496 | 497 | (type? '() k-comb-type) 498 | (hasType? '() k-comb k-comb-type) 499 | 500 | (displayln "checking rejection of bad signatures") 501 | (hasType? '() k-comb id-forall-type) 502 | (hasType? '() id-forall id-unit-type) 503 | 504 | 505 | 506 | ; a value is of a space at a level if it is 507 | ; an index into that space at that level (atomic) 508 | ; function value: a space paired with a second space of points, of the same quantity as the first (a zero function space) _or_ 509 | ; a value in one space and a value in another space 510 | 511 | ; two types are equal if... (require path unless trivial) 512 | 513 | ; two values are equal at a type if... 514 | 515 | ; well typed shapes don't go wrong 516 | 517 | ; to apply 518 | -------------------------------------------------------------------------------- /hlean/rats_basic.hlean: -------------------------------------------------------------------------------- 1 | /- 2 | Copyright (c) 2014 Jeremy Avigad. All rights reserved. 3 | Released under Apache 2.0 license as described in the file LICENSE. 4 | Author: Jeremy Avigad 5 | 6 | The rational numbers as a field generated by the integers, defined as the usual quotient. 7 | -/ 8 | import types.int algebra.field hit.set_quotient hit.trunc int_order 9 | open eq sigma sigma.ops equiv is_equiv equiv.ops eq.ops int algebra set_quotient is_trunc trunc quotient 10 | 11 | record prerat : Type := 12 | (num : ℤ) (denom : ℤ) (denom_pos : denom > 0) 13 | 14 | namespace prerat 15 | 16 | definition equiv (a b : prerat) : Type.{0} := 17 | (prerat.num a) * (prerat.denom b) = 18 | (prerat.num b) *(prerat.denom a) 19 | 20 | infix `≡` := equiv 21 | 22 | theorem equiv.refl [refl] (a : prerat) : a ≡ a := rfl 23 | 24 | theorem equiv.symm [symm] {a b : prerat} (H : a ≡ b) : b ≡ a := !inverse H 25 | 26 | theorem num_eq_zero_of_equiv {a b : prerat} (H : a ≡ b) (na_zero : num a = 0) : num b = 0 := 27 | have num a * denom b = 0, from !zero_mul ▸ na_zero ▸ rfl, 28 | have num b * denom a = 0, from H ▸ this, 29 | show num b = 0, from sum_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero this) (ne_of_gt (denom_pos a)) 30 | 31 | theorem num_pos_of_equiv {a b : prerat} (H : a ≡ b) (na_pos : num a > 0) : num b > 0 := 32 | have num a * denom b > 0, from mul_pos na_pos (denom_pos b), 33 | have num b * denom a > 0, from H ▸ this, 34 | show num b > 0, from pos_of_mul_pos_right this (le_of_lt (denom_pos a)) 35 | 36 | theorem num_neg_of_equiv {a b : prerat} (H : a ≡ b) (na_neg : num a < 0) : num b < 0 := 37 | have num a * denom b < 0, from mul_neg_of_neg_of_pos na_neg (denom_pos b), 38 | have -(-num b * denom a) < 0, from !neg_mul_eq_neg_mul⁻¹ ▸ !neg_neg⁻¹ ▸ H ▸ this, 39 | have -num b > 0, from pos_of_mul_pos_right (pos_of_neg_neg this) (le_of_lt (denom_pos a)), 40 | neg_of_neg_pos this 41 | 42 | theorem equiv_of_num_eq_zero {a b : prerat} (H1 : num a = of_nat 0) (H2 : num b = of_nat 0) : a ≡ b := 43 | by rewrite [↑equiv, H1, H2, *zero_mul] 44 | 45 | theorem equiv.trans [trans] {a b c : prerat} (H1 : a ≡ b) (H2 : b ≡ c) : a ≡ c := 46 | decidable.by_cases 47 | (suppose num b = 0, 48 | have num a = 0, from num_eq_zero_of_equiv (equiv.symm H1) `num b = 0`, 49 | have num c = 0, from num_eq_zero_of_equiv H2 `num b = 0`, 50 | equiv_of_num_eq_zero `num a = 0` `num c = 0`) 51 | (suppose num b ≠ 0, 52 | have H3 : num b * denom b ≠ 0, from mul_ne_zero this (ne_of_gt (denom_pos b)), 53 | have H4 : (num b * denom b) * (num a * denom c) = (num b * denom b) * (num c * denom a), 54 | from calc 55 | (num b * denom b) * (num a * denom c) = (num a * denom b) * (num b * denom c) : 56 | by rewrite [*mul.assoc, *mul.left_comm (num a), *mul.left_comm (num b)] 57 | ... = (num b * denom a) * (num b * denom c) : {H1} 58 | ... = (num b * denom a) * (num c * denom b) : {H2} 59 | ... = (num b * denom b) * (num c * denom a) : 60 | by rewrite [*mul.assoc, *mul.left_comm (denom a), 61 | *mul.left_comm (denom b), mul.comm (denom a)], 62 | eq_of_mul_eq_mul_left H3 H4) 63 | 64 | 65 | /- field operations -/ 66 | 67 | definition of_int (i : int) : prerat := prerat.mk i (of_nat (nat.succ nat.zero)) !of_nat_succ_pos 68 | 69 | definition zero : prerat := of_int (of_nat nat.zero) 70 | 71 | definition one : prerat := of_int (of_nat (nat.succ nat.zero)) 72 | 73 | private theorem mul_denom_pos (a b : prerat) : denom a * denom b > 0 := 74 | mul_pos (denom_pos a) (denom_pos b) 75 | 76 | definition add (a b : prerat) : prerat := 77 | prerat.mk (num a * denom b + num b * denom a) (denom a * denom b) (mul_denom_pos a b) 78 | 79 | definition mul (a b : prerat) : prerat := 80 | prerat.mk (num a * num b) (denom a * denom b) (mul_denom_pos a b) 81 | 82 | definition neg (a : prerat) : prerat := 83 | prerat.mk (- num a) (denom a) (denom_pos a) 84 | 85 | definition smul (a : ℤ) (b : prerat) (H : a > 0) : prerat := 86 | prerat.mk (a * num b) (a * denom b) (mul_pos H (denom_pos b)) 87 | 88 | --set_option pp.all true 89 | 90 | theorem of_int_add (a b : ℤ) : of_int (int.add (#int a) b) ≡ add (of_int a) (of_int b) := 91 | by esimp [equiv, num, denom, one, add, of_int]; rewrite [+int.mul_one] 92 | 93 | theorem of_int_mul (a b : ℤ) : of_int (#int a * b) ≡ mul (of_int a) (of_int b) := 94 | !equiv.refl 95 | 96 | theorem of_int_neg (a : ℤ) : of_int (#int -a) ≡ neg (of_int a) := 97 | !equiv.refl 98 | 99 | theorem of_int.inj {a b : ℤ} : of_int a ≡ of_int b → a = b := 100 | by rewrite [↑of_int, ↑equiv, +mul_one]; intros; assumption 101 | 102 | definition inv : prerat → prerat 103 | | inv (prerat.mk nat.zero d dp) := zero 104 | | inv (prerat.mk (nat.succ n) d dp) := prerat.mk d (nat.succ n) !of_nat_succ_pos 105 | | inv (prerat.mk (neg_succ_of_nat n) d dp) := prerat.mk (-d) (nat.succ n) !of_nat_succ_pos 106 | 107 | theorem equiv_zero_of_num_eq_zero {a : prerat} (H : num a = 0) : a ≡ zero := 108 | by rewrite [↑equiv, H, ↑zero, ↑num, ↑of_int, +zero_mul] 109 | 110 | theorem num_eq_zero_of_equiv_zero {a : prerat} : a ≡ zero → num a = 0 := 111 | by rewrite [↑equiv, ↑zero, ↑of_int, mul_one, zero_mul]; intro H; exact H 112 | 113 | theorem inv_zero {d : int} (dp : d > 0) : inv (mk nat.zero d dp) = zero := 114 | begin rewrite [↑inv, ▸*] end 115 | 116 | theorem inv_zero' : inv zero = zero := inv_zero (of_nat_succ_pos nat.zero) 117 | 118 | theorem inv_of_pos {n d : int} (np : n > 0) (dp : d > 0) : inv (mk n d dp) ≡ mk d n np := 119 | obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), 120 | have (#nat n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), 121 | obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, 122 | have d * n = d * nat.succ k, by rewrite [Hn', Hk], 123 | Hn'⁻¹ ▸ (Hk⁻¹ ▸ this) 124 | 125 | theorem inv_neg {n d : int} (np : n > 0) (dp : d > 0) : inv (mk (-n) d dp) ≡ mk (-d) n np := 126 | obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), 127 | have (#nat n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), 128 | obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, 129 | have -d * n = -d * nat.succ k, by rewrite [Hn', Hk], 130 | have H3 : inv (mk (neg_succ_of_nat k) d dp) ≡ mk (-d) n np, from this, 131 | have H4 : neg_succ_of_nat k = -n, from calc 132 | neg_succ_of_nat k = -(nat.succ k) : rfl 133 | ... = -n : by rewrite [Hk⁻¹, Hn'], 134 | H4 ▸ H3 135 | 136 | theorem inv_of_neg {n d : int} (nn : n < 0) (dp : d > 0) : 137 | inv (mk n d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn) := 138 | have inv (mk (-(-n)) d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn), 139 | from inv_neg (neg_pos_of_neg nn) dp, 140 | !neg_neg ▸ this 141 | 142 | /- operations respect equiv -/ 143 | 144 | theorem add_equiv_add {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) : 145 | add a1 b1 ≡ add a2 b2 := 146 | calc 147 | (num a1 * denom b1 + num b1 * denom a1) * (denom a2 * denom b2) 148 | = num a1 * denom a2 * denom b1 * denom b2 + num b1 * denom b2 * denom a1 * denom a2 : 149 | by rewrite [mul.right_distrib, *mul.assoc, mul.left_comm (denom b1), 150 | mul.comm (denom b2), *mul.assoc] 151 | ... = num a2 * denom a1 * denom b1 * denom b2 + num b2 * denom b1 * denom a1 * denom a2 : 152 | by rewrite [↑equiv at *, eqv1, eqv2] 153 | ... = (num a2 * denom b2 + num b2 * denom a2) * (denom a1 * denom b1) : 154 | by rewrite [mul.right_distrib, *mul.assoc, *mul.left_comm (denom b2), 155 | *mul.comm (denom b1), *mul.assoc, mul.left_comm (denom a2)] 156 | 157 | theorem mul_equiv_mul {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) : 158 | mul a1 b1 ≡ mul a2 b2 := 159 | calc 160 | (num a1 * num b1) * (denom a2 * denom b2) 161 | = (num a1 * denom a2) * (num b1 * denom b2) : by rewrite [*mul.assoc, mul.left_comm (num b1)] 162 | ... = (num a2 * denom a1) * (num b2 * denom b1) : by rewrite [↑equiv at *, eqv1, eqv2] 163 | ... = (num a2 * num b2) * (denom a1 * denom b1) : by rewrite [*mul.assoc, mul.left_comm (num b2)] 164 | 165 | theorem neg_equiv_neg {a b : prerat} (eqv : a ≡ b) : neg a ≡ neg b := 166 | calc 167 | -num a * denom b = -(num a * denom b) : int.neg_mul_eq_neg_mul 168 | ... = -(num b * denom a) : {eqv} 169 | ... = -num b * denom a : int.neg_mul_eq_neg_mul 170 | 171 | theorem inv_equiv_inv : Π{a b : prerat}, a ≡ b → inv a ≡ inv b 172 | | (mk an ad adp) (mk bn bd bdp) := 173 | assume H, 174 | lt.by_cases 175 | (assume an_neg : an < 0, 176 | have bn_neg : bn < 0, from num_neg_of_equiv H an_neg, 177 | calc 178 | inv (mk an ad adp) ≡ mk (-ad) (-an) (neg_pos_of_neg an_neg) : inv_of_neg an_neg adp 179 | ... ≡ mk (-bd) (-bn) (neg_pos_of_neg bn_neg) : 180 | by rewrite [↑equiv at *, ▸*, *neg_mul_neg, mul.comm ad, mul.comm bd, H] 181 | ... ≡ inv (mk bn bd bdp) : (inv_of_neg bn_neg bdp)⁻¹) 182 | (assume an_zero : an = 0, 183 | have bn_zero : bn = 0, from num_eq_zero_of_equiv H an_zero, 184 | eq.subst (calc 185 | inv (mk an ad adp) = inv (mk 0 ad adp) : {an_zero} 186 | ... = zero : inv_zero 187 | ... = inv (mk 0 bd bdp) : inv_zero 188 | ... = inv (mk bn bd bdp) : bn_zero) !equiv.refl) 189 | (assume an_pos : an > 0, 190 | have bn_pos : bn > 0, from num_pos_of_equiv H an_pos, 191 | calc 192 | inv (mk an ad adp) ≡ mk ad an an_pos : inv_of_pos an_pos adp 193 | ... ≡ mk bd bn bn_pos : 194 | by rewrite [↑equiv at *, ▸*, mul.comm ad, mul.comm bd, H] 195 | ... ≡ inv (mk bn bd bdp) : (inv_of_pos bn_pos bdp)⁻¹) 196 | 197 | theorem smul_equiv {a : ℤ} {b : prerat} (H : a > 0) : smul a b H ≡ b := 198 | by esimp[equiv, smul]; rewrite[mul.assoc, mul.left_comm] 199 | 200 | /- properties -/ 201 | 202 | theorem add.comm (a b : prerat) : add a b ≡ add b a := 203 | by rewrite [↑add, ↑equiv, ▸*, add.comm, mul.comm (denom a)] 204 | 205 | theorem add.assoc (a b c : prerat) : add (add a b) c ≡ add a (add b c) := 206 | by rewrite [↑add, ↑equiv, ▸*, *(mul.comm (num c)), *(λy, mul.comm y (denom a)), *mul.left_distrib, 207 | *mul.right_distrib, *mul.assoc, *add.assoc] 208 | 209 | theorem add_zero (a : prerat) : add a zero ≡ a := 210 | by rewrite [↑add, ↑equiv, ↑zero, ↑of_int, ▸*, *mul_one, zero_mul, add_zero] 211 | 212 | theorem add.left_inv (a : prerat) : add (neg a) a ≡ zero := 213 | by rewrite [↑add, ↑equiv, ↑neg, ↑zero, ↑of_int, ▸*, -neg_mul_eq_neg_mul, add.left_inv, *zero_mul] 214 | 215 | theorem mul.comm (a b : prerat) : mul a b ≡ mul b a := 216 | by rewrite [↑mul, ↑equiv, mul.comm (num a), mul.comm (denom a)] 217 | 218 | theorem mul.assoc (a b c : prerat) : mul (mul a b) c ≡ mul a (mul b c) := 219 | by rewrite [↑mul, ↑equiv, *mul.assoc] 220 | 221 | theorem mul_one (a : prerat) : mul a one ≡ a := 222 | by rewrite [↑mul, ↑one, ↑of_int, ↑equiv, ▸*, *mul_one] 223 | 224 | theorem mul.left_distrib (a b c : prerat) : mul a (add b c) ≡ add (mul a b) (mul a c) := 225 | have H : smul (denom a) (mul a (add b c)) (denom_pos a) = 226 | add (mul a b) (mul a c), from begin 227 | rewrite[↑smul, ↑mul, ↑add], 228 | congruence, 229 | rewrite[*mul.left_distrib, *mul.right_distrib, -*int.mul.assoc], 230 | have T : Π {x y z w : ℤ}, x*y*z*w=y*z*x*w, from 231 | λx y z w, (!int.mul.assoc ⬝ !int.mul.comm) ▸ rfl, 232 | exact !congr_arg2 T T, 233 | exact !mul.left_comm ▸ !int.mul.assoc⁻¹ 234 | end, 235 | equiv.symm (H ▸ smul_equiv (denom_pos a)) 236 | 237 | theorem mul_inv_cancel : Π{a : prerat}, ¬ a ≡ zero → mul a (inv a) ≡ one 238 | | (mk an ad adp) := 239 | assume H, 240 | let a := mk an ad adp in 241 | lt.by_cases 242 | (assume an_neg : an < 0, 243 | let ia := mk (-ad) (-an) (neg_pos_of_neg an_neg) in 244 | calc 245 | mul a (inv a) ≡ mul a ia : mul_equiv_mul !equiv.refl (inv_of_neg an_neg adp) 246 | ... ≡ one : begin 247 | esimp [equiv, num, denom, one, mul, of_int], 248 | rewrite [*int.mul_one, *int.one_mul, int.mul.comm, 249 | neg_mul_comm] 250 | end) 251 | (assume an_zero : an = 0, absurd (equiv_zero_of_num_eq_zero an_zero) H) 252 | (assume an_pos : an > 0, 253 | let ia := mk ad an an_pos in 254 | calc 255 | mul a (inv a) ≡ mul a ia : mul_equiv_mul !equiv.refl (inv_of_pos an_pos adp) 256 | ... ≡ one : begin 257 | esimp [equiv, num, denom, one, mul, of_int], 258 | rewrite [*int.mul_one, *int.one_mul, int.mul.comm] 259 | end) 260 | 261 | theorem zero_not_equiv_one : ¬ zero ≡ one := 262 | begin 263 | esimp [equiv, zero, one, of_int], 264 | rewrite [zero_mul, int.mul_one], 265 | exact zero_ne_one 266 | end 267 | 268 | theorem mul_denom_equiv (a : prerat) : mul a (of_int (denom a)) ≡ of_int (num a) := 269 | by esimp [mul, of_int, equiv]; rewrite [*int.mul_one] 270 | 271 | /- Reducing a fraction to lowest terms. Needed to choose a canonical representative of rat, and 272 | define numerator and denominator. -/ 273 | /- TODO must port int.div first 274 | 275 | definition reduce : prerat → prerat 276 | | (mk an ad adpos) := 277 | have pos : ad div gcd an ad > 0, from div_pos_of_pos_of_dvd adpos !gcd_nonneg !gcd_dvd_right, 278 | if an = 0 then prerat.zero 279 | else mk (an div gcd an ad) (ad div gcd an ad) pos 280 | -/ 281 | 282 | --TODO prove int equality is an hset? 283 | 284 | protected theorem eq {a b : prerat} (Hn : num a = num b) (Hd : denom a = denom b) : a = b := 285 | begin 286 | cases a with [an, ad, adpos], 287 | cases b with [bn, bd, bdpos], 288 | generalize adpos, generalize bdpos, 289 | esimp at *, 290 | rewrite [Hn, Hd], 291 | intros, 292 | apply rfl 293 | end 294 | /- 295 | theorem reduce_equiv : Π a : prerat, reduce a ≡ a 296 | | (mk an ad adpos) := 297 | decidable.by_cases 298 | (assume anz : an = 0, 299 | by krewrite [↑reduce, if_pos anz, ↑equiv, anz, *zero_mul]) 300 | (assume annz : an ≠ 0, 301 | by rewrite [↑reduce, if_neg annz, ↑equiv, int.mul.comm, -!mul_div_assoc !gcd_dvd_left, 302 | -!mul_div_assoc !gcd_dvd_right, int.mul.comm]) 303 | 304 | theorem reduce_eq_reduce : Π{a b : prerat}, a ≡ b → reduce a = reduce b 305 | | (mk an ad adpos) (mk bn bd bdpos) := 306 | assume H : an * bd = bn * ad, 307 | decidable.by_cases 308 | (assume anz : an = 0, 309 | have H' : bn * ad = 0, by rewrite [-H, anz, zero_mul], 310 | assert bnz : bn = 0, 311 | from sum_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero H') (ne_of_gt adpos), 312 | by rewrite [↑reduce, if_pos anz, if_pos bnz]) 313 | (assume annz : an ≠ 0, 314 | assert bnnz : bn ≠ 0, from 315 | assume bnz, 316 | have H' : an * bd = 0, by rewrite [H, bnz, zero_mul], 317 | have anz : an = 0, 318 | from sum_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero H') (ne_of_gt bdpos), 319 | show empty, from annz anz, 320 | begin 321 | rewrite [↑reduce, if_neg annz, if_neg bnnz], 322 | apply prerat.eq, 323 | {apply div_gcd_eq_div_gcd H adpos bdpos}, 324 | {esimp, rewrite [gcd.comm, gcd.comm bn], 325 | apply div_gcd_eq_div_gcd_of_nonneg, 326 | rewrite [int.mul.comm, -H, int.mul.comm], 327 | apply annz, 328 | apply bnnz, 329 | apply le_of_lt adpos, 330 | apply le_of_lt bdpos}, 331 | end) 332 | -/ 333 | end prerat 334 | 335 | /- 336 | the rationals 337 | -/ 338 | 339 | inductive prat_rel : prerat → prerat → Type := 340 | | Rmk : Π (a b : prerat), prerat.equiv a b → prat_rel a b 341 | 342 | definition prat_rel.elim {a b : prerat} (pr : prat_rel a b) : prerat.equiv a b := sorry 343 | 344 | definition rat_rel (a : prerat) (b : prerat) : hprop := trunctype.mk (trunc -1 (prat_rel a b)) _ 345 | 346 | definition rat : Type.{0} := set_quotient rat_rel 347 | notation `ℚ` := rat 348 | 349 | namespace rat 350 | 351 | /- operations -/ 352 | 353 | definition lift0 (p : prerat) : ℚ := set_quotient.class_of rat_rel p 354 | definition of_int [coercion] (i : ℤ) : ℚ := lift0 (prerat.of_int i) 355 | definition of_nat [coercion] (n : nat) : ℚ := of_int n 356 | definition of_num [coercion] [reducible] (n : num) : ℚ := of_int (int.of_num n) 357 | 358 | definition lift1 {A : Type} [hs : is_hset A] (f : prerat → A) (coh : Π (p q : prerat), rat_rel p q -> f p = f q) (r : rat) : A := 359 | set_quotient.elim_on rat_rel r f coh 360 | 361 | definition add : ℚ → ℚ → ℚ := sorry 362 | /- 363 | quot.lift₂ 364 | (λ a b : prerat, ⟦prerat.add a b⟧) 365 | (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.add_equiv_add H1 H2)) 366 | 367 | definition mul : ℚ → ℚ → ℚ := 368 | quot.lift₂ 369 | (λ a b : prerat, ⟦prerat.mul a b⟧) 370 | (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.mul_equiv_mul H1 H2)) 371 | -/ 372 | --TODO prove is_hset Q, is_prop prerat_equiv 373 | 374 | lemma equiv_to_eq {a b : prerat} (e : prerat.equiv a b) : lift0 a = lift0 b := sorry 375 | 376 | definition neg : ℚ → ℚ := @lift1 _ sorry (λx, lift0 (prerat.neg x)) 377 | (λ (p q : prerat) (H : rat_rel p q), equiv_to_eq (prerat.neg_equiv_neg (@trunc.elim_on -1 _ _ H sorry prat_rel.elim))) 378 | 379 | definition inv : ℚ → ℚ := 380 | quot.lift 381 | (λ a : prerat, ⟦prerat.inv a⟧) 382 | (take a1 a2, assume H, quot.sound (prerat.inv_equiv_inv H)) 383 | 384 | definition reduce : ℚ → prerat := 385 | quot.lift 386 | (λ a : prerat, prerat.reduce a) 387 | @prerat.reduce_eq_reduce 388 | 389 | definition num (a : ℚ) : ℤ := prerat.num (reduce a) 390 | definition denom (a : ℚ) : ℤ := prerat.denom (reduce a) 391 | 392 | theorem denom_pos (a : ℚ): denom a > 0 := 393 | prerat.denom_pos (reduce a) 394 | 395 | protected definition prio := num.pred int.prio 396 | 397 | infix [priority rat.prio] + := rat.add 398 | infix [priority rat.prio] * := rat.mul 399 | prefix [priority rat.prio] - := rat.neg 400 | 401 | definition sub [reducible] (a b : rat) : rat := a + (-b) 402 | 403 | postfix [priority rat.prio] ⁻¹ := rat.inv 404 | infix [priority rat.prio] - := rat.sub 405 | 406 | /- properties -/ 407 | 408 | theorem of_int_add (a b : ℤ) : of_int (#int a + b) = of_int a + of_int b := 409 | quot.sound (prerat.of_int_add a b) 410 | 411 | theorem of_int_mul (a b : ℤ) : of_int (#int a * b) = of_int a * of_int b := 412 | quot.sound (prerat.of_int_mul a b) 413 | 414 | theorem of_int_neg (a : ℤ) : of_int (#int -a) = -(of_int a) := 415 | quot.sound (prerat.of_int_neg a) 416 | 417 | theorem of_int_sub (a b : ℤ) : of_int (#int a - b) = of_int a - of_int b := 418 | calc 419 | of_int (#int a - b) = of_int a + of_int (#int -b) : of_int_add 420 | ... = of_int a - of_int b : {of_int_neg b} 421 | 422 | theorem of_int.inj {a b : ℤ} (H : of_int a = of_int b) : a = b := 423 | prerat.of_int.inj (quot.exact H) 424 | 425 | theorem of_nat_eq (a : ℕ) : of_nat a = of_int (int.of_nat a) := rfl 426 | 427 | theorem of_nat_add (a b : ℕ) : of_nat (#nat a + b) = of_nat a + of_nat b := 428 | by rewrite [*of_nat_eq, int.of_nat_add, rat.of_int_add] 429 | 430 | theorem of_nat_mul (a b : ℕ) : of_nat (#nat a * b) = of_nat a * of_nat b := 431 | by rewrite [*of_nat_eq, int.of_nat_mul, rat.of_int_mul] 432 | 433 | theorem of_nat_sub {a b : ℕ} (H : #nat a ≥ b) : of_nat (#nat a - b) = of_nat a - of_nat b := 434 | by rewrite [*of_nat_eq, int.of_nat_sub H, rat.of_int_sub] 435 | 436 | theorem add.comm (a b : ℚ) : a + b = b + a := 437 | quot.induction_on₂ a b (take u v, quot.sound !prerat.add.comm) 438 | 439 | theorem add.assoc (a b c : ℚ) : a + b + c = a + (b + c) := 440 | quot.induction_on₃ a b c (take u v w, quot.sound !prerat.add.assoc) 441 | 442 | theorem add_zero (a : ℚ) : a + 0 = a := 443 | quot.rec_on a (take u, quot.sound !prerat.add_zero) 444 | 445 | theorem zero_add (a : ℚ) : 0 + a = a := !add.comm ▸ !add_zero 446 | 447 | theorem add.left_inv (a : ℚ) : -a + a = 0 := 448 | quot.rec_on a (take u, quot.sound !prerat.add.left_inv) 449 | 450 | theorem mul.comm (a b : ℚ) : a * b = b * a := 451 | quot.induction_on₂ a b (take u v, quot.sound !prerat.mul.comm) 452 | 453 | theorem mul.assoc (a b c : ℚ) : a * b * c = a * (b * c) := 454 | quot.induction_on₃ a b c (take u v w, quot.sound !prerat.mul.assoc) 455 | 456 | theorem mul_one (a : ℚ) : a * 1 = a := 457 | quot.rec_on a (take u, quot.sound !prerat.mul_one) 458 | 459 | theorem one_mul (a : ℚ) : 1 * a = a := !mul.comm ▸ !mul_one 460 | 461 | theorem mul.left_distrib (a b c : ℚ) : a * (b + c) = a * b + a * c := 462 | quot.induction_on₃ a b c (take u v w, quot.sound !prerat.mul.left_distrib) 463 | 464 | theorem mul.right_distrib (a b c : ℚ) : (a + b) * c = a * c + b * c := 465 | by rewrite [mul.comm, mul.left_distrib, *mul.comm c] 466 | 467 | theorem mul_inv_cancel {a : ℚ} : a ≠ 0 → a * a⁻¹ = 1 := 468 | quot.rec_on a 469 | (take u, 470 | assume H, 471 | quot.sound (!prerat.mul_inv_cancel (assume H1, H (quot.sound H1)))) 472 | 473 | theorem inv_mul_cancel {a : ℚ} (H : a ≠ 0) : a⁻¹ * a = 1 := 474 | !mul.comm ▸ mul_inv_cancel H 475 | 476 | theorem zero_ne_one : (0 : ℚ) ≠ 1 := 477 | assume H, prerat.zero_not_equiv_one (quot.exact H) 478 | 479 | definition has_decidable_eq [instance] : decidable_eq ℚ := 480 | take a b, quot.rec_on_subsingleton₂ a b 481 | (take u v, 482 | if H : prerat.num u * prerat.denom v = prerat.num v * prerat.denom u 483 | then decidable.inl (quot.sound H) 484 | else decidable.inr (assume H1, H (quot.exact H1))) 485 | 486 | theorem inv_zero : inv 0 = 0 := 487 | quot.sound (prerat.inv_zero' ▸ !prerat.equiv.refl) 488 | 489 | theorem quot_reduce (a : ℚ) : ⟦reduce a⟧ = a := 490 | quot.rec_on a (take u, quot.sound !prerat.reduce_equiv) 491 | 492 | theorem mul_denom (a : ℚ) : a * denom a = num a := 493 | have H : ⟦reduce a⟧ * of_int (denom a) = of_int (num a), from quot.sound (!prerat.mul_denom_equiv), 494 | quot_reduce a ▸ H 495 | 496 | section migrate_algebra 497 | open [classes] algebra 498 | 499 | protected definition discrete_field [reducible] : algebra.discrete_field rat := 500 | ⦃algebra.discrete_field, 501 | add := add, 502 | add_assoc := add.assoc, 503 | zero := 0, 504 | zero_add := zero_add, 505 | add_zero := add_zero, 506 | neg := neg, 507 | add_left_inv := add.left_inv, 508 | add_comm := add.comm, 509 | mul := mul, 510 | mul_assoc := mul.assoc, 511 | one := (of_num 1), 512 | one_mul := one_mul, 513 | mul_one := mul_one, 514 | left_distrib := mul.left_distrib, 515 | right_distrib := mul.right_distrib, 516 | mul_comm := mul.comm, 517 | mul_inv_cancel := @mul_inv_cancel, 518 | inv_mul_cancel := @inv_mul_cancel, 519 | zero_ne_one := zero_ne_one, 520 | inv_zero := inv_zero, 521 | has_decidable_eq := has_decidable_eq⦄ 522 | 523 | local attribute rat.discrete_field [instance] 524 | 525 | definition divide (a b : rat) := algebra.divide a b 526 | infix [priority rat.prio] `/` := divide 527 | 528 | definition dvd (a b : rat) := algebra.dvd a b 529 | 530 | definition pow (a : ℚ) (n : ℕ) : ℚ := algebra.pow a n 531 | infix [priority rat.prio] ^ := pow 532 | 533 | migrate from algebra with rat 534 | replacing sub → rat.sub, divide → divide, dvd → dvd, pow → pow 535 | 536 | end migrate_algebra 537 | 538 | theorem eq_num_div_denom (a : ℚ) : a = num a / denom a := 539 | have H : of_int (denom a) ≠ 0, from assume H', ne_of_gt (denom_pos a) (of_int.inj H'), 540 | iff.mp' (eq_div_iff_mul_eq H) (mul_denom a) 541 | 542 | theorem of_nat_div {a b : ℤ} (H : b ∣ a) : of_int (a div b) = of_int a / of_int b := 543 | decidable.by_cases 544 | (assume bz : b = 0, 545 | by rewrite [bz, div_zero, int.div_zero]) 546 | (assume bnz : b ≠ 0, 547 | have bnz' : of_int b ≠ 0, from assume oibz, bnz (of_int.inj oibz), 548 | have H' : of_int (a div b) * of_int b = of_int a, from 549 | int.dvd.elim H 550 | (take c, assume Hc : a = b * c, 551 | by rewrite [Hc, !int.mul_div_cancel_left bnz, mul.comm]), 552 | iff.mp' (eq_div_iff_mul_eq bnz') H') 553 | 554 | end rat 555 | -------------------------------------------------------------------------------- /mltt/mess.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ; MESS 3 | ; Martin-Löf Extensible Specification and Simulator 4 | ; (c) Gershom Bazerman, 2015 5 | ; BSD(3) Licensed 6 | 7 | (require racket/match) 8 | 9 | ; value formers 10 | (struct lam-pi (var vt body) #:transparent) 11 | (struct app (fun arg) #:transparent) 12 | ; primitives 13 | (struct closure (typ body) #:transparent) 14 | (struct trustme (typ body) #:transparent) 15 | 16 | ; type formers 17 | (struct type-fun (dom codom) #:transparent) 18 | ; one basic type 19 | (define type-unit 'type-unit) 20 | ; dependency 21 | (struct type-pi (var dom codom) #:transparent) 22 | (define type-type 'type) ; inconsistent! 23 | 24 | ; contexts 25 | (define (find-cxt nm cxt) 26 | (match (assoc nm cxt) [(cons a b) b] [_ #f])) 27 | 28 | (define (fresh-var nm cxt) 29 | (if (assoc nm cxt) (fresh-var (string->symbol (string-append (symbol->string nm) "'")) cxt) nm)) 30 | 31 | (define-syntax-rule (extend-cxt var vt cxt (newvar newcxt) body) 32 | (let* ([newvar (fresh-var var cxt)] 33 | [newcxt (cons (cons newvar vt) cxt)]) 34 | body)) 35 | 36 | ; a reduction of a value in a context creates a term where "app" is not in the head position. 37 | ; this is "weak head normal form" call-by-name reduction 38 | ; we call a term in such a form "reduced" or simply a "value" 39 | (define/match (reduce cxt body) 40 | ; To reduce an application of a function to an argument 41 | ; we confirm that the argument is compatible with the function 42 | ; and we produce the application of the function to the argument 43 | ; (if we omit the type check, we get nuprl semantics) 44 | [(_ (app (lam-pi var vt b) arg)) 45 | (if (hasType? cxt arg vt) (reduce cxt (b arg)) 46 | (raise-arguments-error 'bad-type "bad type" 47 | "cxt" cxt "arg" arg "vt" vt "app" (lam-pi var vt b)))] 48 | ; To reduce an application of a closure to an argument, we produce a closure 49 | ; whose type is the application of the closure type to the argument type 50 | ; and whose body is the application of the closure body to the argument 51 | [(_ (app (closure ty b) arg)) 52 | (closure (app-type cxt (red-eval cxt ty) arg) (lambda (cxt) (app (b cxt) arg)))] 53 | ; To reduce an application of anything else to an argument, we first reduce the thing itself 54 | ; and then attempt to again reduce the application of the result 55 | 56 | [(_ (app fun arg)) (if (or (not fun) (symbol? fun)) 57 | (raise-arguments-error 'stuck "reduction stuck" 58 | "fun" fun "arg" arg) 59 | (reduce cxt (app (reduce cxt fun) arg)))] 60 | [(_ _) body]) 61 | 62 | ; A red-eval of a term in a context creates a term where neither "app" nor "closure" are in the head position 63 | ; we call a term in such a form "evaluated" (or also, where evident, a "value"). 64 | (define (red-eval cxt x) 65 | (match (reduce cxt x) 66 | ; To red-eval a closure, we red-eval the application of the body of the closure to the context 67 | [(closure typ b) (red-eval cxt (b cxt))] 68 | [v v])) 69 | 70 | ; An application of a type to a term confirms the term is compatible with the type 71 | ; and if so, removes provides the new type that is the result of applying a term 72 | ; with the type to a term with the type of the argument 73 | (define/match (app-type cxt fun arg) 74 | [(_ (type-fun a b) _) 75 | (if (hasType? cxt arg a) b 76 | (raise-arguments-error 'bad-type "bad type applying in closure" "cxt" cxt "fun" fun "arg" arg))] 77 | [(_ (type-pi a at b) _) 78 | (if (hasType? cxt arg a) (b arg) 79 | (raise-arguments-error 'bad-type "bad pi type applying in closure" "cxt" cxt "fun" fun "arg" arg))] 80 | [(_ _ _) (raise-arguments-error 'bad-type "can't apply non-function type in closure" "cxt" cxt "fun" fun "arg" arg)]) 81 | 82 | ; In all the following, judgment may be read as "verification" 83 | ; and "to judge" may be read as "to verify," "to know" or "to confirm" 84 | 85 | ; We may judge that an evaluated term is a type by the following rules 86 | (define (type? cxt t) 87 | (match (red-eval cxt t) 88 | ; We know a value is a type if we know that it is tagged type-fun 89 | ; and furthermore we know that its domain is a type and its codomain is a type 90 | [(type-fun a b) (and (type? cxt a) (type? cxt b))] 91 | ; We know a value is a type if it has the symbol 'type-unit 92 | ['type-unit #t] 93 | ; We know a value is a type in a context if it is a symbol and that context assigns it a type of type 94 | [(? symbol? vname) #:when (eq? type-type (find-cxt vname cxt)) #t] 95 | ; We know a value is a type if we know that it is tagged type-pi 96 | ; and furthermore we know that its domain is a type and in a context where 97 | ; its domain is assigned the proper type, its body can send the domain to a type. 98 | [(type-pi var a b) 99 | (and (type? cxt a) (extend-cxt var a cxt (newvar newcxt) (type? newcxt (b newvar))))] 100 | ; We know a value is a type if it has the symbol 'type 101 | ['type #t] 102 | ; Or, we know a value is a type if any other rules let us make such a judgment 103 | [t1 (type?-additional cxt t1)] 104 | )) 105 | 106 | ; We may judge that a reduced value has an evaluated type by the following rules 107 | (define (hasType? cxt x1 t1) 108 | (match* ((reduce cxt x1) (red-eval cxt t1)) 109 | ; To know a closure is of a type is to know that the type of the closure is equal to the desired type 110 | [((closure typ b) t) (eqType? cxt typ t)] 111 | ; To know a primitive is of a type is to know the type claimed by the primitive is equal to the desired type 112 | [((trustme typ b) t) (eqType? cxt typ t)] 113 | ; To know that a symbol has a type in a context is to know that the context assigns the symbol a type equal to the desired type 114 | [((? symbol? x) t) #:when (eqType? cxt t (find-cxt x cxt)) #t] 115 | ; To know that a lambda has type function is to know that 116 | ; the domain of the function type is equal to the input type of the body and to know that 117 | ; in a context where the argument is assigned the proper domain type 118 | ; the body in turn has a type of the codomain of the function type 119 | [((lam-pi vn vt body) (type-fun a b)) 120 | (and (eqType? cxt vt a) 121 | (extend-cxt vn vt cxt (newvar newcxt) (hasType? newcxt (body newvar) b)))] 122 | ; To know that a term has type unit is to know that it is the unit value 123 | [(x 'type-unit) (null? x)] 124 | ; To know that a lambda has type pi is to know that 125 | ; the domain of the function type is equal to the input type of the body and to know that 126 | ; in a context where the argument is assigned the proper domain type 127 | ; the body in turn has a type of the codomain of the function type, as viewed in the same context 128 | [((lam-pi vn vt body) (type-pi _ a b)) 129 | (and (eqType? cxt vt a) 130 | (extend-cxt vn vt cxt (newvar newcxt) 131 | (hasType? newcxt (body newvar) (reduce newcxt (b newvar)))))] 132 | ; To know that a term has type type is to know that the term may be judged a type 133 | [(x 'type) (type? cxt x)] 134 | ; Or, to know that a term has any other type is to follow any additional rules 135 | ; on how we may judge the types of terms 136 | [(x t) (hasType?-additional cxt x t)])) 137 | 138 | ; We may judge that two evaluated values are equal as types by the following rules 139 | (define (eqType? cxt t1 t2) 140 | (match* ((red-eval cxt t1) (red-eval cxt t2)) 141 | ; To know two types tagged type-fun are equal is to know that 142 | ; they have terms equal as types in their domains and 143 | ; they have terms equal as types in their codomains 144 | [((type-fun a b) (type-fun a1 b1)) 145 | (and (eqType? cxt a a1) (eqType? cxt b b1))] 146 | ; To know two types tagged type-pi are equal is to know that 147 | ; they have terms equal as types in their domains and 148 | ; in a context where their arguments are assigned the proper domain type 149 | ; then their codomains also equal as types 150 | [((type-pi v a b) (type-pi v1 a1 b1)) 151 | (and (eqType? cxt a a1) 152 | (extend-cxt v a cxt (newvar newcxt) 153 | (eqType? newcxt (b newvar) (b1 newvar))))] 154 | ; To know two symbols are equal as types is to know that they are the same symbol 155 | [((? symbol? vname) (? symbol? vname1)) (eq? vname vname1)] 156 | ; Or to know any other two values are equal as types is to follow any 157 | ; additional rules on how we may judge the equality of terms as types 158 | [(a b) (and a b (or (eqType?-additional cxt a b) 159 | (begin (printf "not equal\n ~a\n ~a\n cxt: ~a\n" a b cxt) #f)))])) 160 | 161 | ; We may judge that two evaluated values are equal at an evaluated type types by the following rules 162 | (define (eqVal? cxt typ v1 v2) 163 | (match* ((red-eval cxt typ) (red-eval cxt v1) (red-eval cxt v2)) 164 | ; To know two lambda terms are equal at a function type is to know that 165 | ; their domains are equal as types to the domain of the function type and 166 | ; in a context where their domains are assigned the proper input type 167 | ; then their bodies are equal at the type of the codomain 168 | [((type-fun a b) (lam-pi x xt body) (lam-pi y yt body2)) 169 | (and (eqType? cxt a xt) (eqType? cxt a yt) 170 | (extend-cxt x xt cxt (newv newcxt) 171 | (eqVal? newcxt b (body newv) (body2 newv))))] 172 | ; To know two lambda terms are equal at a pi type is to know that 173 | ; their domains are equal as types to the domain of the function type and 174 | ; in a context where their domains are assigned the proper input type 175 | ; then their bodies are equal at the type of the codomain, as viewed in the same context 176 | [((type-pi v a b) (lam-pi x xt body) (lam-pi y yt body2)) 177 | (and (eqType? cxt a xt) (eqType? cxt a yt) 178 | (extend-cxt x xt cxt (newv newcxt) 179 | (eqVal? newcxt (b newv) (body newv) (body2 newv))))] 180 | ; To know two values are equal at unit type 181 | ; requires knowing nothing else -- it is always known 182 | [('type-unit _ _) #t] 183 | ; To know two values are equal at type type is to know that they are equal as types 184 | [('type a b) (eqType? cxt a b)] 185 | ; To know two symbols are equal at any type is to know that they are equal as symbols 186 | [(_ (? symbol? x) (? symbol? y)) #:when (eq? x y) #t] 187 | ; To know two primitives are equal at any type is to know their types are equal and know that 188 | ; their bodies are equal by primitive recursive comparison 189 | [(_ (trustme t v) (trustme t1 v1)) (and (eqType? cxt t t1) (equal? v v1))] ;if all else fails use primitive equality 190 | ; Or to know any other two values are equal at any other type is to follow any 191 | ; additional rules on how we may judge the equality of terms at types 192 | [(rtyp x y) (eqVal?-additional cxt rtyp x y)])) 193 | 194 | (define type-judgments '()) 195 | (define (type?-additional cxt t) 196 | (for/or ([p type-judgments]) (p cxt t))) 197 | 198 | (define hasType-judgments '()) 199 | (define (hasType?-additional cxt x t) 200 | (for/or ([p hasType-judgments]) (p cxt x t))) 201 | 202 | (define eqType-judgments '()) 203 | (define (eqType?-additional cxt t1 t2) 204 | (for/or ([p eqType-judgments]) (p cxt t1 t2))) 205 | 206 | (define eqVal-judgments '()) 207 | (define (eqVal?-additional cxt typ v1 v2) 208 | (for/or ([p eqVal-judgments]) (p cxt typ v1 v2))) 209 | 210 | (define apps 211 | (lambda (fun . args) 212 | (foldl (lambda (arg acc) (app acc arg)) fun args))) 213 | 214 | (define-syntax-rule (lam (x t) body) (lam-pi (quote x) t (lambda (x) body))) 215 | (define-syntax-rule (pi (x t) body) (lam-pi (quote x) t (lambda (x) body))) 216 | (define-syntax-rule (pi-ty (x t) body) (type-pi (quote x) t (lambda (x) body))) 217 | (define-syntax-rule (close t body) (closure t body)) 218 | 219 | (displayln "id-unit: is type, has type") 220 | (define id-unit (lam (x type-unit) x)) 221 | ; (define id-unit (lam 'x type-unit (lambda (x) x))) 222 | (define id-unit-type (type-fun type-unit type-unit)) 223 | (type? '() id-unit-type) 224 | (hasType? '() id-unit id-unit-type) 225 | 226 | (displayln "id-forall: is type, has type") 227 | (define id-forall (pi (t type-type) (lam (x t) x))) 228 | ; (define id-forall (lam 'x type-type (lambda (x) (lam 'y x (lambda (y) y))))) 229 | (define id-forall-type (pi-ty (tau type-type) (type-fun tau tau))) 230 | ; (define id-forall-type (type-pi 'tau type-type (lambda (tau) (type-fun tau tau)))) 231 | (type? '() id-forall-type) 232 | (hasType? '() id-forall id-forall-type) 233 | 234 | (displayln "id-forall: application typechecks") 235 | (hasType? '() (app id-forall type-unit) id-unit-type) 236 | (hasType? '() (apps id-forall type-unit '()) type-unit) 237 | 238 | (displayln "k-comb: is type, has type") 239 | (define k-comb 240 | (pi (a type-type) (lam (x a) (pi (b type-type) (lam (y b) x))))) 241 | (define k-comb-type 242 | (pi-ty (a type-type) (type-fun a (pi-ty (b type-type) (type-fun b a))))) 243 | 244 | (type? '() k-comb-type) 245 | (hasType? '() k-comb k-comb-type) 246 | 247 | (displayln "checking rejection of bad signatures") 248 | (hasType? '() k-comb id-forall-type) 249 | (hasType? '() id-forall id-unit-type) 250 | 251 | ; To introduce a new type is to 252 | ; extend the ways to know a value is a type 253 | ; give a way to know a value has that type 254 | ; extend the ways to know two values are equal as types 255 | ; give a way to know two values are equal at that type 256 | 257 | (define (new-form type-judgment hasType-judgment eqType-judgment eqVal-judgment) 258 | (cond [type-judgment (set! type-judgments (cons type-judgment type-judgments))]) 259 | (cond [hasType-judgment (set! hasType-judgments (cons hasType-judgment hasType-judgments))]) 260 | (cond [eqType-judgment (set! eqType-judgments (cons eqType-judgment eqType-judgments))]) 261 | (cond [eqVal-judgment (set! eqVal-judgments (cons eqVal-judgment eqVal-judgments))]) 262 | ) 263 | 264 | ; adding bool 265 | (define type-bool 'type-bool) 266 | (new-form 267 | ; To know a value is a type may be to know that it is the symbol 'type-bool 268 | (lambda (cxt t) (eq? t 'type-bool)) 269 | ; To know a value is of type bool is to know that it is #t or #f 270 | (lambda (cxt x t) (and (eq? t 'type-bool) (boolean? x))) 271 | ; to know a two values are equal as types when the symbol 'type-bool corresponds to a type 272 | ; is to compare the symbols, which is already known 273 | #f 274 | ; To know two values are equal at type bool is to know that they are equal as scheme values 275 | (lambda (cxt t x y) (and (eq? t 'type-bool) (eq? x y)))) 276 | 277 | ; If we are given two terms at a type, 278 | ; then we may produce a term that sends bools to either the first or second of those given terms. 279 | (define bool-elim 280 | (pi (a type-type) (lam (x a) (lam (y a) (lam (b type-bool) (close a (lambda (cxt) (if (red-eval cxt b) x y)))))))) 281 | 282 | ; If we know a mapping from bools to types 283 | ; and we know a term of the type that is the image of that function on true 284 | ; and we know a term of the type that is the image of that function on false 285 | ; then we may produce a term that sends bools to either the first or second of those terms 286 | ; at either the first or second of those types 287 | (define bool-induct 288 | (pi (p (type-fun type-bool type-type)) 289 | (lam (x (app p #t)) 290 | (lam (y (app p #f)) 291 | (pi (bl type-bool) 292 | (close (app p bl) (lambda (cxt) (if (red-eval cxt bl) x y)))))))) 293 | 294 | (displayln "functions on bool") 295 | (define not-bool (apps bool-elim type-bool #f #t)) 296 | (red-eval '() (app not-bool #t)) 297 | (red-eval '() (app not-bool #f)) 298 | 299 | ; adding equality types 300 | (struct type-eq (type v1 v2) #:transparent) 301 | (struct val-eq (v1 v2)) 302 | 303 | (new-form 304 | ; To know a value is a type may be to know that 305 | ; it is tagged with type-eq and a given type 306 | ; to know that its first term is of the appropriate type and 307 | ; to know that its second term is of the appropriate type 308 | (match-lambda** 309 | [(cxt (type-eq type v1 v2)) 310 | (and (hasType? cxt v1 type) 311 | (hasType? cxt v2 type))] 312 | [(_ _) #f]) 313 | ; To know a value has an equality type is to know that 314 | ; the values of equality type can be known equal at the appropriate type 315 | (match-lambda** 316 | [(cxt 'refl (type-eq type v1 v2)) ;note we ignore the refl 317 | (eqVal? cxt type v1 v2)] 318 | [(_ _ _) #f]) 319 | ; To know a two types are equal may be to know that 320 | ; they are of type-eq and 321 | ; they are equalities at the same type and 322 | ; their first values are equal at that type 323 | ; their second values are equal at that type 324 | (match-lambda** 325 | [(cxt (type-eq t1t t1a t1b) (type-eq t2t t2a t2b)) 326 | (and (eqType? cxt t1t t2t) (eqVal? cxt t1t t1a t2a) (eqVal? cxt t1t t1b t2b))] 327 | [(_ _ _) #f]) 328 | ; To know if two values are equal at any given equality type 329 | ; requires knowing nothing else -- it is always known 330 | (match-lambda** 331 | [(cxt (type-eq t a b) _ _) #t] 332 | [(_ _ _ _) #f]) 333 | ) 334 | 335 | ;intro 336 | ; if we know a term at a type, we know that the term, at that type, is equal to itself 337 | (define refl (pi (a type-type) (pi (x a) (close (type-eq a x x) (lambda (cxt) 'refl))))) 338 | 339 | ; if we know a type 340 | ; and we know a family C which can send two terms at that type and an equality between them to types 341 | ; and know how to produce from a term at a type a value of C as decided by the identity path on our term 342 | ; then we may produce a term that 343 | ; sends two values at a type and an equality between them to the value of C as decided by that path between them 344 | (define equal-induct 345 | (pi (a type-type) 346 | (pi (c (pi-ty (x a) (pi-ty (y a) (type-fun (type-eq a x y) type-type)))) 347 | (lam (f (pi-ty (z a) (apps c z z 'refl))) 348 | (pi (m a) 349 | (pi (n a) 350 | (pi (p (type-eq a m n)) 351 | (close (apps c m n p) (lambda (cxt) (app f m)))))))))) 352 | 353 | ;todo prove transitivity 354 | 355 | (displayln "proving that for all bool, not (not x) = x") 356 | 357 | (define not-not-bool (lam (x type-bool) (app not-bool (app not-bool x)))) 358 | (define id-bool (lam (x type-bool) x)) 359 | 360 | ; not-not-is-id 361 | (define nnii-fam (lam (x type-bool) (type-eq type-bool (app id-bool x) (app not-not-bool x)))) 362 | (hasType? '() nnii-fam (type-fun type-bool type-type)) 363 | (hasType? '() 'refl (app nnii-fam #t)) 364 | 365 | (define nnii-type (pi-ty (x type-bool) (app nnii-fam x))) 366 | (define nnii (pi (x type-bool) (apps bool-induct nnii-fam (apps refl type-bool #t) (apps refl type-bool #f) x))) 367 | (type? '() nnii-type) 368 | (hasType? '() nnii nnii-type) 369 | 370 | (displayln "but we don't have extensional function equality") 371 | (define nnii-extensional (type-eq (type-fun type-bool type-bool) id-bool not-not-bool)) 372 | (type? '() nnii-extensional) 373 | (hasType? '() 'refl nnii-extensional) ; we shouldn't even be able to write that refl 374 | 375 | (displayln "although we do have intensional equality") 376 | (hasType? '() (apps refl (type-fun type-bool type-bool) not-not-bool) (type-eq (type-fun type-bool type-bool) not-not-bool not-not-bool)) 377 | 378 | (displayln "and we can add eta as an axiom") 379 | (define eta-axiom 380 | (pi (a type-type) 381 | (pi (b type-type) 382 | (pi (f (type-fun a b)) 383 | (pi (g (type-fun a b)) 384 | (pi (prf (pi-ty (x a) (type-eq a (app f x) (app g x)))) 385 | (trustme (type-eq (type-fun a b) f g) 'eta-axiom))))))) 386 | 387 | (define nnii-extensional-term (apps eta-axiom type-bool type-bool id-bool not-not-bool nnii)) 388 | (hasType? '() nnii-extensional-term nnii-extensional) 389 | (hasType? '() (red-eval '() nnii-extensional-term) nnii-extensional) 390 | (red-eval '() nnii-extensional-term) 391 | 392 | (displayln "naturals are easy") 393 | (define type-nat 'type-nat) 394 | (new-form 395 | (lambda (cxt t) (eq? t 'type-nat)) 396 | (lambda (cxt x t) (and (eq? t 'type-nat) (exact-integer? x) (>= x 0))) 397 | #f 398 | (lambda (cxt t x y) (and (eq? t 'type-nat) (eq? x y)))) 399 | 400 | (define z 0) 401 | (define succ (lam (x type-nat) 402 | (close type-nat (lambda (cxt) 403 | (let ([x1 (red-eval cxt x)]) 404 | (if (number? x1) 405 | (+ x1 1) 406 | (trustme type-nat (cons 'succ x1)))))))) 407 | 408 | (define nat-induct 409 | (pi (c (type-fun type-nat type-type)) 410 | (lam (base (app c z)) 411 | (lam (induct (pi-ty (n2 type-nat) 412 | (type-fun (app c n2) (app c (app succ n2))))) 413 | (pi (n1 type-nat) 414 | (close (app c n1) (lambda (cxt) (for/fold ([acc base]) 415 | ([x (in-range (red-eval cxt n1))]) 416 | (apps induct x acc))))))))) 417 | 418 | (define double (apps nat-induct (lam (x type-nat) type-nat) z (pi (x type-nat) (lam (n type-nat) (app succ (app succ n)))))) 419 | (red-eval '() (app double (app double (app succ z)))) 420 | 421 | (define plus (lam (a type-nat) 422 | (apps nat-induct (lam (x type-nat) type-nat) a (pi (n type-nat) (lam (n type-nat) (app succ n)))))) 423 | 424 | (red-eval '() (apps plus 5 5)) 425 | 426 | (displayln "we can use sigma types, for existential proofs") 427 | (struct type-sig (a b) #:transparent) 428 | (define-syntax-rule (sig-ty (x t) body) (type-sig t (lambda (x) body))) 429 | (new-form 430 | ; To know a value is a type may be to know that it is tagged type-sig 431 | ; and to know that its first element is a type 432 | ; and to know that the second element can send terms of the first element to types. 433 | (match-lambda** 434 | [(cxt (type-sig a b)) 435 | (and (type? cxt a) 436 | (extend-cxt 'fst a cxt (newv newcxt) 437 | (type? newcxt (b newv))))] 438 | [(_ _) #f]) 439 | ; To know a value is of type sigma is to know that it is a pair 440 | ; and to know that its first element has the type of the first element of the type 441 | ; and to know that its second element has the type that the second element of the type 442 | ; sends the first element of the value to. 443 | (match-lambda** 444 | [(cxt (cons x y) (type-sig a b)) 445 | (and (hasType? cxt x a) 446 | (hasType? cxt y (b x)))] 447 | [(_ _ _) #f]) 448 | ; To know two values are equal as types may be to know that they are both tagged type-sig 449 | ; and that their first elements are equal as types 450 | ; and that their second elements send values of the first element to terms that are equal as types 451 | (match-lambda** 452 | [(cxt (type-sig a b) (type-sig a1 b1)) 453 | (and (eqType? cxt a a1) 454 | (extend-cxt 'fst a cxt (newv newcxt) 455 | (eqType? newcxt (b newv) (b1 newv))))] 456 | [(_ _ _) #f]) 457 | ; To know two values are equal at a sigma type is to know that 458 | ; their first elements are equal at the first component of the sigma type 459 | ; and their second elements are equal at the type produced by the application of the 460 | ; second component of the sigma type to either of their first elements. 461 | (match-lambda** 462 | [(cxt (type-sig a b) (cons x y) (cons x1 y1)) 463 | (and (eqVal? cxt a x x1) 464 | (eqVal? cxt (b x) y y1))] 465 | [(_ _ _ _) #f])) 466 | 467 | ; every number has a successor 468 | (define has-succ (pi (n type-nat) (cons (app succ n) (apps refl type-nat (app succ n))))) 469 | (define has-succ-type (pi-ty (n type-nat) (sig-ty (x type-nat) (type-eq type-nat x (app succ n))))) 470 | (hasType? '() has-succ has-succ-type) 471 | 472 | ; every inhabitant of unit is equal to '() 473 | (define unit-induct 474 | (pi (c (type-fun type-unit type-type)) 475 | (lam (v (app c '())) 476 | (pi (u type-unit) 477 | (close (app c u) (lambda (env) v)))))) 478 | (define is-unit (pi (u type-unit) (cons u (apps unit-induct 479 | (lam (x type-unit) (type-eq type-unit x '())) 480 | (apps refl type-unit '()) 481 | u)))) 482 | (define is-unit-type (pi-ty (u type-unit) (sig-ty (x type-unit) (type-eq type-unit x '())))) 483 | (hasType? '() is-unit is-unit-type) 484 | 485 | (displayln "we have partial type inference") 486 | (define (inferType cxt x1) 487 | (match (reduce cxt x1) 488 | [(closure typ b) typ] 489 | [(trustme typ b) typ] 490 | [(? symbol? x) #:when (find-cxt x cxt) (find-cxt x cxt)] 491 | [(lam-pi vn vt body) 492 | (extend-cxt vn vt cxt (newvar newcxt) 493 | (type-pi newvar vt (lambda (y) (subst y newvar (reduce newcxt (inferType newcxt (body newvar)))))))] 494 | ['() type-unit] 495 | [(? number? x) type-nat] 496 | [(? boolean? x) type-bool] 497 | [(cons a b) (type-sig (inferType cxt a) (lambda (arg) (inferType cxt b)))] ; can't infer sigmas in general 498 | ; ['refl ...] -- given a plain refl whats its type? 499 | ; in both cases, more data in terms can help clean this up... 500 | [(? (lambda (x) (type? cxt x))) type-type] 501 | )) 502 | 503 | (define/match (subst y v x) 504 | [(_ _ (? symbol? x)) #:when (eq? x y) y] 505 | [(_ _ (closure typ b)) (closure (abs y v typ) (lambda (cxt) (subst y v (b cxt))))] 506 | [(_ _ (trustme typ b)) (closure (subst y v typ) (subst y v b))] 507 | [(_ _ (lam-pi vn vt body)) (lam-pi vn (subst y v vt) (lambda (arg) (subst y v (body arg))))] 508 | [(_ _ (cons a b)) (cons (subst y v a) (subst y v b))] 509 | [(_ _ (type-fun a b)) (type-fun (subst y v a) (subst y v b))] 510 | [(_ _ (type-eq t a b)) (type-eq (subst y v t) (subst y v a) (subst y v b))] 511 | [(_ _ (type-pi av a b)) (type-pi av (subst y v a) (lambda (arg) (subst y v (b arg))))] 512 | [(_ _ (type-sig a b)) (type-sig (subst y v a) (lambda (arg) (subst y v (b arg))))] 513 | [(_ _ _) x] 514 | ) 515 | 516 | (define (saturate cxt x) 517 | (match (reduce cxt x) 518 | [(closure typ b) (closure (saturate cxt typ) (saturate cxt (red-eval cxt (b cxt))))] 519 | [(trustme typ b) (trustme (saturate cxt typ) b)] 520 | [(lam-pi vn vt body) 521 | (extend-cxt vn vt cxt (newvar newcxt) 522 | (lam-pi vn vt (saturate newcxt (body newvar))))] 523 | [(cons a b) (cons (saturate cxt a) (saturate cxt b))] 524 | [(type-fun a b) (type-fun (saturate cxt a) (saturate cxt b))] 525 | [(type-eq t a b) (type-eq (saturate cxt t) (saturate cxt a) (saturate cxt b))] 526 | [(type-pi av a b) 527 | (extend-cxt av a cxt (newvar newcxt) 528 | (type-pi newvar (saturate newcxt a) (saturate newcxt (b newvar))))] 529 | [(type-sig a b) 530 | (extend-cxt 'fst a cxt (newvar newcxt) 531 | (type-sig (saturate newcxt a) (saturate newcxt (b newvar))))] 532 | [v v] 533 | )) 534 | 535 | (saturate '() (inferType '() id-bool)) 536 | (saturate '() (inferType '() not-not-bool)) 537 | (saturate '() (inferType '() nnii)) 538 | (saturate '() (inferType '() (cons #t '()))) 539 | 540 | (displayln "we can build either from sigma") 541 | (define (either-type a b) (sig-ty (bl type-bool) 542 | (apps bool-elim type-type a b bl))) 543 | (define left (pi (t type-type) (lam (a t) (cons #t a)))) 544 | (define right (pi (t type-type) (lam (a t) (cons #f a)))) 545 | 546 | (hasType? '() (apps left type-nat 5) (either-type type-nat type-nat)) 547 | 548 | (define maybe-zero (pi (n type-nat) (either-type (type-eq type-nat n z) type-bool))) 549 | (define zero-or-not (apps nat-induct 550 | (lam (x type-nat) (app maybe-zero x)) 551 | (apps left (type-eq type-nat z z) (apps refl type-nat z)) 552 | (pi (x type-nat) (lam (y (app maybe-zero x)) (apps right type-bool #f))))) 553 | 554 | (hasType? '() (pi (x type-nat) (app zero-or-not x)) (pi-ty (x type-nat) (app maybe-zero x))) 555 | 556 | (displayln "we can introduce a type for falsehood, and use it to show contradiction.") 557 | (define type-false 'false) 558 | (new-form 559 | (lambda (cxt t) (eq? t 'false)) 560 | #f 561 | #f 562 | (lambda (cxt t x y) (eq? t 'false))) 563 | 564 | (define transport 565 | (pi (a type-type) 566 | (pi (p (type-fun a type-type)) 567 | (apps equal-induct 568 | a 569 | (pi (x a) (pi (y a) (lam (q (type-eq a x y)) (type-fun (app p x) (app p y))))) 570 | (pi (z a) (lam (v (app p z)) v)))))) 571 | 572 | (define trivial-transport (apps transport type-bool (lam (x type-bool) type-nat) #t #t (apps refl type-bool #t))) 573 | (red-eval '() (app trivial-transport 4)) 574 | 575 | (define true-is-false (type-eq type-bool #t #f)) 576 | (define bool-to-type (apps bool-elim type-type type-unit type-false)) 577 | 578 | (define contradiction-implies-false 579 | (lam (absurd true-is-false) 580 | (apps transport type-bool bool-to-type #t #f absurd '()))) 581 | 582 | (hasType? '() contradiction-implies-false (type-fun true-is-false type-false)) 583 | (hasType? '() (app contradiction-implies-false (trustme true-is-false 'haha)) type-false) 584 | (red-eval '() (app contradiction-implies-false (trustme true-is-false 'haha))) 585 | 586 | <<<<<<< Updated upstream 587 | (define/match (check-universes cxt t) 588 | [(_ (app (lam-pi var vt b) arg)) 589 | (let* 590 | ([au (check-universes cxt arg)] 591 | [ru (extend-cxt var au cxt (nvar newcxt) 592 | (check-universes newcxt (b nvar)))]) 593 | ru)]; todo check compat? 594 | [(_ (app (closure ty b) arg)) (error "what")] 595 | [(_ (app fun arg)) 596 | (check-universes cxt (app (reduce cxt fun) arg))] ; will loop if not careful? need an occurs check! 597 | [(_ (type-fun vt body)) 598 | (let* 599 | ([vu (check-universes cxt vt)] 600 | [bu (check-universes cxt vt)]) 601 | (max bu vu))] 602 | [(_ (type-pi var vt body)) 603 | ======= 604 | ; Todo write univalence as axiom 605 | 606 | (struct pair-ty (fst snd) #:transparent) 607 | 608 | (define (fun-compose a f g) 609 | (lam (x a) (app f (app g a)))) 610 | 611 | (define (type-homotopy a p f g) 612 | (pi (x a) (type-eq (app p x) (app f x) (app g x)))) 613 | 614 | (define (type-isequiv a b f) 615 | (pair-ty 616 | (sig-ty (g (type-fun b a)) (type-homotopy b (lam (x a) b) (fun-compose b f g) (lam (x b) x))) 617 | (sig-ty (h (type-fun b a)) (type-homotopy a (lam (x b) a) (fun-compose a h f) (lam (x a) x))))) 618 | 619 | (define (type-equiv a b) 620 | (sig-ty (f (type-fun a b)) (type-isequiv a b f))) 621 | 622 | (define univalence-axiom (pi (a type-type) (pi (b type-type) 623 | (trustme (type-equiv (type-equiv a b) (type-eq type-type a b)) 'ua)))) 624 | 625 | 626 | (define/match (check-univ cxt x t) ; todo red-eval t 627 | [(_ (app (lam-pi var vt b) arg) _) 628 | (let* 629 | ([arg-univ (check-univ cxt arg vt)] 630 | [result-univ (extend-cxt var (car arg-univ) (cdr arg-univ) (nvar newcxt) 631 | (check-univ newcxt (b nvar) t))]) 632 | (cons (car result-univ) 633 | (cdr (check-univ (cdr result-univ) t type-type))))] 634 | [(_ (app (closure ty b) arg) _) (error "what")] 635 | [(_ (app fun arg) _) 636 | (check-univ cxt (app (reduce cxt fun) arg))] ; will loop if not careful? need an occurs check! 637 | [(_ (type-fun a b) _) 638 | (let* 639 | ([vu (check-univ cxt a type-type)] 640 | [bu (check-univ (cdr vu) b type-type)]) 641 | (cons (cons (car vu) (car bu)) 642 | (cdr (check-univ (cdr bu) t type-type))))] 643 | [(_ (type-pi var vt body) _) 644 | (let* 645 | ([vu (check-univ cxt vt type-type)] 646 | [bu (extend-cxt var (car vu) (cdr vu) (nvar newcxt) 647 | (check-univ newcxt (body nvar) type-type))]) 648 | (cons (cons (car vu) (car bu)) 649 | (cdr (check-univ (cdr bu) t type-type))))] 650 | [(_ type-unit _) (cons 0 cxt)] 651 | [(_ type-bool _) (cons 0 cxt)] 652 | [(_ type-type _) (extend-cxt 't 0 cxt (nvar newcxt) 653 | (cons nvar newcxt))] 654 | [(_ (? symbol? vname) _) #:when (find-cxt vname cxt) 655 | (cons vname cxt)] 656 | [(_ _ _) (error "urk")] 657 | ) 658 | 659 | (struct maxs (x y) #:transparent) 660 | 661 | (define/match (check-u cxt x) 662 | [(_ (lam-pi a at body)) 663 | (let* 664 | ([au (check-u cxt at)] 665 | [vu (check-u (cons (cons a (car au)) (cdr au)) a)] 666 | [bu (extend-cxt a (car vu) (cdr vu) (nvar newcxt) 667 | (check-u newcxt (body nvar)))]) 668 | (cons (maxs (car bu) (car vu)) (cdr bu)))] 669 | [(_ (app fun arg)) 670 | (let* 671 | ([funu (check-u cxt fun)] 672 | [argu (check-u (cdr funu) arg)]) 673 | (cons (car funu) (cons (cons (car funu) (car argu)) (cdr argu))))] 674 | [(_ (? symbol? vname)) #:when (find-cxt vname cxt) 675 | (cons vname cxt)] 676 | [(_ x) (cons 0 cxt)]) 677 | 678 | (check-u '() (lam (x type-type) (lam (y x) (lam (z y) x)))) 679 | 680 | ;(define fam1 (lam (x type-bool) type-unit)) 681 | 682 | ;(check-u '() fam1) 683 | ;(check-u '() (lam (x type-bool) (app fam1 x))) 684 | 685 | 686 | 687 | ;(check-univ '() nnii-fam type-type) 688 | ;(check-univ '() nnii-type type-type) 689 | (define weirdid 690 | (app (lam (q (type-fun type-type type-type)) q) (lam (y type-type) y))) 691 | (define type-weirdid 692 | (type-fun type-type type-type)) 693 | ;(check-u '() weirdid) 694 | ; (check-u '() nnii) 695 | ;(saturate '() (inferType '() weirdid)) 696 | ;(hasType? '() weirdid type-weirdid) 697 | ;(check-univ '() weirdid type-weirdid) 698 | 699 | 700 | ;(check-universes '() nnii-fam) 701 | ;(check-universes '() nnii-type) 702 | 703 | ;(define-syntax-rule (extend-cxt var vt cxt (newvar newcxt) body)) 704 | 705 | ; check universes should just check the type, not the body? 706 | 707 | ; todo? 708 | ; heterogeneous equality 709 | ; looping y combinator? 710 | ; use codes for types 711 | ; tactics -- term is (partial term, full desired type) 712 | 713 | ; references 714 | ; Simply Easy: http://strictlypositive.org/Easy.pdf 715 | ; Simpler, Easier: http://augustss.blogspot.com/2007/10/simpler-easier-in-recent-paper-simply.html 716 | ; PTS: http://hub.darcs.net/dolio/pts 717 | ; Pi-Forall: https://github.com/sweirich/pi-forall 718 | --------------------------------------------------------------------------------