├── .gitignore └── agda └── Linear.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /agda/Linear.agda: -------------------------------------------------------------------------------- 1 | module Linear where 2 | 3 | open import Agda.Primitive using (Level; lzero; lsuc; _⊔_) 4 | 5 | data _==_ {l : Level}{A : Set l}(a : A) : A -> Set l where 6 | refl : a == a 7 | infix 0 _==_ 8 | 9 | {-# BUILTIN EQUALITY _==_ #-} 10 | 11 | record One : Set where 12 | constructor <> 13 | open One 14 | 15 | data Two : Set where 16 | tt ff : Two 17 | 18 | data Nat : Set where 19 | zero : Nat 20 | succ : Nat -> Nat 21 | 22 | {-# BUILTIN NATURAL Nat #-} 23 | 24 | _+N_ : Nat -> Nat -> Nat 25 | zero +N n = n 26 | succ m +N n = succ (m +N n) 27 | 28 | data CompareNat : Nat -> Nat -> Set where 29 | lt : (m k : Nat) -> CompareNat m (succ (m +N k)) 30 | gte : (k n : Nat) -> CompareNat (n +N k) n 31 | 32 | compareNat : (m n : Nat) -> CompareNat m n 33 | compareNat zero zero = gte zero zero 34 | compareNat zero (succ n) = lt zero n 35 | compareNat (succ m) zero = gte (succ m) zero 36 | compareNat (succ m) (succ n) with compareNat m n 37 | compareNat (succ m) (succ .(succ (m +N k))) | lt .m k = lt _ _ 38 | compareNat (succ .(n +N k)) (succ n) | gte k .n = gte _ _ 39 | 40 | data List (A : Set) : Set where 41 | nil : List A 42 | _::_ : A -> List A -> List A 43 | 44 | record Sg (A : Set) (B : A -> Set) : Set where 45 | constructor _,_ 46 | field 47 | fst : A 48 | snd : B fst 49 | open Sg 50 | infixr 1 _,_ 51 | 52 | _*_ : Set -> Set -> Set 53 | A * B = Sg A \ _ -> B 54 | infixr 4 _*_ 55 | 56 | infixr 5 _::_ 57 | 58 | -------------------------------------------------------------------------------- 59 | data LTy : Set where 60 | KEY : LTy 61 | LIST : LTy -> LTy 62 | _-o_ _<**>_ _&_ : LTy -> LTy -> LTy 63 | 64 | infixr 5 _-o_ 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Permutations and so on 68 | _++_ : forall {X} -> List X -> List X -> List X 69 | nil ++ l2 = l2 70 | (x :: l1) ++ l2 = x :: (l1 ++ l2) 71 | 72 | ++nil : {X : Set} -> (l : List X) -> l ++ nil == l 73 | ++nil nil = refl 74 | ++nil (x :: l) rewrite ++nil l = refl 75 | 76 | -- This is the one from the Coq standard library. It represents 77 | -- permutations as a sequence of individual swaps. 78 | -- http://coq.inria.fr/stdlib/Coq.Sorting.Permutation.html 79 | data _><_ {X : Set} : List X -> List X -> Set where 80 | permNil : nil >< nil 81 | permSkip : forall {x l1 l2} -> l1 >< l2 -> (x :: l1) >< (x :: l2) 82 | permSwap : forall {x y l} -> (x :: y :: l) >< (y :: x :: l) 83 | permTrans : forall {l1 l2 l3} -> l1 >< l2 -> l2 >< l3 -> l1 >< l3 84 | 85 | permRefl : forall {X : Set} (l : List X) -> l >< l 86 | permRefl nil = permNil 87 | permRefl (x :: l) = permSkip (permRefl l) 88 | 89 | permAppL : {X : Set} -> {l1 l2 l : List X} -> l1 >< l2 -> (l1 ++ l) >< (l2 ++ l) 90 | permAppL permNil = permRefl _ 91 | permAppL (permSkip p) = permSkip (permAppL p) 92 | permAppL permSwap = permSwap 93 | permAppL (permTrans p1 p2) = permTrans (permAppL p1) (permAppL p2) 94 | 95 | permAppR : {X : Set} -> (l : List X) -> {l1 l2 : List X} -> l1 >< l2 -> (l ++ l1) >< (l ++ l2) 96 | permAppR nil p = p 97 | permAppR (x :: l) p = permSkip (permAppR l p) 98 | 99 | nilPerm : {X : Set} -> {K : List X} -> nil >< K -> K == nil 100 | nilPerm permNil = refl 101 | nilPerm (permTrans p1 p2) rewrite nilPerm p1 = nilPerm p2 102 | 103 | singlPerm : {X : Set} -> {l : List X} {x : X} -> (x :: nil) >< l -> l == x :: nil 104 | singlPerm (permSkip p) rewrite nilPerm p = refl 105 | singlPerm (permTrans p1 p2) rewrite singlPerm p1 = singlPerm p2 106 | 107 | permSymm : {X : Set} -> {l1 l2 : List X} -> l1 >< l2 -> l2 >< l1 108 | permSymm permNil = permNil 109 | permSymm (permSkip p) = permSkip (permSymm p) 110 | permSymm permSwap = permSwap 111 | permSymm (permTrans p1 p2) = permTrans (permSymm p2) (permSymm p1) 112 | 113 | permBubble : {X : Set} -> (l1 l2 : List X) {x : X} -> (x :: l1 ++ l2) >< (l1 ++ (x :: l2)) 114 | permBubble nil l2 = permRefl _ 115 | permBubble (y :: l1) l2 = permTrans permSwap (permSkip (permBubble l1 l2)) 116 | 117 | -- FIXME: should just use the fact that ++ is assoc for == 118 | permAssoc : {X : Set} -> (l1 l2 l3 : List X) -> ((l1 ++ l2) ++ l3) >< (l1 ++ (l2 ++ l3)) 119 | permAssoc nil l2 l3 = permRefl (l2 ++ l3) 120 | permAssoc (x :: l1) l2 l3 = permSkip (permAssoc l1 l2 l3) 121 | 122 | permSwap++ : {X : Set} -> (l1 l2 : List X) -> (l1 ++ l2) >< (l2 ++ l1) 123 | permSwap++ nil l2 rewrite ++nil l2 = permRefl l2 124 | permSwap++ (x :: l1) l2 = permTrans (permSkip (permSwap++ l1 l2)) (permBubble l2 l1) 125 | 126 | -------------------------------------------------------------------------------- 127 | -- explicit splitting presentation of terms 128 | Ctx : Set 129 | Ctx = List LTy 130 | 131 | data _|-_ : Ctx -> LTy -> Set where 132 | var : forall {T} -> (T :: nil) |- T 133 | lam : forall {G S T} -> (S :: G) |- T -> G |- (S -o T) 134 | app : forall {G G0 G1 S T} -> G >< (G0 ++ G1) -> G0 |- (S -o T) -> G1 |- S -> G |- T 135 | 136 | nil : forall {T} -> nil |- LIST T 137 | cons : forall {T} -> nil |- (T -o LIST T -o LIST T) 138 | foldr : forall {S T} -> nil |- T 139 | -> nil |- (S -o (LIST S & T) -o T) 140 | -> nil |- (LIST S -o T) 141 | 142 | cmp : forall {T} -> nil |- (KEY -o KEY -o ((KEY -o KEY -o T) & (KEY -o KEY -o T)) -o T) 143 | 144 | tensor : forall {G G0 G1 S T} -> G >< (G0 ++ G1) -> G0 |- S -> G1 |- T -> G |- (S <**> T) 145 | pm : forall {G G0 G1 S T U} -> G >< (G0 ++ G1) -> G0 |- (S <**> T) -> (S :: T :: G1) |- U -> G |- U 146 | 147 | _&_ : forall {G S T} -> G |- S -> G |- T -> G |- (S & T) 148 | proj1 : forall {G S T} -> G |- (S & T) -> G |- S 149 | proj2 : forall {G S T} -> G |- (S & T) -> G |- T 150 | 151 | -------------------------------------------------------------------------------- 152 | -- insertion sort 153 | _$$_ : forall {G0 G1 S T} -> G0 |- (S -o T) -> G1 |- S -> (G0 ++ G1) |- T 154 | t1 $$ t2 = app (permRefl _) t1 t2 155 | 156 | infixl 4 _$$_ 157 | 158 | insert : nil |- (LIST KEY -o KEY -o LIST KEY) 159 | insert = foldr (lam (cons $$ var $$ nil)) 160 | (lam (lam (lam (app (permSkip permSwap) 161 | (cmp $$ var $$ var) 162 | (lam (lam (app (permSkip permSwap) (cons $$ var) (proj2 var $$ var))) 163 | & 164 | lam (lam (cons $$ var $$ (cons $$ var $$ proj1 var)))))))) 165 | 166 | insertion-sort : nil |- (LIST KEY -o LIST KEY) 167 | insertion-sort = foldr nil (lam (lam (insert $$ proj2 var $$ var))) 168 | 169 | -------------------------------------------------------------------------------- 170 | [[_]]T : LTy -> Set 171 | [[ KEY ]]T = Nat 172 | [[ LIST T ]]T = List [[ T ]]T 173 | [[ S -o T ]]T = [[ S ]]T -> [[ T ]]T 174 | [[ S <**> T ]]T = [[ S ]]T * [[ T ]]T 175 | [[ S & T ]]T = [[ S ]]T * [[ T ]]T 176 | 177 | [[_]]C : Ctx -> Set 178 | [[ nil ]]C = One 179 | [[ S :: G ]]C = [[ S ]]T * [[ G ]]C 180 | 181 | [[_]]p : forall {G G'} -> G >< G' -> [[ G ]]C -> [[ G' ]]C 182 | [[ permNil ]]p <> = <> 183 | [[ permSkip p ]]p (x , g) = x , [[ p ]]p g 184 | [[ permSwap ]]p (x , y , g) = (y , x , g) 185 | [[ permTrans p1 p2 ]]p g = [[ p2 ]]p ([[ p1 ]]p g) 186 | 187 | split : forall G0 {G1} -> [[ G0 ++ G1 ]]C -> [[ G0 ]]C * [[ G1 ]]C 188 | split nil g = <> , g 189 | split (T :: G0) (t , g) with split G0 g 190 | ... | g0 , g1 = (t , g0) , g1 191 | 192 | compare : {X : Set} -> Nat -> Nat -> ((Nat -> Nat -> X) * (Nat -> Nat -> X)) -> X 193 | compare m n (GTE , LT) with compareNat m n 194 | compare m .(succ (m +N k)) (GTE , LT) | lt .m k = LT (succ (m +N k)) m 195 | compare .(n +N k) n (GTE , LT) | gte k .n = GTE (n +N k) n 196 | 197 | foldright : {X Y : Set} -> X -> (Y -> (List Y * X) -> X) -> List Y -> X 198 | foldright n c nil = n 199 | foldright n c (y :: ys) = c y (ys , foldright n c ys) 200 | 201 | [[_]]t : forall {G T} -> G |- T -> [[ G ]]C -> [[ T ]]T 202 | [[ var ]]t (t , <>) = t 203 | [[ lam t ]]t g = \ v -> [[ t ]]t (v , g) 204 | [[ app {_} {G0} p t1 t2 ]]t g with split G0 ([[ p ]]p g) 205 | ... | g0 , g1 = [[ t1 ]]t g0 ([[ t2 ]]t g1) 206 | [[ nil ]]t <> = nil 207 | [[ cons ]]t <> = _::_ 208 | [[ foldr t1 t2 ]]t <> = foldright ([[ t1 ]]t <>) ([[ t2 ]]t <>) 209 | [[ cmp ]]t <> = compare 210 | [[ tensor {_} {G0} p t1 t2 ]]t g with split G0 ([[ p ]]p g) 211 | ... | g0 , g1 = ([[ t1 ]]t g0) , ([[ t2 ]]t g1) 212 | [[ pm {_} {G0} p t1 t2 ]]t g with split G0 ([[ p ]]p g) 213 | ... | g0 , g1 with [[ t1 ]]t g0 214 | ... | s , t = [[ t2 ]]t (s , t , g1) 215 | [[ t1 & t2 ]]t g = [[ t1 ]]t g , [[ t2 ]]t g 216 | [[ proj1 t ]]t g = fst ([[ t ]]t g) 217 | [[ proj2 t ]]t g = snd ([[ t ]]t g) 218 | 219 | sorter : List Nat -> List Nat 220 | sorter = [[ insertion-sort ]]t <> 221 | 222 | -------------------------------------------------------------------------------- 223 | -- Logical Predicates to prove the permutation property 224 | KeySet : Set 225 | KeySet = List Nat 226 | 227 | [_|=_contains_] : KeySet -> (T : LTy) -> [[ T ]]T -> Set 228 | [ K |= KEY contains n ] = (n :: nil) >< K 229 | [ K |= LIST T contains nil ] = nil >< K 230 | [ K |= LIST T contains (t :: ts) ] = Sg KeySet \ K1 -> Sg KeySet \ K2 -> (K1 ++ K2) >< K * [ K1 |= T contains t ] * [ K2 |= LIST T contains ts ] 231 | [ K |= S -o T contains f ] = forall K' s -> [ K' |= S contains s ] -> [ K ++ K' |= T contains f s ] 232 | [ K |= S <**> T contains (s , t) ] = Sg KeySet \ K1 -> Sg KeySet \ K2 -> (K1 ++ K2) >< K * [ K1 |= S contains s ] * [ K2 |= T contains t ] 233 | [ K |= S & T contains (s , t) ] = [ K |= S contains s ] * [ K |= T contains t ] 234 | 235 | repList : forall K K' -> [ K |= LIST KEY contains K' ] -> K' >< K 236 | repList K nil phi rewrite nilPerm phi = permRefl nil 237 | repList K (k :: ks) (K1 , K2 , phi , psi1 , psi2) rewrite singlPerm psi1 = permTrans (permSkip (repList _ _ psi2)) phi 238 | 239 | listRep : forall K -> [ K |= LIST KEY contains K ] 240 | listRep nil = permNil 241 | listRep (k :: K) = (k :: nil) , K , permRefl (k :: K) , permRefl (k :: nil) , listRep K 242 | 243 | [_|=_*contains_] : KeySet -> (G : Ctx) -> [[ G ]]C -> Set 244 | [ K |= nil *contains <> ] = nil >< K 245 | [ K |= T :: G *contains t , g ] = Sg KeySet \ K1 -> Sg KeySet \ K2 -> (K1 ++ K2) >< K * [ K1 |= T contains t ] * [ K2 |= G *contains g ] 246 | 247 | preservePerm : forall {K K'} -> (T : LTy) -> (x : [[ T ]]T) -> K >< K' -> [ K |= T contains x ] -> [ K' |= T contains x ] 248 | preservePerm KEY n p prf = permTrans prf p 249 | preservePerm (LIST T) nil p phi = permTrans phi p 250 | preservePerm (LIST T) (t :: ts) p (K1 , K2 , p' , r1 , r2) = K1 , K2 , permTrans p' p , r1 , r2 251 | preservePerm (S -o T) f p prf = \ K' s x -> preservePerm T (f s) (permAppL p) (prf K' s x) 252 | preservePerm (S <**> T) (s , t) p (K1 , K2 , p' , r1 , r2) = K1 , K2 , permTrans p' p , r1 , r2 253 | preservePerm (S & T) (s , t) p (r1 , r2) = preservePerm S s p r1 , preservePerm T t p r2 254 | 255 | lem-1 : forall {A : Set} -> (l0 l1 l2 : List A) -> ((l2 ++ l0) ++ l1) >< ((l0 ++ l1) ++ l2) 256 | lem-1 l0 l1 l2 = permTrans (permAppL (permSwap++ l2 l0)) 257 | (permTrans (permAssoc l0 l2 l1) 258 | (permTrans (permAppR l0 (permSwap++ l2 l1)) 259 | (permSymm (permAssoc l0 l1 l2)))) 260 | 261 | lem-2 : forall {A : Set} -> (l0 l1 l2 : List A) -> ((l2 ++ l1) ++ l0) >< ((l0 ++ l1) ++ l2) 262 | lem-2 l0 l1 l2 = permTrans (permAppL (permSwap++ l2 l1)) (permTrans (permSwap++ (l1 ++ l2) l0) (permSymm (permAssoc l0 l1 l2))) 263 | 264 | foldright-welltyped : forall {T S} n f -> 265 | [ nil |= T contains n ] -> 266 | [ nil |= (S -o (LIST S & T) -o T) contains f ] -> 267 | [ nil |= (LIST S -o T) contains foldright n f ] 268 | foldright-welltyped n f psin psif Kl nil phil rewrite nilPerm phil = psin 269 | foldright-welltyped {T} {S} n f psin psif Kl (s :: ss) (K1 , K2 , phi , phis , phiss) rewrite ++nil Kl = 270 | preservePerm T _ phi (psif K1 s phis K2 (ss , foldright n f ss) (phiss , foldright-welltyped {T} {S} n f psin psif K2 ss phiss)) 271 | 272 | compare-welltyped : forall T -> 273 | [ nil |= (KEY -o KEY -o ((KEY -o KEY -o T) & (KEY -o KEY -o T)) -o T) contains compare ] 274 | 275 | compare-welltyped T K0 x0 phi0 K1 x1 phi1 K2 (GTE , LT) (phi2 , psi2) with compareNat x0 x1 276 | compare-welltyped T K0 x0 phi0 K1 .(succ (x0 +N k)) phi1 K2 (GTE , LT) (phi2 , psi2) | lt .x0 k = 277 | preservePerm T _ (lem-2 K0 K1 K2) (psi2 K1 (succ (x0 +N k)) phi1 K0 x0 phi0) 278 | compare-welltyped T K0 .(x1 +N k) phi0 K1 x1 phi1 K2 (GTE , LT) (phi2 , psi2) | gte k .x1 = 279 | preservePerm T _ (lem-1 K0 K1 K2) (phi2 K0 (x1 +N k) phi0 K1 x1 phi1) 280 | 281 | 282 | respPerm : forall {G G'} -> (p : G >< G') -> (g : [[ G ]]C) -> forall {K} -> [ K |= G *contains g ] -> [ K |= G' *contains [[ p ]]p g ] 283 | respPerm permNil g phi = phi 284 | respPerm (permSkip p) (t , g) (K1 , K2 , phi , psi1 , psi2) = K1 , K2 , phi , psi1 , respPerm p g psi2 285 | respPerm permSwap (s , t , g) (K1 , K2 , phi1 , psi1 , K3 , K4 , phi2 , psi3 , psi4) = 286 | K3 , K1 ++ K4 , permTrans (permSymm (permAssoc K3 K1 K4)) (permTrans (permAppL (permSwap++ K3 K1)) (permTrans (permAssoc K1 K3 K4) (permTrans (permAppR K1 phi2) phi1))) , psi3 , K1 , K4 , permRefl _ , psi1 , psi4 287 | respPerm (permTrans p1 p2) g phi = respPerm p2 _ (respPerm p1 _ phi) 288 | 289 | 290 | data Split (G0 G1 : Ctx) (K : List Nat) : (g0 : [[ G0 ]]C) -> (g1 : [[ G1 ]]C) -> Set where 291 | splitting : (g0 : [[ G0 ]]C) -> 292 | (g1 : [[ G1 ]]C) -> 293 | (K0 : List Nat) -> 294 | (K1 : List Nat) -> 295 | (p : (K0 ++ K1) >< K) -> 296 | (phi0 : [ K0 |= G0 *contains g0 ]) -> 297 | (phi1 : [ K1 |= G1 *contains g1 ]) -> 298 | Split G0 G1 K g0 g1 299 | 300 | makeSplitting : forall G0 G1 -> 301 | (g : [[ G0 ++ G1 ]]C) -> 302 | (K : List Nat) -> 303 | [ K |= G0 ++ G1 *contains g ] -> 304 | Split G0 G1 K (fst (split G0 g)) (snd (split G0 g)) 305 | makeSplitting nil G1 g K phi = splitting <> g nil K (permRefl K) permNil phi 306 | makeSplitting (T :: G0) G1 (t , g) K (K1 , K2 , phi , psi1 , psi2) with makeSplitting G0 G1 g K2 psi2 307 | makeSplitting (T :: G0) G1 (t , g) K (K1' , K2 , phi , psi1 , psi2) | splitting .(fst (split G0 g)) .(snd (split G0 g)) K0 K1 p phi0 phi1 308 | = splitting (t , fst (split G0 g)) 309 | (snd (split G0 g)) 310 | (K1' ++ K0) 311 | K1 312 | (permTrans (permAssoc K1' K0 K1) (permTrans (permAppR K1' p) phi)) 313 | (K1' , K0 , permRefl (K1' ++ K0) , psi1 , phi0) 314 | phi1 315 | 316 | fundamental : forall {G T} -> 317 | (t : G |- T) -> 318 | forall K g -> [ K |= G *contains g ] -> [ K |= T contains ([[ t ]]t g) ] 319 | 320 | fundamental (var {T}) K (t , <>) (K1 , K2 , phi , tOK , nilK2) rewrite nilPerm nilK2 | ++nil K1 = preservePerm T t phi tOK 321 | fundamental (lam t) K g phi = \ K' s psi -> fundamental t (K ++ K') (s , g) (K' , K , permSwap++ K' K , psi , phi) 322 | fundamental {_} {T} (app {._} {G0} {G1} p t1 t2) K g phi with makeSplitting G0 G1 ([[ p ]]p g) K (respPerm p g phi) 323 | ... | splitting ._ ._ K0 K1 p' phi0 phi1 = preservePerm T _ p' (fundamental t1 K0 _ phi0 K1 ([[ t2 ]]t _) (fundamental t2 K1 _ phi1)) 324 | fundamental nil K g phi = phi 325 | fundamental cons K g phi rewrite nilPerm phi = \ K0 s0 psi0 K1 s1 psi1 -> K0 , K1 , permRefl _ , psi0 , psi1 326 | fundamental (foldr {S}{T} t1 t2) K g phi rewrite nilPerm phi = foldright-welltyped {T} {S} _ _ (fundamental t1 nil <> permNil) (fundamental t2 nil <> permNil) 327 | fundamental (cmp {T}) K g phi rewrite nilPerm phi = compare-welltyped T 328 | fundamental (tensor {_} {G0} {G1} p t1 t2) K g phi with makeSplitting G0 G1 ([[ p ]]p g) K (respPerm p g phi) 329 | ... | splitting ._ ._ K0 K1 p' phi0 phi1 = K0 , K1 , p' , fundamental t1 K0 _ phi0 , fundamental t2 K1 _ phi1 330 | fundamental (pm {_} {G0} {G1} {S} {T} {U} p t1 t2) K g phi with makeSplitting G0 G1 ([[ p ]]p g) K (respPerm p g phi) 331 | ... | splitting ._ ._ K0 K1 p' phi0 phi1 with fundamental t1 K0 _ phi0 332 | ... | K01 , K02 , p'' , phi01 , phi02 = preservePerm U _ (permTrans (permTrans (permSymm (permAssoc K01 K02 K1)) (permAppL p'')) p') 333 | (fundamental t2 (K01 ++ (K02 ++ K1)) _ (K01 , K02 ++ K1 , permRefl _ , phi01 , K02 , K1 , permRefl _ , phi02 , phi1)) 334 | fundamental (t1 & t2) K g phi = fundamental t1 K g phi , fundamental t2 K g phi 335 | fundamental (proj1 t) K g phi = fst (fundamental t K g phi) 336 | fundamental (proj2 t) K g phi = snd (fundamental t K g phi) 337 | 338 | isPermutation : (t : nil |- (LIST KEY -o LIST KEY)) -> (l : List Nat) -> ([[ t ]]t <> l) >< l 339 | isPermutation t l with fundamental t nil <> permNil l l (listRep l) 340 | ... | x rewrite ++nil l = repList l ([[ t ]]t <> l) x 341 | --------------------------------------------------------------------------------