├── .gitignore ├── LICENSE.md ├── Makefile ├── README.md └── src ├── Bf ├── ArrMp.agda ├── BoxMp.agda ├── Cp.agda ├── Ip.agda └── Mp.agda ├── Bi ├── ArrMp.agda ├── BoxMp.agda ├── Cp.agda ├── Ip.agda └── Mp.agda ├── Lib.agda ├── Lib.hs ├── Pf ├── ArrMp.agda ├── ArrMp.hs ├── ArrMp.idr ├── BoxMp.agda ├── BoxMp.hs ├── BoxMp.idr ├── Cp.agda ├── Cp.hs ├── Cp.idr ├── Ip.agda ├── Ip.hs ├── Ip.idr ├── Mp.agda ├── Mp.hs └── Mp.idr ├── Pi ├── ArrMp.agda ├── ArrMp.hs ├── ArrMp.idr ├── BoxMp.agda ├── BoxMp.hs ├── BoxMp.idr ├── C.agda ├── C.idr ├── Cp.agda ├── Cp.hs ├── Cp.idr ├── I.agda ├── I.idr ├── Ip.agda ├── Ip.hs ├── Ip.idr ├── M.agda ├── M.idr ├── Mp.agda ├── Mp.hs └── Mp.idr └── Vi ├── ArrMp.agda ├── BoxMp.agda ├── Cp.agda ├── Ip.agda └── Mp.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | *.hi 3 | *.ibc 4 | *.o 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT X11 license 2 | =============== 3 | 4 | Copyright © 2015 Miëtek Bak. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 7 | 8 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 9 | 10 | *The Software is provided “as is”, without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall the authors or copyright holders be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the software or the use or other dealings in the software.* 11 | 12 | Except as contained in this notice, the names of the above copyright holders shall not be used in advertising or otherwise to promote the sale, use or other dealings in the Software without prior written authorization. 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all agda haskell idris 2 | all: agda haskell idris 3 | 4 | .PHONY: clean agda-clean haskell-clean idris-clean 5 | clean: agda-clean haskell-clean idris-clean 6 | 7 | 8 | agda := $(shell find src -type f -name '*.agda') 9 | agdai := $(patsubst %.agda,%.agdai,$(agda)) 10 | 11 | agda: $(agdai) 12 | 13 | %.agdai: %.agda 14 | agda --safe -i src $< 15 | 16 | agda-clean: 17 | rm -f $(agdai) 18 | 19 | 20 | idr := $(shell find src -type f -name '*.idr') 21 | ibc := $(patsubst %.idr,%.ibc,$(idr)) 22 | 23 | idris: $(ibc) 24 | 25 | %.ibc: %.idr 26 | idris --check -i src $< 27 | 28 | idris-clean: 29 | rm -f $(ibc) 30 | 31 | 32 | hs := $(shell find src -type f -name '*.hs') 33 | hi := $(patsubst %.hs,%.hi,$(hs)) 34 | o := $(patsubst %.hs,%.o,$(hs)) 35 | 36 | haskell: $(hi) $(o) 37 | 38 | %.hi %.o: %.hs 39 | ghc --make -Wall -isrc $< 40 | 41 | haskell-clean: 42 | rm -f $(hi) $(o) 43 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | _formal-logic_ 2 | ============== 3 | 4 | Formalisation of some logical systems, in Agda, Idris, and Haskell. 5 | 6 | 7 | ### Notes 8 | 9 | This work compares a number of techniques for formalising typed higher-order languages in a typed meta-language, with an eye towards the readability of programs written in the resulting object-language. 10 | 11 | Following [Troelstra and Schwichtenberg](#references), we use **M**, **I**, and **C** for minimal, intuitionistic, and classical first-order predicate calculus, respectively; **Mp**, **Ip**, and **Cp** stand for the corresponding propositional systems. For technical reasons, we refer to minimal implicational logic as **ArrMp**, and to minimal implicational modal logic as **BoxMp**. 12 | 13 | We investigate the issue of binder representation by contrasting the use of _de Bruijn indices_ against _parametric higher-order abstract syntax_ (PHOAS), after [Chlipala](#references). Each approach is presented in the widely-used _initial_ encoding, using a generalised algebraic data type, and the _final_ encoding of [Carette, Kiselyov, and Shan](#references), using a sequence of type classes. 14 | 15 | We refer to the de Bruijn, vector-based de Bruijn, and PHOAS approach as **B**, **V**, and **P**, respectively; **i** and **f** correspond to the initial and final encoding. 16 | 17 | 18 | ### Implementations 19 | 20 | | | **Pi** | **Pf** | **Bi** | **Vi** | **Bf** 21 | | :----- | :----- | :----- | :----- | :----- | :----- 22 | | **ArrMp** | [`agda`](src/Pi/ArrMp.agda), [`idr`](src/Pi/ArrMp.idr), [`hs`](src/Pi/ArrMp.hs) | [`agda`](src/Pf/ArrMp.agda), [`idr`](src/Pf/ArrMp.idr), [`hs`](src/Pf/ArrMp.hs) | [`agda`](src/Bi/ArrMp.agda) | [`agda`](src/Vi/ArrMp.agda) | [`agda`](src/Bf/ArrMp.agda) 23 | | **BoxMp** | [`agda`](src/Pi/BoxMp.agda), [`idr`](src/Pi/BoxMp.idr), [`hs`](src/Pi/BoxMp.hs) | [`agda`](src/Pf/BoxMp.agda), [`idr`](src/Pf/BoxMp.idr), [`hs`](src/Pf/BoxMp.hs) | [`agda`](src/Bi/BoxMp.agda) | [`agda`](src/Vi/BoxMp.agda) | [`agda`](src/Bf/BoxMp.agda) 24 | | **Mp** | [`agda`](src/Pi/Mp.agda), [`idr`](src/Pi/Mp.idr), [`hs`](src/Pi/Mp.hs) | [`agda`](src/Pf/Mp.agda), [`idr`](src/Pf/Mp.idr), [`hs`](src/Pf/Mp.hs) | [`agda`](src/Bi/Mp.agda) | [`agda`](src/Vi/Mp.agda) | [`agda`](src/Bf/Mp.agda) 25 | | **Ip** | [`agda`](src/Pi/Ip.agda), [`idr`](src/Pi/Ip.idr), [`hs`](src/Pi/Ip.hs) | [`agda`](src/Pf/Ip.agda), [`idr`](src/Pf/Ip.idr), [`hs`](src/Pf/Ip.hs) | [`agda`](src/Bi/Ip.agda) | [`agda`](src/Vi/Ip.agda) | [`agda`](src/Bf/Ip.agda) 26 | | **Cp** | [`agda`](src/Pi/Cp.agda), [`idr`](src/Pi/Cp.idr), [`hs`](src/Pi/Cp.hs) | [`agda`](src/Pf/Cp.agda), [`idr`](src/Pf/Cp.idr), [`hs`](src/Pf/Cp.hs) | [`agda`](src/Bi/Cp.agda) | [`agda`](src/Vi/Cp.agda) | [`agda`](src/Bf/Cp.agda) 27 | | **M** | [`agda`](src/Pi/M.idr), [`idr`](src/Pi/M.idr) | | | | | 28 | | **I** | [`agda`](src/Pi/I.idr), [`idr`](src/Pi/I.idr) | | | | | 29 | | **C** | [`agda`](src/Pi/C.idr), [`idr`](src/Pi/C.idr) | | | | | 30 | 31 | 32 | Usage 33 | ----- 34 | 35 | To check all files automatically: 36 | 37 | ``` 38 | $ make 39 | ``` 40 | 41 | To load a particular file for interactive use: 42 | 43 | ``` 44 | $ agda --safe -I -i src src/FILE.agda 45 | ``` 46 | 47 | ``` 48 | $ ghci -Wall -isrc src/FILE.hs 49 | ``` 50 | 51 | ``` 52 | $ idris -i src src/FILE.idr 53 | ``` 54 | 55 | Tested with Agda 2.4.2.3, Idris 0.9.19, and GHC 7.8.4. 56 | 57 | 58 | ### Notation 59 | 60 | This section describes the notation available in the PHOAS approach; in the de Bruijn approach, variable binding is not part of the constructors or eliminators. 61 | 62 | #### Agda 63 | 64 | | **Op** | **Type** | **Constructors** | **Eliminators** 65 | | :----: | :-------- | :--------------------------- | :-------------------- 66 | | → | `=>` | `lam` *v* `=>` *e* | *e₁* `$` *e₂* 67 | | ∧ | `&&` | `[` *e₁* `,` *e₂* `]` | `fst` *e* ; `snd` *e* 68 | | ∨ | `||` | `left` *e* ; `right` *e* | `case` *e₀* `of` *v₁* `=>` *e₁* `or` *v₂* `=>` *e₂* 69 | | ⊥ | `FALSE` | — | **I**: `abort` *e* ; **C**: `abort` *v* `=>` *e* 70 | | ↔︎ | `<=>` | — | — 71 | | ¬ | `NOT` | — | — 72 | | ⊤ | `TRUE` | — | — 73 | | ∀ | `FORALL` | `pi` *v* `=>` *e* | *e₁* `$$` *e₂* 74 | | ∃ | `EXISTS` | `[` *e₁* `,,` *e₂* `]` | `split` *e₀* `as` *v* `=>` *e* 75 | | □ | `BOX` | `box` *e* | `unbox` *e₀* `as` *v* `=>` *e* 76 | | ◇ | `DIAMOND` | — | — 77 | 78 | 79 | #### Idris 80 | 81 | | **Op** | **Type** | **Constructors** | **Eliminators** 82 | | :----: | :-------- | :--------------------------- | :-------------------- 83 | | → | `:=>` | `lam` *v* `:=>` *e* | *e₁* `:$` *e₂* 84 | | ∧ | `:&&` | `[` *e₁* `,` *e₂* `]` | `fst` *e* ; `snd` *e* 85 | | ∨ | `:||` | `left` *e* ; `right` *e* | `case` *e₀* `of` *v₁* `:=>` *e₁* `or` *v₂* `:=>` *e₂* 86 | | ⊥ | `FALSE` | — | **I**: `abort` *e* ; **C**: `abort` *v* `:=>` *e* 87 | | ↔︎ | `:<=>` | — | — 88 | | ¬ | `NOT` | — | — 89 | | ⊤ | `TRUE` | — | — 90 | | ∀ | `FORALL` | `pi` *v* `:=>` *e* | *e₁* `:$$` *e₂* 91 | | ∃ | `EXISTS` | `[` *e₁* `,,` *e₂* `]` | `split` *e₀* `as` *v* `:=>` *e* 92 | | □ | `BOX` | `box` *e* | `unbox` *e₀* `as` *v* `:=>` *e* 93 | | ◇ | `DIAMOND` | — | — 94 | 95 | 96 | #### Haskell 97 | 98 | | **Op** | **Type** | **Constructors** | **Eliminators** 99 | | :----: | :-------- | :--------------------------- | :-------------------- 100 | | → | `:=>` | `lam` *λ* | **i**: *e₁* `:$` *e₂* ; **f**: *e₁* `.$` *e₂* 101 | | ∧ | `:&&` | `pair` `(` *e₁* `,` *e₂* `)` | `fst'` *e* ; `snd'`  *e* 102 | | ∨ | `:||` | `left` *e* ; `right` *e* | `case'` *e₀* *λ₁* *λ₂* 103 | | ⊥ | `FALSE` | — | **I**: `abort` *e* ; **C**: `abort` *λ* 104 | | ↔︎ | `:<=>` | — | — 105 | | ¬ | `NOT` | — | — 106 | | ⊤ | `TRUE` | — | — 107 | | ∀ | `FORALL` | `pi` *λ* | **i**: *e₁* `:$$` *e₂* ; **f**: *e₁* `.$$` *e₂* 108 | | ∃ | `EXISTS` | `sig` `(` *e₁* `,` *e₂* `)` | `split` *e₀* *λ* 109 | | □ | `BOX` | `box` *e* | `unbox` *e₀* *λ* 110 | | ◇ | `DIAMOND` | — | — 111 | 112 | 113 | About 114 | ----- 115 | 116 | Made by [Miëtek Bak](https://mietek.io/). Published under the [MIT X11 license](LICENSE.md). 117 | 118 | Thanks to Dominique Devriese, Darryl McAdams, and Andrea Vezzosi for comments and discussion. 119 | 120 | 121 | ### References 122 | 123 | * J.-P. Bernardy, [`PHOAS.hs`](https://github.com/jyp/topics/blob/master/PHOAS/PHOAS.hs), 2008 124 | * G. Boolos, [“The logic of provability”](http://www.cambridge.org/gb/academic/subjects/philosophy/logic/logic-provability), 1993 125 | * J. Carette, O. Kiselyov, C. Shan, [“Finally tagless, partially evaluated: Tagless staged interpreters for simpler typed languages”](http://okmij.org/ftp/tagless-final/JFP.pdf), 2009 126 | * A. Chlipala, [“Parametric higher-order abstract syntax for mechanized semantics”](http://adam.chlipala.net/papers/PhoasICFP08/PhoasICFP08.pdf), 2008 127 | * N.A. Danielsson, [`HOAS.SimplyTyped.agda`](http://www.cse.chalmers.se/~nad/listings/simply-typed/HOAS.SimplyTyped.html), 2008 128 | * D. Devriese, F. Piessens, [“On the bright side of type classes: Instance arguments in Agda”](https://lirias.kuleuven.be/bitstream/123456789/304985/1/icfp001-Devriese.pdf), 2011 129 | * F. Pfenning, R. Davies, [“A judgmental reconstruction of modal logic”](https://www.cs.cmu.edu/~fp/papers/mscs00.pdf), 2001 130 | * A.S. Troelstra, H. Schwichtenberg, [“Basic proof theory”](http://www.cambridge.org/gb/academic/subjects/computer-science/programming-languages-and-applied-logic/basic-proof-theory-2nd-edition), 2000 131 | -------------------------------------------------------------------------------- /src/Bf/ArrMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, de Bruijn approach, final encoding 2 | 3 | module Bf.ArrMp where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | Cx : Set 19 | Cx = List Ty 20 | 21 | isTrue : Ty -> Cx -> Set 22 | isTrue a tc = LMem a tc 23 | 24 | 25 | -- Terms 26 | 27 | TmRepr : Set1 28 | TmRepr = Cx -> Ty -> Set 29 | 30 | module ArrMp where 31 | record Tm (tr : TmRepr) : Set1 where 32 | infixl 1 _$_ 33 | infixr 0 lam=>_ 34 | field 35 | var : forall {tc a} -> isTrue a tc -> tr tc a 36 | lam=>_ : forall {tc a b} -> tr (tc , a) b -> tr tc (a => b) 37 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 38 | 39 | v0 : forall {tc a} -> tr (tc , a) a 40 | v0 = var lzero 41 | 42 | v1 : forall {tc a b} -> tr (tc , a , b) a 43 | v1 = var (lsuc lzero) 44 | 45 | v2 : forall {tc a b c} -> tr (tc , a , b , c) a 46 | v2 = var (lsuc (lsuc lzero)) 47 | open Tm {{...}} public 48 | 49 | Thm : Ty -> Set1 50 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 51 | open ArrMp public 52 | 53 | 54 | -- Example theorems 55 | 56 | aI : forall {a} -> Thm (a => a) 57 | aI = 58 | lam=> v0 59 | 60 | aK : forall {a b} -> Thm (a => b => a) 61 | aK = 62 | lam=> 63 | lam=> v1 64 | 65 | aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c) 66 | aS = 67 | lam=> 68 | lam=> 69 | lam=> v2 $ v0 $ (v1 $ v0) 70 | 71 | tSKK : forall {a} -> Thm (a => a) 72 | tSKK {a = a} = 73 | aS {b = a => a} $ aK $ aK 74 | -------------------------------------------------------------------------------- /src/Bf/BoxMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, de Bruijn approach, final encoding 2 | 3 | module Bf.BoxMp where 4 | 5 | open import Lib using (List; []; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | infixr 0 _=>_ 9 | data Ty : Set where 10 | UNIT : Ty 11 | _=>_ : Ty -> Ty -> Ty 12 | BOX : Ty -> Ty 13 | 14 | 15 | -- Context and truth/validity judgements 16 | 17 | Cx : Set 18 | Cx = List Ty 19 | 20 | isTrue : Ty -> Cx -> Set 21 | isTrue a tc = LMem a tc 22 | 23 | isValid : Ty -> Cx -> Set 24 | isValid a vc = LMem a vc 25 | 26 | 27 | -- Terms 28 | 29 | TmRepr : Set1 30 | TmRepr = Cx -> Cx -> Ty -> Set 31 | 32 | module ArrMp where 33 | record Tm (tr : TmRepr) : Set1 where 34 | infixl 1 _$_ 35 | infixr 0 lam=>_ 36 | field 37 | var : forall {vc tc a} -> isTrue a tc -> tr vc tc a 38 | lam=>_ : forall {vc tc a b} -> tr vc (tc , a) b -> tr vc tc (a => b) 39 | _$_ : forall {vc tc a b} -> tr vc tc (a => b) -> tr vc tc a -> tr vc tc b 40 | 41 | v0 : forall {vc tc a} -> tr vc (tc , a) a 42 | v0 = var lzero 43 | 44 | v1 : forall {vc tc a b} -> tr vc (tc , a , b) a 45 | v1 = var (lsuc lzero) 46 | 47 | v2 : forall {vc tc a b c} -> tr vc (tc , a , b , c) a 48 | v2 = var (lsuc (lsuc lzero)) 49 | open Tm {{...}} public 50 | 51 | module BoxMp where 52 | record Tm (tr : TmRepr) : Set1 where 53 | field 54 | var# : forall {vc tc a} -> isValid a vc -> tr vc tc a 55 | box : forall {vc tc a} -> tr vc [] a -> tr vc tc (BOX a) 56 | unbox' : forall {vc tc a b} -> tr vc tc (BOX a) -> tr (vc , a) tc b -> tr vc tc b 57 | 58 | isArrMp : ArrMp.Tm tr 59 | open ArrMp.Tm isArrMp public 60 | 61 | syntax unbox' x' x = unbox x' as x 62 | 63 | v0# : forall {vc tc a} -> tr (vc , a) tc a 64 | v0# = var# lzero 65 | 66 | v1# : forall {vc tc a b} -> tr (vc , a , b) tc a 67 | v1# = var# (lsuc lzero) 68 | 69 | v2# : forall {vc tc a b c} -> tr (vc , a , b , c) tc a 70 | v2# = var# (lsuc (lsuc lzero)) 71 | open Tm {{...}} public 72 | 73 | Thm : Ty -> Set1 74 | Thm a = forall {tr vc tc} {{_ : Tm tr}} -> tr vc tc a 75 | open BoxMp public 76 | 77 | 78 | -- Example theorems 79 | 80 | rNec : forall {a} -> Thm a -> Thm (BOX a) 81 | rNec x = 82 | box x 83 | 84 | aK : forall {a b} -> Thm (BOX (a => b) => BOX a => BOX b) 85 | aK = 86 | lam=> 87 | lam=> 88 | (unbox v1 as 89 | unbox v0 as 90 | box (v1# $ v0#)) 91 | 92 | aT : forall {a} -> Thm (BOX a => a) 93 | aT = 94 | lam=> 95 | (unbox v0 as v0#) 96 | 97 | a4 : forall {a} -> Thm (BOX a => BOX (BOX a)) 98 | a4 = 99 | lam=> 100 | (unbox v0 as box (box v0#)) 101 | 102 | t2 : forall {a} -> Thm (a => BOX (a => a)) 103 | t2 = 104 | lam=> box (lam=> v0) 105 | -------------------------------------------------------------------------------- /src/Bf/Cp.agda: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, de Bruijn approach, final encoding 2 | 3 | module Bf.Cp where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Set 34 | Cx = List Ty 35 | 36 | isTrue : Ty -> Cx -> Set 37 | isTrue a tc = LMem a tc 38 | 39 | 40 | -- Terms 41 | 42 | TmRepr : Set1 43 | TmRepr = Cx -> Ty -> Set 44 | 45 | module ArrMp where 46 | record Tm (tr : TmRepr) : Set1 where 47 | infixl 1 _$_ 48 | infixr 0 lam=>_ 49 | field 50 | var : forall {tc a} -> isTrue a tc -> tr tc a 51 | lam=>_ : forall {tc a b} -> tr (tc , a) b -> tr tc (a => b) 52 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 53 | 54 | v0 : forall {tc a} -> tr (tc , a) a 55 | v0 = var lzero 56 | 57 | v1 : forall {tc a b} -> tr (tc , a , b) a 58 | v1 = var (lsuc lzero) 59 | 60 | v2 : forall {tc a b c} -> tr (tc , a , b , c) a 61 | v2 = var (lsuc (lsuc lzero)) 62 | open Tm {{...}} public 63 | 64 | module Mp where 65 | record Tm (tr : TmRepr) : Set1 where 66 | field 67 | pair' : forall {tc a b} -> tr tc a -> tr tc b -> tr tc (a && b) 68 | fst : forall {tc a b} -> tr tc (a && b) -> tr tc a 69 | snd : forall {tc a b} -> tr tc (a && b) -> tr tc b 70 | left : forall {tc a b} -> tr tc a -> tr tc (a || b) 71 | right : forall {tc a b} -> tr tc b -> tr tc (a || b) 72 | case' : forall {tc a b c} -> tr tc (a || b) -> tr (tc , a) c -> tr (tc , b) c -> tr tc c 73 | 74 | isArrMp : ArrMp.Tm tr 75 | open ArrMp.Tm isArrMp public 76 | 77 | syntax pair' x y = [ x , y ] 78 | syntax case' xy x y = case xy => x => y 79 | open Tm {{...}} public 80 | 81 | module Cp where 82 | record Tm (tr : TmRepr) : Set1 where 83 | infixr 0 abort=>_ 84 | field 85 | abort=>_ : forall {tc a} -> tr (tc , NOT a) FALSE -> tr tc a 86 | 87 | isMp : Mp.Tm tr 88 | open Mp.Tm isMp public 89 | open Tm {{...}} public 90 | 91 | Thm : Ty -> Set1 92 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 93 | open Cp public 94 | -------------------------------------------------------------------------------- /src/Bf/Ip.agda: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, de Bruijn approach, final encoding 2 | 3 | module Bf.Ip where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Set 34 | Cx = List Ty 35 | 36 | isTrue : Ty -> Cx -> Set 37 | isTrue a tc = LMem a tc 38 | 39 | 40 | -- Terms 41 | 42 | TmRepr : Set1 43 | TmRepr = Cx -> Ty -> Set 44 | 45 | module ArrMp where 46 | record Tm (tr : TmRepr) : Set1 where 47 | infixl 1 _$_ 48 | infixr 0 lam=>_ 49 | field 50 | var : forall {tc a} -> isTrue a tc -> tr tc a 51 | lam=>_ : forall {tc a b} -> tr (tc , a) b -> tr tc (a => b) 52 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 53 | 54 | v0 : forall {tc a} -> tr (tc , a) a 55 | v0 = var lzero 56 | 57 | v1 : forall {tc a b} -> tr (tc , a , b) a 58 | v1 = var (lsuc lzero) 59 | 60 | v2 : forall {tc a b c} -> tr (tc , a , b , c) a 61 | v2 = var (lsuc (lsuc lzero)) 62 | open Tm {{...}} public 63 | 64 | module Mp where 65 | record Tm (tr : TmRepr) : Set1 where 66 | field 67 | pair' : forall {tc a b} -> tr tc a -> tr tc b -> tr tc (a && b) 68 | fst : forall {tc a b} -> tr tc (a && b) -> tr tc a 69 | snd : forall {tc a b} -> tr tc (a && b) -> tr tc b 70 | left : forall {tc a b} -> tr tc a -> tr tc (a || b) 71 | right : forall {tc a b} -> tr tc b -> tr tc (a || b) 72 | case' : forall {tc a b c} -> tr tc (a || b) -> tr (tc , a) c -> tr (tc , b) c -> tr tc c 73 | 74 | isArrMp : ArrMp.Tm tr 75 | open ArrMp.Tm isArrMp public 76 | 77 | syntax pair' x y = [ x , y ] 78 | syntax case' xy x y = case xy => x => y 79 | open Tm {{...}} public 80 | 81 | module Ip where 82 | record Tm (tr : TmRepr) : Set1 where 83 | field 84 | abort : forall {tc a} -> tr tc FALSE -> tr tc a 85 | 86 | isMp : Mp.Tm tr 87 | open Mp.Tm isMp public 88 | open Tm {{...}} public 89 | 90 | Thm : Ty -> Set1 91 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 92 | open Ip public 93 | 94 | 95 | -- Example theorems 96 | 97 | t1 : forall {a b} -> Thm (a => NOT a => b) 98 | t1 = 99 | lam=> 100 | lam=> abort (v0 $ v1) 101 | 102 | t2 : forall {a b} -> Thm (NOT a => a => b) 103 | t2 = 104 | lam=> 105 | lam=> abort (v1 $ v0) 106 | 107 | t3 : forall {a} -> Thm (a => NOT (NOT a)) 108 | t3 = 109 | lam=> 110 | lam=> v0 $ v1 111 | 112 | t4 : forall {a} -> Thm (NOT a <=> NOT (NOT (NOT a))) 113 | t4 = 114 | [ lam=> 115 | lam=> v0 $ v1 116 | , lam=> 117 | lam=> v1 $ (lam=> v0 $ v1) 118 | ] 119 | -------------------------------------------------------------------------------- /src/Bf/Mp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, de Bruijn approach, final encoding 2 | 3 | module Bf.Mp where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Set 34 | Cx = List Ty 35 | 36 | isTrue : Ty -> Cx -> Set 37 | isTrue a tc = LMem a tc 38 | 39 | 40 | -- Terms 41 | 42 | TmRepr : Set1 43 | TmRepr = Cx -> Ty -> Set 44 | 45 | module ArrMp where 46 | record Tm (tr : TmRepr) : Set1 where 47 | infixl 1 _$_ 48 | infixr 0 lam=>_ 49 | field 50 | var : forall {tc a} -> isTrue a tc -> tr tc a 51 | lam=>_ : forall {tc a b} -> tr (tc , a) b -> tr tc (a => b) 52 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 53 | 54 | v0 : forall {tc a} -> tr (tc , a) a 55 | v0 = var lzero 56 | 57 | v1 : forall {tc a b} -> tr (tc , a , b) a 58 | v1 = var (lsuc lzero) 59 | 60 | v2 : forall {tc a b c} -> tr (tc , a , b , c) a 61 | v2 = var (lsuc (lsuc lzero)) 62 | open Tm {{...}} public 63 | 64 | module Mp where 65 | record Tm (tr : TmRepr) : Set1 where 66 | field 67 | pair' : forall {tc a b} -> tr tc a -> tr tc b -> tr tc (a && b) 68 | fst : forall {tc a b} -> tr tc (a && b) -> tr tc a 69 | snd : forall {tc a b} -> tr tc (a && b) -> tr tc b 70 | left : forall {tc a b} -> tr tc a -> tr tc (a || b) 71 | right : forall {tc a b} -> tr tc b -> tr tc (a || b) 72 | case' : forall {tc a b c} -> tr tc (a || b) -> tr (tc , a) c -> tr (tc , b) c -> tr tc c 73 | 74 | isArrMp : ArrMp.Tm tr 75 | open ArrMp.Tm isArrMp public 76 | 77 | syntax pair' x y = [ x , y ] 78 | syntax case' xy x y = case xy => x => y 79 | open Tm {{...}} public 80 | 81 | Thm : Ty -> Set1 82 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 83 | open Mp public 84 | 85 | 86 | -- Example theorems 87 | 88 | c1 : forall {a b} -> Thm (a && b <=> b && a) 89 | c1 = 90 | [ lam=> [ snd v0 , fst v0 ] 91 | , lam=> [ snd v0 , fst v0 ] 92 | ] 93 | 94 | c2 : forall {a b} -> Thm (a || b <=> b || a) 95 | c2 = 96 | [ lam=> 97 | (case v0 98 | => right v0 99 | => left v0) 100 | , lam=> 101 | (case v0 102 | => right v0 103 | => left v0) 104 | ] 105 | 106 | i1 : forall {a} -> Thm (a && a <=> a) 107 | i1 = 108 | [ lam=> fst v0 109 | , lam=> [ v0 , v0 ] 110 | ] 111 | 112 | i2 : forall {a} -> Thm (a || a <=> a) 113 | i2 = 114 | [ lam=> 115 | (case v0 116 | => v0 117 | => v0) 118 | , lam=> left v0 119 | ] 120 | 121 | l3 : forall {a} -> Thm ((a => a) <=> TRUE) 122 | l3 = 123 | [ lam=> lam=> v0 124 | , lam=> lam=> v0 125 | ] 126 | 127 | l1 : forall {a b c} -> Thm (a && (b && c) <=> (a && b) && c) 128 | l1 = 129 | [ lam=> 130 | [ [ fst v0 , fst (snd v0) ] 131 | , snd (snd v0) 132 | ] 133 | , lam=> 134 | [ fst (fst v0) 135 | , [ snd (fst v0) , snd v0 ] 136 | ] 137 | ] 138 | 139 | l2 : forall {a} -> Thm (a && TRUE <=> a) 140 | l2 = 141 | [ lam=> fst v0 142 | , lam=> [ v0 , lam=> v0 ] 143 | ] 144 | 145 | l4 : forall {a b c} -> Thm (a && (b || c) <=> (a && b) || (a && c)) 146 | l4 = 147 | [ lam=> 148 | (case snd v0 149 | => left [ fst v1 , v0 ] 150 | => right [ fst v1 , v0 ]) 151 | , lam=> 152 | (case v0 153 | => [ fst v0 , left (snd v0) ] 154 | => [ fst v0 , right (snd v0) ]) 155 | ] 156 | 157 | l6 : forall {a b c} -> Thm (a || (b && c) <=> (a || b) && (a || c)) 158 | l6 = 159 | [ lam=> 160 | (case v0 161 | => [ left v0 , left v0 ] 162 | => [ right (fst v0) , right (snd v0) ]) 163 | , lam=> 164 | (case fst v0 165 | => left v0 166 | => 167 | case snd v1 168 | => left v0 169 | => right [ v1 , v0 ]) 170 | ] 171 | 172 | l7 : forall {a} -> Thm (a || TRUE <=> TRUE) 173 | l7 = 174 | [ lam=> lam=> v0 175 | , lam=> right v0 176 | ] 177 | 178 | l9 : forall {a b c} -> Thm (a || (b || c) <=> (a || b) || c) 179 | l9 = 180 | [ lam=> 181 | (case v0 182 | => left (left v0) 183 | => 184 | case v0 185 | => left (right v0) 186 | => right v0) 187 | , lam=> 188 | (case v0 189 | => 190 | case v0 191 | => left v0 192 | => right (left v0) 193 | => right (right v0)) 194 | ] 195 | 196 | l11 : forall {a b c} -> Thm ((a => (b && c)) <=> (a => b) && (a => c)) 197 | l11 = 198 | [ lam=> 199 | [ lam=> fst (v1 $ v0) 200 | , lam=> snd (v1 $ v0) 201 | ] 202 | , lam=> 203 | lam=> [ fst v1 $ v0 , snd v1 $ v0 ] 204 | ] 205 | 206 | l12 : forall {a} -> Thm ((a => TRUE) <=> TRUE) 207 | l12 = 208 | [ lam=> lam=> v0 209 | , lam=> lam=> v1 210 | ] 211 | 212 | l13 : forall {a b c} -> Thm ((a => (b => c)) <=> ((a && b) => c)) 213 | l13 = 214 | [ lam=> 215 | lam=> v1 $ fst v0 $ snd v0 216 | , lam=> 217 | lam=> 218 | lam=> v2 $ [ v1 , v0 ] 219 | ] 220 | 221 | l16 : forall {a b c} -> Thm (((a && b) => c) <=> (a => (b => c))) 222 | l16 = 223 | [ lam=> 224 | lam=> 225 | lam=> v2 $ [ v1 , v0 ] 226 | , lam=> 227 | lam=> v1 $ fst v0 $ snd v0 228 | ] 229 | 230 | l17 : forall {a} -> Thm ((TRUE => a) <=> a) 231 | l17 = 232 | [ lam=> v0 $ (lam=> v0) 233 | , lam=> lam=> v1 234 | ] 235 | 236 | l19 : forall {a b c} -> Thm (((a || b) => c) <=> (a => c) && (b => c)) 237 | l19 = 238 | [ lam=> 239 | [ lam=> v1 $ left v0 240 | , lam=> v1 $ right v0 241 | ] 242 | , lam=> 243 | lam=> 244 | (case v0 245 | => fst v2 $ v0 246 | => snd v2 $ v0) 247 | ] 248 | -------------------------------------------------------------------------------- /src/Bi/ArrMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, de Bruijn approach, initial encoding 2 | 3 | module Bi.ArrMp where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | Cx : Set 19 | Cx = List Ty 20 | 21 | isTrue : Ty -> Cx -> Set 22 | isTrue a tc = LMem a tc 23 | 24 | 25 | -- Terms 26 | 27 | module ArrMp where 28 | infixl 1 _$_ 29 | infixr 0 lam=>_ 30 | data Tm (tc : Cx) : Ty -> Set where 31 | var : forall {a} -> isTrue a tc -> Tm tc a 32 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 33 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 34 | 35 | v0 : forall {tc a} -> Tm (tc , a) a 36 | v0 = var lzero 37 | 38 | v1 : forall {tc a b} -> Tm (tc , a , b) a 39 | v1 = var (lsuc lzero) 40 | 41 | v2 : forall {tc a b c} -> Tm (tc , a , b , c) a 42 | v2 = var (lsuc (lsuc lzero)) 43 | 44 | Thm : Ty -> Set 45 | Thm a = forall {tc} -> Tm tc a 46 | open ArrMp public 47 | 48 | 49 | -- Example theorems 50 | 51 | aI : forall {a} -> Thm (a => a) 52 | aI = 53 | lam=> v0 54 | 55 | aK : forall {a b} -> Thm (a => b => a) 56 | aK = 57 | lam=> 58 | lam=> v1 59 | 60 | aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c) 61 | aS = 62 | lam=> 63 | lam=> 64 | lam=> v2 $ v0 $ (v1 $ v0) 65 | 66 | tSKK : forall {a} -> Thm (a => a) 67 | tSKK {a = a} = 68 | aS {b = a => a} $ aK $ aK 69 | -------------------------------------------------------------------------------- /src/Bi/BoxMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, de Bruijn approach, initial encoding 2 | 3 | module Bi.BoxMp where 4 | 5 | open import Lib using (List; []; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | BOX : Ty -> Ty 15 | 16 | 17 | -- Context and truth/validity judgements 18 | 19 | Cx : Set 20 | Cx = List Ty 21 | 22 | isTrue : Ty -> Cx -> Set 23 | isTrue a tc = LMem a tc 24 | 25 | isValid : Ty -> Cx -> Set 26 | isValid a vc = LMem a vc 27 | 28 | 29 | -- Terms 30 | 31 | module BoxMp where 32 | infixl 1 _$_ 33 | infixr 0 lam=>_ 34 | data Tm (vc tc : Cx) : Ty -> Set where 35 | var : forall {a} -> isTrue a tc -> Tm vc tc a 36 | lam=>_ : forall {a b} -> Tm vc (tc , a) b -> Tm vc tc (a => b) 37 | _$_ : forall {a b} -> Tm vc tc (a => b) -> Tm vc tc a -> Tm vc tc b 38 | var# : forall {a} -> isValid a vc -> Tm vc tc a 39 | box : forall {a} -> Tm vc [] a -> Tm vc tc (BOX a) 40 | unbox' : forall {a b} -> Tm vc tc (BOX a) -> Tm (vc , a) tc b -> Tm vc tc b 41 | 42 | syntax unbox' x' x = unbox x' => x 43 | 44 | v0 : forall {vc tc a} -> Tm vc (tc , a) a 45 | v0 = var lzero 46 | 47 | v1 : forall {vc tc a b} -> Tm vc (tc , a , b) a 48 | v1 = var (lsuc lzero) 49 | 50 | v2 : forall {vc tc a b c} -> Tm vc (tc , a , b , c) a 51 | v2 = var (lsuc (lsuc lzero)) 52 | 53 | v0# : forall {vc tc a} -> Tm (vc , a) tc a 54 | v0# = var# lzero 55 | 56 | v1# : forall {vc tc a b} -> Tm (vc , a , b) tc a 57 | v1# = var# (lsuc lzero) 58 | 59 | v2# : forall {vc tc a b c} -> Tm (vc , a , b , c) tc a 60 | v2# = var# (lsuc (lsuc lzero)) 61 | 62 | Thm : Ty -> Set 63 | Thm a = forall {vc tc} -> Tm vc tc a 64 | open BoxMp public 65 | 66 | 67 | -- Example theorems 68 | 69 | rNec : forall {a} -> Thm a -> Thm (BOX a) 70 | rNec x = 71 | box x 72 | 73 | aK : forall {a b} -> Thm (BOX (a => b) => BOX a => BOX b) 74 | aK = 75 | lam=> 76 | lam=> 77 | (unbox v1 => 78 | unbox v0 => 79 | box (v1# $ v0#)) 80 | 81 | aT : forall {a} -> Thm (BOX a => a) 82 | aT = 83 | lam=> 84 | (unbox v0 => v0#) 85 | 86 | a4 : forall {a} -> Thm (BOX a => BOX (BOX a)) 87 | a4 = 88 | lam=> 89 | (unbox v0 => box (box v0#)) 90 | 91 | t1 : forall {a} -> Thm (a => BOX (a => a)) 92 | t1 = 93 | lam=> box (lam=> v0) 94 | -------------------------------------------------------------------------------- /src/Bi/Cp.agda: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, de Bruijn approach, initial encoding 2 | 3 | module Bi.Cp where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Set 34 | Cx = List Ty 35 | 36 | isTrue : Ty -> Cx -> Set 37 | isTrue a tc = LMem a tc 38 | 39 | 40 | -- Terms 41 | 42 | module Cp where 43 | infixl 1 _$_ 44 | infixr 0 lam=>_ 45 | infixr 0 abort=>_ 46 | data Tm (tc : Cx) : Ty -> Set where 47 | var : forall {a} -> isTrue a tc -> Tm tc a 48 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 49 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 50 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 51 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 52 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 53 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 54 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 55 | case' : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c 56 | abort=>_ : forall {a} -> Tm (tc , NOT a) FALSE -> Tm tc a 57 | 58 | syntax pair' x y = [ x , y ] 59 | syntax case' xy x y = case xy => x => y 60 | 61 | v0 : forall {tc a} -> Tm (tc , a) a 62 | v0 = var lzero 63 | 64 | v1 : forall {tc a b} -> Tm (tc , a , b) a 65 | v1 = var (lsuc lzero) 66 | 67 | v2 : forall {tc a b c} -> Tm (tc , a , b , c) a 68 | v2 = var (lsuc (lsuc lzero)) 69 | 70 | Thm : Ty -> Set 71 | Thm a = forall {tc} -> Tm tc a 72 | open Cp public 73 | -------------------------------------------------------------------------------- /src/Bi/Ip.agda: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, de Bruijn approach, initial encoding 2 | 3 | module Bi.Ip where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Set 34 | Cx = List Ty 35 | 36 | isTrue : Ty -> Cx -> Set 37 | isTrue a tc = LMem a tc 38 | 39 | 40 | -- Terms 41 | 42 | module Ip where 43 | infixl 1 _$_ 44 | infixr 0 lam=>_ 45 | data Tm (tc : Cx) : Ty -> Set where 46 | var : forall {a} -> isTrue a tc -> Tm tc a 47 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 48 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 49 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 50 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 51 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 52 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 53 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 54 | case' : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c 55 | abort : forall {a} -> Tm tc FALSE -> Tm tc a 56 | 57 | syntax pair' x y = [ x , y ] 58 | syntax case' xy x y = case xy => x => y 59 | 60 | v0 : forall {tc a} -> Tm (tc , a) a 61 | v0 = var lzero 62 | 63 | v1 : forall {tc a b} -> Tm (tc , a , b) a 64 | v1 = var (lsuc lzero) 65 | 66 | v2 : forall {tc a b c} -> Tm (tc , a , b , c) a 67 | v2 = var (lsuc (lsuc lzero)) 68 | 69 | Thm : Ty -> Set 70 | Thm a = forall {tc} -> Tm tc a 71 | open Ip public 72 | 73 | 74 | -- Example theorems 75 | 76 | t1 : forall {a b} -> Thm (a => NOT a => b) 77 | t1 = 78 | lam=> 79 | lam=> abort (v0 $ v1) 80 | 81 | t2 : forall {a b} -> Thm (NOT a => a => b) 82 | t2 = 83 | lam=> 84 | lam=> abort (v1 $ v0) 85 | 86 | t3 : forall {a} -> Thm (a => NOT (NOT a)) 87 | t3 = 88 | lam=> 89 | lam=> v0 $ v1 90 | 91 | t4 : forall {a} -> Thm (NOT a <=> NOT (NOT (NOT a))) 92 | t4 = 93 | [ lam=> 94 | lam=> v0 $ v1 95 | , lam=> 96 | lam=> v1 $ (lam=> v0 $ v1) 97 | ] 98 | -------------------------------------------------------------------------------- /src/Bi/Mp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, de Bruijn approach, initial encoding 2 | 3 | module Bi.Mp where 4 | 5 | open import Lib using (List; _,_; LMem; lzero; lsuc) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Set 34 | Cx = List Ty 35 | 36 | isTrue : Ty -> Cx -> Set 37 | isTrue a tc = LMem a tc 38 | 39 | 40 | -- Terms 41 | 42 | module Mp where 43 | infixl 1 _$_ 44 | infixr 0 lam=>_ 45 | data Tm (tc : Cx) : Ty -> Set where 46 | var : forall {a} -> isTrue a tc -> Tm tc a 47 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 48 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 49 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 50 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 51 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 52 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 53 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 54 | case' : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c 55 | 56 | syntax pair' x y = [ x , y ] 57 | syntax case' xy x y = case xy => x => y 58 | 59 | v0 : forall {tc a} -> Tm (tc , a) a 60 | v0 = var lzero 61 | 62 | v1 : forall {tc a b} -> Tm (tc , a , b) a 63 | v1 = var (lsuc lzero) 64 | 65 | v2 : forall {tc a b c} -> Tm (tc , a , b , c) a 66 | v2 = var (lsuc (lsuc lzero)) 67 | 68 | Thm : Ty -> Set 69 | Thm a = forall {tc} -> Tm tc a 70 | open Mp public 71 | 72 | 73 | -- Example theorems 74 | 75 | c1 : forall {a b} -> Thm (a && b <=> b && a) 76 | c1 = 77 | [ lam=> [ snd v0 , fst v0 ] 78 | , lam=> [ snd v0 , fst v0 ] 79 | ] 80 | 81 | c2 : forall {a b} -> Thm (a || b <=> b || a) 82 | c2 = 83 | [ lam=> 84 | (case v0 85 | => right v0 86 | => left v0) 87 | , lam=> 88 | (case v0 89 | => right v0 90 | => left v0) 91 | ] 92 | 93 | i1 : forall {a} -> Thm (a && a <=> a) 94 | i1 = 95 | [ lam=> fst v0 96 | , lam=> [ v0 , v0 ] 97 | ] 98 | 99 | i2 : forall {a} -> Thm (a || a <=> a) 100 | i2 = 101 | [ lam=> 102 | (case v0 103 | => v0 104 | => v0) 105 | , lam=> left v0 106 | ] 107 | 108 | l3 : forall {a} -> Thm ((a => a) <=> TRUE) 109 | l3 = 110 | [ lam=> lam=> v0 111 | , lam=> lam=> v0 112 | ] 113 | 114 | l1 : forall {a b c} -> Thm (a && (b && c) <=> (a && b) && c) 115 | l1 = 116 | [ lam=> 117 | [ [ fst v0 , fst (snd v0) ] 118 | , snd (snd v0) 119 | ] 120 | , lam=> 121 | [ fst (fst v0) 122 | , [ snd (fst v0) , snd v0 ] 123 | ] 124 | ] 125 | 126 | l2 : forall {a} -> Thm (a && TRUE <=> a) 127 | l2 = 128 | [ lam=> fst v0 129 | , lam=> [ v0 , lam=> v0 ] 130 | ] 131 | 132 | l4 : forall {a b c} -> Thm (a && (b || c) <=> (a && b) || (a && c)) 133 | l4 = 134 | [ lam=> 135 | (case snd v0 136 | => left [ fst v1 , v0 ] 137 | => right [ fst v1 , v0 ]) 138 | , lam=> 139 | (case v0 140 | => [ fst v0 , left (snd v0) ] 141 | => [ fst v0 , right (snd v0) ]) 142 | ] 143 | 144 | l6 : forall {a b c} -> Thm (a || (b && c) <=> (a || b) && (a || c)) 145 | l6 = 146 | [ lam=> 147 | (case v0 148 | => [ left v0 , left v0 ] 149 | => [ right (fst v0) , right (snd v0) ]) 150 | , lam=> 151 | (case fst v0 152 | => left v0 153 | => 154 | case snd v1 155 | => left v0 156 | => right [ v1 , v0 ]) 157 | ] 158 | 159 | l7 : forall {a} -> Thm (a || TRUE <=> TRUE) 160 | l7 = 161 | [ lam=> lam=> v0 162 | , lam=> right v0 163 | ] 164 | 165 | l9 : forall {a b c} -> Thm (a || (b || c) <=> (a || b) || c) 166 | l9 = 167 | [ lam=> 168 | (case v0 169 | => left (left v0) 170 | => 171 | case v0 172 | => left (right v0) 173 | => right v0) 174 | , lam=> 175 | (case v0 176 | => 177 | case v0 178 | => left v0 179 | => right (left v0) 180 | => right (right v0)) 181 | ] 182 | 183 | l11 : forall {a b c} -> Thm ((a => (b && c)) <=> (a => b) && (a => c)) 184 | l11 = 185 | [ lam=> 186 | [ lam=> fst (v1 $ v0) 187 | , lam=> snd (v1 $ v0) 188 | ] 189 | , lam=> 190 | lam=> [ fst v1 $ v0 , snd v1 $ v0 ] 191 | ] 192 | 193 | l12 : forall {a} -> Thm ((a => TRUE) <=> TRUE) 194 | l12 = 195 | [ lam=> lam=> v0 196 | , lam=> lam=> v1 197 | ] 198 | 199 | l13 : forall {a b c} -> Thm ((a => (b => c)) <=> ((a && b) => c)) 200 | l13 = 201 | [ lam=> 202 | lam=> v1 $ fst v0 $ snd v0 203 | , lam=> 204 | lam=> 205 | lam=> v2 $ [ v1 , v0 ] 206 | ] 207 | 208 | l16 : forall {a b c} -> Thm (((a && b) => c) <=> (a => (b => c))) 209 | l16 = 210 | [ lam=> 211 | lam=> 212 | lam=> v2 $ [ v1 , v0 ] 213 | , lam=> 214 | lam=> v1 $ fst v0 $ snd v0 215 | ] 216 | 217 | l17 : forall {a} -> Thm ((TRUE => a) <=> a) 218 | l17 = 219 | [ lam=> v0 $ (lam=> v0) 220 | , lam=> lam=> v1 221 | ] 222 | 223 | l19 : forall {a b c} -> Thm (((a || b) => c) <=> (a => c) && (b => c)) 224 | l19 = 225 | [ lam=> 226 | [ lam=> v1 $ left v0 227 | , lam=> v1 $ right v0 228 | ] 229 | , lam=> 230 | lam=> 231 | (case v0 232 | => fst v2 $ v0 233 | => snd v2 $ v0) 234 | ] 235 | -------------------------------------------------------------------------------- /src/Lib.agda: -------------------------------------------------------------------------------- 1 | module Lib where 2 | 3 | 4 | -- Natural numbers 5 | 6 | data Nat : Set where 7 | zero : Nat 8 | suc : Nat -> Nat 9 | 10 | {-# BUILTIN NATURAL Nat #-} 11 | 12 | _+_ : Nat -> Nat -> Nat 13 | zero + n = n 14 | suc k + n = suc (k + n) 15 | 16 | 17 | -- Finite sets 18 | 19 | data Fin : Nat -> Set where 20 | fzero : forall {n} -> Fin (suc n) 21 | fsuc : forall {n} -> Fin n -> Fin (suc n) 22 | 23 | fin : forall {n} (k : Nat) -> Fin (suc (k + n)) 24 | fin zero = fzero 25 | fin (suc i) = fsuc (fin i) 26 | 27 | 28 | -- Lists 29 | 30 | infixl 0 _,_ 31 | 32 | data List (X : Set) : Set where 33 | [] : List X 34 | _,_ : List X -> X -> List X 35 | 36 | 37 | -- List membership 38 | 39 | data LMem {X : Set} (a : X) : List X -> Set where 40 | lzero : forall {l} -> LMem a (l , a) 41 | lsuc : forall {l b} -> LMem a l -> LMem a (l , b) 42 | 43 | 44 | -- Vectors 45 | 46 | data Vec (X : Set) : Nat -> Set where 47 | [] : Vec X zero 48 | _,_ : forall {n} -> Vec X n -> X -> Vec X (suc n) 49 | 50 | proj : forall {X n} -> Vec X n -> Fin n -> X 51 | proj [] () 52 | proj (_ , a) fzero = a 53 | proj (v , _) (fsuc i) = proj v i 54 | 55 | 56 | -- Vector membership 57 | 58 | data VMem {X : Set} (a : X) : forall {n} -> Fin n -> Vec X n -> Set where 59 | mzero : forall {n} {v : Vec X n} -> VMem a fzero (v , a) 60 | msuc : forall {n i b} {v : Vec X n} -> VMem a i v -> VMem a (fsuc i) (v , b) 61 | 62 | fmem : forall {X n} -> (i : Fin n) -> {v : Vec X n} -> VMem (proj v i) i v 63 | fmem {_} {zero} () 64 | fmem {_} {suc n} fzero {_ , a} = mzero 65 | fmem {_} {suc n} (fsuc i) {v , _} = msuc (fmem i) 66 | 67 | mem : forall {X n} -> (k : Nat) -> {v : Vec X (suc (k + n))} -> VMem (proj v (fin k)) (fin k) v 68 | mem i = fmem (fin i) 69 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeFamilies, TypeOperators #-} 2 | 3 | module Lib where 4 | 5 | 6 | -- Natural numbers 7 | 8 | data Nat :: * where 9 | Zero :: Nat 10 | Suc :: Nat -> Nat 11 | 12 | 13 | infixl 6 :+ 14 | 15 | type family (m :: Nat) :+ (n :: Nat) :: Nat 16 | type instance Zero :+ n = n 17 | type instance Suc k :+ n = Suc (k :+ n) 18 | -------------------------------------------------------------------------------- /src/Pf/ArrMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, PHOAS approach, final encoding 2 | 3 | module Pf.ArrMp where 4 | 5 | 6 | -- Types 7 | 8 | infixr 0 _=>_ 9 | data Ty : Set where 10 | UNIT : Ty 11 | _=>_ : Ty -> Ty -> Ty 12 | 13 | 14 | -- Context and truth judgement 15 | 16 | Cx : Set1 17 | Cx = Ty -> Set 18 | 19 | isTrue : Ty -> Cx -> Set 20 | isTrue a tc = tc a 21 | 22 | 23 | -- Terms 24 | 25 | TmRepr : Set1 26 | TmRepr = Cx -> Ty -> Set 27 | 28 | module ArrMp where 29 | record Tm (tr : TmRepr) : Set1 where 30 | infixl 1 _$_ 31 | field 32 | var : forall {tc a} -> isTrue a tc -> tr tc a 33 | lam' : forall {tc a b} -> (isTrue a tc -> tr tc b) -> tr tc (a => b) 34 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 35 | 36 | lam'' : forall {tc a b} -> (tr tc a -> tr tc b) -> tr tc (a => b) 37 | lam'' f = lam' \x -> f (var x) 38 | 39 | syntax lam'' (\a -> b) = lam a => b 40 | open Tm {{...}} public 41 | 42 | Thm : Ty -> Set1 43 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 44 | open ArrMp public 45 | 46 | 47 | -- Example theorems 48 | 49 | aI : forall {a} -> Thm (a => a) 50 | aI = 51 | lam x => x 52 | 53 | aK : forall {a b} -> Thm (a => b => a) 54 | aK = 55 | lam x => 56 | lam _ => x 57 | 58 | aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c) 59 | aS = 60 | lam f => 61 | lam g => 62 | lam x => f $ x $ (g $ x) 63 | 64 | tSKK : forall {a} -> Thm (a => a) 65 | tSKK {a = a} = 66 | aS {b = a => a} $ aK $ aK 67 | -------------------------------------------------------------------------------- /src/Pf/ArrMp.hs: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, PHOAS approach, final encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pf.ArrMp where 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 :=> 11 | data Ty :: * where 12 | UNIT :: Ty 13 | (:=>) :: Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | -- NOTE: Haskell does not support kind synonyms 19 | -- type Cx = Ty -> * 20 | 21 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 22 | 23 | 24 | -- Terms 25 | 26 | -- type TmRepr :: (Ty -> *) -> Ty -> * 27 | 28 | infixl 1 .$ 29 | class ArrMpTm (tr :: (Ty -> *) -> Ty -> *) where 30 | var :: IsTrue a tc -> tr tc a 31 | lam' :: (IsTrue a tc -> tr tc b) -> tr tc (a :=> b) 32 | (.$) :: tr tc (a :=> b) -> tr tc a -> tr tc b 33 | 34 | lam :: ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 35 | lam f = lam' $ \x -> f (var x) 36 | 37 | type Thm a = ArrMpTm tr => tr tc a 38 | 39 | 40 | -- Example theorems 41 | 42 | aI :: Thm (a :=> a) 43 | aI = 44 | lam $ \x -> x 45 | 46 | aK :: Thm (a :=> b :=> a) 47 | aK = 48 | lam $ \x -> 49 | lam $ \_ -> x 50 | 51 | aS :: Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c) 52 | aS = 53 | lam $ \f -> 54 | lam $ \g -> 55 | lam $ \x -> f .$ x .$ (g .$ x) 56 | 57 | tSKK :: Thm (a :=> a) 58 | tSKK = 59 | aS .$ aK .$ aK 60 | -------------------------------------------------------------------------------- /src/Pf/ArrMp.idr: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, PHOAS approach, final encoding 2 | 3 | module Pf.ArrMp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 :=> 11 | data Ty : Type where 12 | UNIT : Ty 13 | (:=>) : Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | Cx : Type 19 | Cx = Ty -> Type 20 | 21 | isTrue : Ty -> Cx -> Type 22 | isTrue a tc = tc a 23 | 24 | 25 | -- Terms 26 | 27 | TmRepr : Type 28 | TmRepr = Cx -> Ty -> Type 29 | 30 | infixl 1 :$ 31 | class ArrMpTm (tr : TmRepr) where 32 | var : isTrue a tc -> tr tc a 33 | lam' : (isTrue a tc -> tr tc b) -> tr tc (a :=> b) 34 | (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b 35 | 36 | lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 37 | lam'' f = lam' $ \x => f (var x) 38 | 39 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 40 | 41 | Thm : Ty -> Type 42 | Thm a = {tr : TmRepr} -> {tc : Cx} -> ArrMpTm tr => tr tc a 43 | 44 | 45 | -- Example theorems 46 | 47 | aI : Thm (a :=> a) 48 | aI = 49 | lam x :=> x 50 | 51 | aK : Thm (a :=> b :=> a) 52 | aK = 53 | lam x :=> 54 | lam y :=> x 55 | 56 | aS : Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c) 57 | aS = 58 | lam f :=> 59 | lam g :=> 60 | lam x :=> f :$ x :$ (g :$ x) 61 | 62 | -- TODO: 63 | -- ./src/Pf/ArrMp.idr:63:6:When checking right hand side of tSKK: 64 | -- Can't resolve type class ArrMpTm tr 65 | -- tSKK : Thm (a :=> a) 66 | -- tSKK {a} = 67 | -- aS {b = a :=> a} :$ aK :$ aK 68 | -------------------------------------------------------------------------------- /src/Pf/BoxMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, PHOAS approach, final encoding 2 | 3 | module Pf.BoxMp where 4 | 5 | open import Lib using (Nat; suc) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | BOX : Ty -> Ty 15 | 16 | 17 | -- Context and truth judgement with modal depth 18 | 19 | Cx : Set1 20 | Cx = Ty -> Nat -> Set 21 | 22 | isTrue : Ty -> Nat -> Cx -> Set 23 | isTrue a d tc = tc a d 24 | 25 | 26 | -- Terms 27 | 28 | TmRepr : Set1 29 | TmRepr = Nat -> Cx -> Ty -> Set 30 | 31 | module ArrMp where 32 | record Tm (tr : TmRepr) : Set1 where 33 | infixl 1 _$_ 34 | field 35 | var : forall {d tc a} -> isTrue a d tc -> tr d tc a 36 | lam' : forall {d tc a b} -> (isTrue a d tc -> tr d tc b) -> tr d tc (a => b) 37 | _$_ : forall {d tc a b} -> tr d tc (a => b) -> tr d tc a -> tr d tc b 38 | 39 | lam'' : forall {d tc a b} -> (tr d tc a -> tr d tc b) -> tr d tc (a => b) 40 | lam'' f = lam' \x -> f (var x) 41 | 42 | syntax lam'' (\a -> b) = lam a => b 43 | open Tm {{...}} public 44 | 45 | module BoxMp where 46 | record Tm (tr : TmRepr) : Set1 where 47 | field 48 | box : forall {d tc a} -> tr (suc d) tc a -> tr d tc (BOX a) 49 | unbox' : forall {d >d tc a b} -> tr d tc (BOX a) -> (isTrue a >d tc -> tr d tc b) -> tr d tc b 50 | 51 | isArrMp : ArrMp.Tm tr 52 | open ArrMp.Tm isArrMp public 53 | 54 | unbox'' : forall {d >d tc a b} -> tr d tc (BOX a) -> (tr >d tc a -> tr d tc b) -> tr d tc b 55 | unbox'' x' f = unbox' x' \x -> f (var x) 56 | 57 | syntax unbox'' x' (\x -> y) = unbox x' as x => y 58 | open Tm {{...}} public 59 | 60 | Thm : Ty -> Set1 61 | Thm a = forall {tr d tc} {{_ : Tm tr}} -> tr d tc a 62 | open BoxMp public 63 | 64 | 65 | -- Example theorems 66 | 67 | rNec : forall {a} -> Thm a -> Thm (BOX a) 68 | rNec x = 69 | box x 70 | 71 | aK : forall {a b} -> Thm (BOX (a => b) => BOX a => BOX b) 72 | aK = 73 | lam f' => 74 | lam x' => 75 | unbox f' as f => 76 | unbox x' as x => 77 | box (f $ x) 78 | 79 | aT : forall {a} -> Thm (BOX a => a) 80 | aT = 81 | lam x' => 82 | unbox x' as x => x 83 | 84 | a4 : forall {a} -> Thm (BOX a => BOX (BOX a)) 85 | a4 = 86 | lam x' => 87 | unbox x' as x => box (box x) 88 | 89 | t1 : forall {a} -> Thm (a => BOX (a => a)) 90 | t1 = 91 | lam _ => box (lam y => y) 92 | -------------------------------------------------------------------------------- /src/Pf/BoxMp.hs: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, PHOAS approach, final encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pf.BoxMp where 6 | 7 | import Lib (Nat (Suc)) 8 | 9 | 10 | -- Types 11 | 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | BOX :: Ty -> Ty 17 | 18 | 19 | -- Context and truth judgement with modal depth 20 | 21 | -- NOTE: Haskell does not support kind synonyms 22 | -- type Cx = Ty -> Nat -> * 23 | 24 | type IsTrue (a :: Ty) (d :: Nat) (tc :: Ty -> Nat -> *) = tc a d 25 | 26 | 27 | -- Terms 28 | 29 | infixl 1 .$ 30 | class ArrMpTm (tr :: Nat -> (Ty -> Nat -> *) -> Ty -> *) where 31 | var :: IsTrue a d tc -> tr d tc a 32 | lam' :: (IsTrue a d tc -> tr d tc b) -> tr d tc (a :=> b) 33 | (.$) :: tr d tc (a :=> b) -> tr d tc a -> tr d tc b 34 | 35 | lam :: ArrMpTm tr => (tr d tc a -> tr d tc b) -> tr d tc (a :=> b) 36 | lam f = lam' $ \x -> f (var x) 37 | 38 | class ArrMpTm tr => BoxMpTm (tr :: Nat -> (Ty -> Nat -> *) -> Ty -> *) where 39 | box :: tr (Suc d) tc a -> tr d tc (BOX a) 40 | unbox' :: tr d tc (BOX a) -> (IsTrue a gd tc -> tr d tc b) -> tr d tc b 41 | 42 | unbox :: BoxMpTm tr => tr d tc (BOX a) -> (tr gd tc a -> tr d tc b) -> tr d tc b 43 | unbox x' f = unbox' x' $ \x -> f (var x) 44 | 45 | type Thm a = BoxMpTm tr => tr d tc a 46 | 47 | 48 | -- Example theorems 49 | 50 | rNec :: Thm a -> Thm (BOX a) 51 | rNec x = 52 | box x 53 | 54 | aK :: Thm (BOX (a :=> b) :=> BOX a :=> BOX b) 55 | aK = 56 | lam $ \f' -> 57 | lam $ \x' -> 58 | unbox f' $ \f -> 59 | unbox x' $ \x -> box (f .$ x) 60 | 61 | aT :: Thm (BOX a :=> a) 62 | aT = 63 | lam $ \x' -> 64 | unbox x' $ \x -> x 65 | 66 | a4 :: Thm (BOX a :=> BOX (BOX a)) 67 | a4 = 68 | lam $ \x' -> 69 | unbox x' $ \x -> box (box x) 70 | 71 | t1 :: Thm (a :=> BOX (a :=> a)) 72 | t1 = 73 | lam $ \_ -> box (lam $ \y -> y) 74 | -------------------------------------------------------------------------------- /src/Pf/BoxMp.idr: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, PHOAS approach, final encoding 2 | 3 | module Pf.BoxMp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 :=> 11 | data Ty : Type where 12 | UNIT : Ty 13 | (:=>) : Ty -> Ty -> Ty 14 | BOX : Ty -> Ty 15 | 16 | 17 | -- Context and truth judgement with modal depth 18 | 19 | Cx : Type 20 | Cx = Nat -> Ty -> Type 21 | 22 | isTrue : Ty -> Nat -> Cx -> Type 23 | isTrue a d tc = tc d a 24 | 25 | 26 | -- Terms 27 | 28 | TmRepr : Type 29 | TmRepr = Nat -> Cx -> Ty -> Type 30 | 31 | infixl 1 :$ 32 | class ArrMpTm (tr : TmRepr) where 33 | var : isTrue a d tc -> tr d tc a 34 | lam' : (isTrue a d tc -> tr d tc b) -> tr d tc (a :=> b) 35 | (:$) : tr d tc (a :=> b) -> tr d tc a -> tr d tc b 36 | 37 | lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr d tc a -> tr d tc b) -> tr d tc (a :=> b) 38 | lam'' f = lam' $ \x => f (var x) 39 | 40 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 41 | 42 | class ArrMpTm tr => BoxMpTm (tr : TmRepr) where 43 | box : tr (succ d) tc a -> tr d tc (BOX a) 44 | unbox' : tr d tc (BOX a) -> (isTrue a gd tc -> tr d tc b) -> tr d tc b 45 | 46 | unbox'' : {tr : TmRepr} -> BoxMpTm tr => tr d tc (BOX a) -> (tr gd tc a -> tr d tc b) -> tr d tc b 47 | unbox'' x' f = unbox' x' $ \x => f (var x) 48 | 49 | syntax "unbox" [a'] as {a} ":=>" [b] = unbox'' a' (\a => b) 50 | 51 | Thm : Ty -> Type 52 | Thm a = {tr : TmRepr} -> {d : Nat} -> {tc : Cx} -> BoxMpTm tr => tr d tc a 53 | 54 | 55 | -- Example theorems 56 | 57 | rNec : Thm a -> Thm (BOX a) 58 | rNec x = 59 | box x 60 | 61 | aK : Thm (BOX (a :=> b) :=> BOX a :=> BOX b) 62 | aK = 63 | lam f' :=> 64 | lam x' :=> 65 | unbox f' as f :=> 66 | unbox x' as x :=> box (f :$ x) 67 | 68 | aT : Thm (BOX a :=> a) 69 | aT = 70 | lam x' :=> 71 | unbox x' as x :=> x 72 | 73 | a4 : Thm (BOX a :=> BOX (BOX a)) 74 | a4 = 75 | lam x' :=> 76 | unbox x' as x :=> box (box x) 77 | 78 | t1 : Thm (a :=> BOX (a :=> a)) 79 | t1 = 80 | lam x :=> box (lam y :=> y) 81 | -------------------------------------------------------------------------------- /src/Pf/Cp.agda: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, PHOAS approach, final encoding 2 | 3 | module Pf.Cp where 4 | 5 | 6 | -- Types 7 | 8 | infixl 2 _&&_ 9 | infixl 1 _||_ 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | _&&_ : Ty -> Ty -> Ty 15 | _||_ : Ty -> Ty -> Ty 16 | FALSE : Ty 17 | 18 | infixr 0 _<=>_ 19 | _<=>_ : Ty -> Ty -> Ty 20 | a <=> b = (a => b) && (b => a) 21 | 22 | NOT : Ty -> Ty 23 | NOT a = a => FALSE 24 | 25 | TRUE : Ty 26 | TRUE = FALSE => FALSE 27 | 28 | 29 | -- Context and truth judgement 30 | 31 | Cx : Set1 32 | Cx = Ty -> Set 33 | 34 | isTrue : Ty -> Cx -> Set 35 | isTrue a tc = tc a 36 | 37 | 38 | -- Terms 39 | 40 | TmRepr : Set1 41 | TmRepr = Cx -> Ty -> Set 42 | 43 | module ArrMp where 44 | record Tm (tr : TmRepr) : Set1 where 45 | infixl 1 _$_ 46 | field 47 | var : forall {tc a} -> isTrue a tc -> tr tc a 48 | lam' : forall {tc a b} -> (isTrue a tc -> tr tc b) -> tr tc (a => b) 49 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 50 | 51 | lam'' : forall {tc a b} -> (tr tc a -> tr tc b) -> tr tc (a => b) 52 | lam'' f = lam' \x -> f (var x) 53 | 54 | syntax lam'' (\a -> b) = lam a => b 55 | open Tm {{...}} public 56 | 57 | module Mp where 58 | record Tm (tr : TmRepr) : Set1 where 59 | field 60 | pair' : forall {tc a b} -> tr tc a -> tr tc b -> tr tc (a && b) 61 | fst : forall {tc a b} -> tr tc (a && b) -> tr tc a 62 | snd : forall {tc a b} -> tr tc (a && b) -> tr tc b 63 | left : forall {tc a b} -> tr tc a -> tr tc (a || b) 64 | right : forall {tc a b} -> tr tc b -> tr tc (a || b) 65 | case' : forall {tc a b c} -> tr tc (a || b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c 66 | 67 | isArrMp : ArrMp.Tm tr 68 | open ArrMp.Tm isArrMp public 69 | 70 | case'' : forall {tc a b c} -> tr tc (a || b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 71 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 72 | 73 | syntax pair' x y = [ x , y ] 74 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 75 | open Tm {{...}} public 76 | 77 | module Cp where 78 | record Tm (tr : TmRepr) : Set1 where 79 | field 80 | abort' : forall {tc a} -> (isTrue (NOT a) tc -> tr tc FALSE) -> tr tc a 81 | 82 | isMp : Mp.Tm tr 83 | open Mp.Tm isMp public 84 | 85 | abort'' : forall {tc a} -> (tr tc (NOT a) -> tr tc FALSE) -> tr tc a 86 | abort'' f = abort' \na -> f (var na) 87 | 88 | syntax abort'' (\x -> y) = abort x => y 89 | open Tm {{...}} public 90 | 91 | Thm : Ty -> Set1 92 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 93 | open Cp public 94 | -------------------------------------------------------------------------------- /src/Pf/Cp.hs: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, PHOAS approach, final encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pf.Cp where 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | (:&&) :: Ty -> Ty -> Ty 17 | (:||) :: Ty -> Ty -> Ty 18 | FALSE :: Ty 19 | 20 | infixr 0 :<=> 21 | type a :<=> b = (a :=> b) :&& (b :=> a) 22 | 23 | type NOT a = a :=> FALSE 24 | 25 | type TRUE = FALSE :=> FALSE 26 | 27 | 28 | -- Context and truth judgement 29 | 30 | -- NOTE: Haskell does not support kind synonyms 31 | -- type Cx = Ty -> * 32 | 33 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 34 | 35 | 36 | -- Terms 37 | 38 | infixl 1 .$ 39 | class ArrMpTm (tr :: (Ty -> *) -> Ty -> *) where 40 | var :: IsTrue a tc -> tr tc a 41 | lam' :: (IsTrue a tc -> tr tc b) -> tr tc (a :=> b) 42 | (.$) :: tr tc (a :=> b) -> tr tc a -> tr tc b 43 | 44 | lam :: ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 45 | lam f = lam' $ \x -> f (var x) 46 | 47 | class ArrMpTm tr => MpTm (tr :: (Ty -> *) -> Ty -> *) where 48 | pair' :: tr tc a -> tr tc b -> tr tc (a :&& b) 49 | fst' :: tr tc (a :&& b) -> tr tc a 50 | snd' :: tr tc (a :&& b) -> tr tc b 51 | left :: tr tc a -> tr tc (a :|| b) 52 | right :: tr tc b -> tr tc (a :|| b) 53 | case'' :: tr tc (a :|| b) -> (IsTrue a tc -> tr tc c) -> (IsTrue b tc -> tr tc c) -> tr tc c 54 | 55 | pair :: MpTm tr => (tr tc a, tr tc b) -> tr tc (a :&& b) 56 | pair (a, b) = pair' a b 57 | 58 | case' :: MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 59 | case' xy f g = case'' xy (\x -> f (var x)) (\y -> g (var y)) 60 | 61 | class MpTm tr => CpTm (tr :: (Ty -> *) -> Ty -> *) where 62 | abort' :: (IsTrue (NOT a) tc -> tr tc FALSE) -> tr tc a 63 | 64 | abort :: CpTm tr => (tr tc (NOT a) -> tr tc FALSE) -> tr tc a 65 | abort f = abort' $ \na -> f (var na) 66 | 67 | type Thm a = CpTm tr => tr tc a 68 | -------------------------------------------------------------------------------- /src/Pf/Cp.idr: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, PHOAS approach, final encoding 2 | 3 | module Pf.Cp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty : Type where 14 | UNIT : Ty 15 | (:=>) : Ty -> Ty -> Ty 16 | (:&&) : Ty -> Ty -> Ty 17 | (:||) : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 :<=> 21 | (:<=>) : Ty -> Ty -> Ty 22 | (:<=>) a b = (a :=> b) :&& (b :=> a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a :=> FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE :=> FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Type 34 | Cx = Ty -> Type 35 | 36 | isTrue : Ty -> Cx -> Type 37 | isTrue a tc = tc a 38 | 39 | 40 | -- Terms 41 | 42 | TmRepr : Type 43 | TmRepr = Cx -> Ty -> Type 44 | 45 | infixl 1 :$ 46 | class ArrMpTm (tr : TmRepr) where 47 | var : isTrue a tc -> tr tc a 48 | lam' : (isTrue a tc -> tr tc b) -> tr tc (a :=> b) 49 | (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b 50 | 51 | lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 52 | lam'' f = lam' $ \x => f (var x) 53 | 54 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 55 | 56 | class ArrMpTm tr => MpTm (tr : TmRepr) where 57 | pair : tr tc a -> tr tc b -> tr tc (a :&& b) 58 | fst : tr tc (a :&& b) -> tr tc a 59 | snd : tr tc (a :&& b) -> tr tc b 60 | left : tr tc a -> tr tc (a :|| b) 61 | right : tr tc b -> tr tc (a :|| b) 62 | case' : tr tc (a :|| b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c 63 | 64 | case'' : {tr : TmRepr} -> MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 65 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 66 | 67 | syntax "[" [a] "," [b] "]" = pair a b 68 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 69 | 70 | class MpTm tr => CpTm (tr : TmRepr) where 71 | abort' : (isTrue (NOT a) tc -> tr tc FALSE) -> tr tc a 72 | 73 | abort'' : {tr : TmRepr} -> CpTm tr => (tr tc (NOT a) -> tr tc FALSE) -> tr tc a 74 | abort'' f = abort' $ \na => f (var na) 75 | 76 | syntax "abort" {a} ":=>" [b] = abort'' (\a => b) 77 | 78 | Thm : Ty -> Type 79 | Thm a = {tr : TmRepr} -> {tc : Cx} -> CpTm tr => tr tc a 80 | -------------------------------------------------------------------------------- /src/Pf/Ip.agda: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, PHOAS approach, final encoding 2 | 3 | module Pf.Ip where 4 | 5 | 6 | -- Types 7 | 8 | infixl 2 _&&_ 9 | infixl 1 _||_ 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | _&&_ : Ty -> Ty -> Ty 15 | _||_ : Ty -> Ty -> Ty 16 | FALSE : Ty 17 | 18 | infixr 0 _<=>_ 19 | _<=>_ : Ty -> Ty -> Ty 20 | a <=> b = (a => b) && (b => a) 21 | 22 | NOT : Ty -> Ty 23 | NOT a = a => FALSE 24 | 25 | TRUE : Ty 26 | TRUE = FALSE => FALSE 27 | 28 | 29 | -- Context and truth judgement 30 | 31 | Cx : Set1 32 | Cx = Ty -> Set 33 | 34 | isTrue : Ty -> Cx -> Set 35 | isTrue a tc = tc a 36 | 37 | 38 | -- Terms 39 | 40 | TmRepr : Set1 41 | TmRepr = Cx -> Ty -> Set 42 | 43 | module ArrMp where 44 | record Tm (tr : TmRepr) : Set1 where 45 | infixl 1 _$_ 46 | field 47 | var : forall {tc a} -> isTrue a tc -> tr tc a 48 | lam' : forall {tc a b} -> (isTrue a tc -> tr tc b) -> tr tc (a => b) 49 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 50 | 51 | lam'' : forall {tc a b} -> (tr tc a -> tr tc b) -> tr tc (a => b) 52 | lam'' f = lam' \x -> f (var x) 53 | 54 | syntax lam'' (\a -> b) = lam a => b 55 | open Tm {{...}} public 56 | 57 | module Mp where 58 | record Tm (tr : TmRepr) : Set1 where 59 | field 60 | pair' : forall {tc a b} -> tr tc a -> tr tc b -> tr tc (a && b) 61 | fst : forall {tc a b} -> tr tc (a && b) -> tr tc a 62 | snd : forall {tc a b} -> tr tc (a && b) -> tr tc b 63 | left : forall {tc a b} -> tr tc a -> tr tc (a || b) 64 | right : forall {tc a b} -> tr tc b -> tr tc (a || b) 65 | case' : forall {tc a b c} -> tr tc (a || b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c 66 | 67 | isArrMp : ArrMp.Tm tr 68 | open ArrMp.Tm isArrMp public 69 | 70 | case'' : forall {tc a b c} -> tr tc (a || b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 71 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 72 | 73 | syntax pair' x y = [ x , y ] 74 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 75 | open Tm {{...}} public 76 | 77 | module Ip where 78 | record Tm (tr : TmRepr) : Set1 where 79 | field 80 | abort : forall {tc a} -> tr tc FALSE -> tr tc a 81 | 82 | isMp : Mp.Tm tr 83 | open Mp.Tm isMp public 84 | open Tm {{...}} public 85 | 86 | Thm : Ty -> Set1 87 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 88 | open Ip public 89 | 90 | 91 | -- Example theorems 92 | 93 | t1 : forall {a b} -> Thm (a => NOT a => b) 94 | t1 = 95 | lam x => 96 | lam f => abort (f $ x) 97 | 98 | t2 : forall {a b} -> Thm (NOT a => a => b) 99 | t2 = 100 | lam f => 101 | lam x => abort (f $ x) 102 | 103 | t3 : forall {a} -> Thm (a => NOT (NOT a)) 104 | t3 = 105 | lam x => 106 | lam f => f $ x 107 | 108 | t4 : forall {a} -> Thm (NOT a <=> NOT (NOT (NOT a))) 109 | t4 = 110 | [ lam f => 111 | lam g => g $ f 112 | , lam g => 113 | lam x => g $ (lam f => f $ x) 114 | ] 115 | -------------------------------------------------------------------------------- /src/Pf/Ip.hs: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, PHOAS approach, final encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pf.Ip where 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | (:&&) :: Ty -> Ty -> Ty 17 | (:||) :: Ty -> Ty -> Ty 18 | FALSE :: Ty 19 | 20 | infixr 0 :<=> 21 | type a :<=> b = (a :=> b) :&& (b :=> a) 22 | 23 | type NOT a = a :=> FALSE 24 | 25 | type TRUE = FALSE :=> FALSE 26 | 27 | 28 | -- Context and truth judgement 29 | 30 | -- NOTE: Haskell does not support kind synonyms 31 | -- type Cx = Ty -> * 32 | 33 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 34 | 35 | 36 | -- Terms 37 | 38 | infixl 1 .$ 39 | class ArrMpTm (tr :: (Ty -> *) -> Ty -> *) where 40 | var :: IsTrue a tc -> tr tc a 41 | lam' :: (IsTrue a tc -> tr tc b) -> tr tc (a :=> b) 42 | (.$) :: tr tc (a :=> b) -> tr tc a -> tr tc b 43 | 44 | lam :: ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 45 | lam f = lam' $ \x -> f (var x) 46 | 47 | class ArrMpTm tr => MpTm (tr :: (Ty -> *) -> Ty -> *) where 48 | pair' :: tr tc a -> tr tc b -> tr tc (a :&& b) 49 | fst' :: tr tc (a :&& b) -> tr tc a 50 | snd' :: tr tc (a :&& b) -> tr tc b 51 | left :: tr tc a -> tr tc (a :|| b) 52 | right :: tr tc b -> tr tc (a :|| b) 53 | case'' :: tr tc (a :|| b) -> (IsTrue a tc -> tr tc c) -> (IsTrue b tc -> tr tc c) -> tr tc c 54 | 55 | pair :: MpTm tr => (tr tc a, tr tc b) -> tr tc (a :&& b) 56 | pair (a, b) = pair' a b 57 | 58 | case' :: MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 59 | case' xy f g = case'' xy (\x -> f (var x)) (\y -> g (var y)) 60 | 61 | class MpTm tr => IpTm (tr :: (Ty -> *) -> Ty -> *) where 62 | abort :: tr tc FALSE -> tr tc a 63 | 64 | type Thm a = IpTm tr => tr tc a 65 | 66 | 67 | -- Example theorems 68 | 69 | t1 :: Thm (a :=> NOT a :=> b) 70 | t1 = 71 | lam $ \x -> 72 | lam $ \f -> abort (f .$ x) 73 | 74 | t2 :: Thm (NOT a :=> a :=> b) 75 | t2 = 76 | lam $ \f -> 77 | lam $ \x -> abort (f .$ x) 78 | 79 | t3 :: Thm (a :=> NOT (NOT a)) 80 | t3 = 81 | lam $ \x -> 82 | lam $ \f -> f .$ x 83 | 84 | t4 :: Thm (NOT a :<=> NOT (NOT (NOT a))) 85 | t4 = 86 | pair 87 | ( lam $ \f -> 88 | lam $ \g -> g .$ f 89 | , lam $ \g -> 90 | lam $ \x -> g .$ (lam $ \f -> f .$ x) 91 | ) 92 | -------------------------------------------------------------------------------- /src/Pf/Ip.idr: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, PHOAS approach, final encoding 2 | 3 | module Pf.Ip 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty : Type where 14 | UNIT : Ty 15 | (:=>) : Ty -> Ty -> Ty 16 | (:&&) : Ty -> Ty -> Ty 17 | (:||) : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 :<=> 21 | (:<=>) : Ty -> Ty -> Ty 22 | (:<=>) a b = (a :=> b) :&& (b :=> a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a :=> FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE :=> FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Type 34 | Cx = Ty -> Type 35 | 36 | isTrue : Ty -> Cx -> Type 37 | isTrue a tc = tc a 38 | 39 | 40 | -- Terms 41 | 42 | TmRepr : Type 43 | TmRepr = Cx -> Ty -> Type 44 | 45 | infixl 1 :$ 46 | class ArrMpTm (tr : TmRepr) where 47 | var : isTrue a tc -> tr tc a 48 | lam' : (isTrue a tc -> tr tc b) -> tr tc (a :=> b) 49 | (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b 50 | 51 | lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 52 | lam'' f = lam' $ \x => f (var x) 53 | 54 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 55 | 56 | class ArrMpTm tr => MpTm (tr : TmRepr) where 57 | pair : tr tc a -> tr tc b -> tr tc (a :&& b) 58 | fst : tr tc (a :&& b) -> tr tc a 59 | snd : tr tc (a :&& b) -> tr tc b 60 | left : tr tc a -> tr tc (a :|| b) 61 | right : tr tc b -> tr tc (a :|| b) 62 | case' : tr tc (a :|| b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c 63 | 64 | case'' : {tr : TmRepr} -> MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 65 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 66 | 67 | syntax "[" [a] "," [b] "]" = pair a b 68 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 69 | 70 | class MpTm tr => IpTm (tr : TmRepr) where 71 | abort : tr tc FALSE -> tr tc a 72 | 73 | Thm : Ty -> Type 74 | Thm a = {tr : TmRepr} -> {tc : Cx} -> IpTm tr => tr tc a 75 | 76 | 77 | -- Example theorems 78 | 79 | t1 : Thm (a :=> NOT a :=> b) 80 | t1 = 81 | lam x :=> 82 | lam f :=> abort (f :$ x) 83 | 84 | t2 : Thm (NOT a :=> a :=> b) 85 | t2 = 86 | lam f :=> 87 | lam x :=> abort (f :$ x) 88 | 89 | t3 : Thm (a :=> NOT (NOT a)) 90 | t3 = 91 | lam x :=> 92 | lam f :=> f :$ x 93 | 94 | t4 : Thm (NOT a :<=> NOT (NOT (NOT a))) 95 | t4 = 96 | [ lam f :=> 97 | lam g :=> g :$ f 98 | , lam g :=> 99 | lam x :=> g :$ (lam f :=> f :$ x) 100 | ] 101 | -------------------------------------------------------------------------------- /src/Pf/Mp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, PHOAS approach, final encoding 2 | 3 | module Pf.Mp where 4 | 5 | 6 | -- Types 7 | 8 | infixl 2 _&&_ 9 | infixl 1 _||_ 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | _&&_ : Ty -> Ty -> Ty 15 | _||_ : Ty -> Ty -> Ty 16 | FALSE : Ty 17 | 18 | infixr 0 _<=>_ 19 | _<=>_ : Ty -> Ty -> Ty 20 | a <=> b = (a => b) && (b => a) 21 | 22 | NOT : Ty -> Ty 23 | NOT a = a => FALSE 24 | 25 | TRUE : Ty 26 | TRUE = FALSE => FALSE 27 | 28 | 29 | -- Context and truth judgement 30 | 31 | Cx : Set1 32 | Cx = Ty -> Set 33 | 34 | isTrue : Ty -> Cx -> Set 35 | isTrue a tc = tc a 36 | 37 | 38 | -- Terms 39 | 40 | TmRepr : Set1 41 | TmRepr = Cx -> Ty -> Set 42 | 43 | module ArrMp where 44 | record Tm (tr : TmRepr) : Set1 where 45 | infixl 1 _$_ 46 | field 47 | var : forall {tc a} -> isTrue a tc -> tr tc a 48 | lam' : forall {tc a b} -> (isTrue a tc -> tr tc b) -> tr tc (a => b) 49 | _$_ : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b 50 | 51 | lam'' : forall {tc a b} -> (tr tc a -> tr tc b) -> tr tc (a => b) 52 | lam'' f = lam' \x -> f (var x) 53 | 54 | syntax lam'' (\a -> b) = lam a => b 55 | open Tm {{...}} public 56 | 57 | module Mp where 58 | record Tm (tr : TmRepr) : Set1 where 59 | field 60 | pair' : forall {tc a b} -> tr tc a -> tr tc b -> tr tc (a && b) 61 | fst : forall {tc a b} -> tr tc (a && b) -> tr tc a 62 | snd : forall {tc a b} -> tr tc (a && b) -> tr tc b 63 | left : forall {tc a b} -> tr tc a -> tr tc (a || b) 64 | right : forall {tc a b} -> tr tc b -> tr tc (a || b) 65 | case' : forall {tc a b c} -> tr tc (a || b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c 66 | 67 | isArrMp : ArrMp.Tm tr 68 | open ArrMp.Tm isArrMp public 69 | 70 | case'' : forall {tc a b c} -> tr tc (a || b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 71 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 72 | 73 | syntax pair' x y = [ x , y ] 74 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 75 | open Tm {{...}} public 76 | 77 | Thm : Ty -> Set1 78 | Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a 79 | open Mp public 80 | 81 | 82 | -- Example theorems 83 | 84 | c1 : forall {a b} -> Thm (a && b <=> b && a) 85 | c1 = 86 | [ lam xy => [ snd xy , fst xy ] 87 | , lam yx => [ snd yx , fst yx ] 88 | ] 89 | 90 | c2 : forall {a b} -> Thm (a || b <=> b || a) 91 | c2 = 92 | [ lam xy => 93 | case xy 94 | of x => right x 95 | or y => left y 96 | , lam yx => 97 | case yx 98 | of y => right y 99 | or x => left x 100 | ] 101 | 102 | i1 : forall {a} -> Thm (a && a <=> a) 103 | i1 = 104 | [ lam xx => fst xx 105 | , lam x => [ x , x ] 106 | ] 107 | 108 | i2 : forall {a} -> Thm (a || a <=> a) 109 | i2 = 110 | [ lam xx => 111 | case xx 112 | of x => x 113 | or x => x 114 | , lam x => left x 115 | ] 116 | 117 | l3 : forall {a} -> Thm ((a => a) <=> TRUE) 118 | l3 = 119 | [ lam _ => lam nt => nt 120 | , lam _ => lam x => x 121 | ] 122 | 123 | l1 : forall {a b c} -> Thm (a && (b && c) <=> (a && b) && c) 124 | l1 = 125 | [ lam xyz => 126 | (let yz = snd xyz in 127 | [ [ fst xyz , fst yz ] , snd yz ]) 128 | , lam xyz => 129 | (let xy = fst xyz in 130 | [ fst xy , [ snd xy , snd xyz ] ]) 131 | ] 132 | 133 | l2 : forall {a} -> Thm (a && TRUE <=> a) 134 | l2 = 135 | [ lam xt => fst xt 136 | , lam x => [ x , lam nt => nt ] 137 | ] 138 | 139 | l4 : forall {a b c} -> Thm (a && (b || c) <=> (a && b) || (a && c)) 140 | l4 = 141 | [ lam xyz => 142 | (let x = fst xyz in 143 | case snd xyz 144 | of y => left [ x , y ] 145 | or z => right [ x , z ]) 146 | , lam xyxz => 147 | case xyxz 148 | of xy => [ fst xy , left (snd xy) ] 149 | or xz => [ fst xz , right (snd xz) ] 150 | ] 151 | 152 | l6 : forall {a b c} -> Thm (a || (b && c) <=> (a || b) && (a || c)) 153 | l6 = 154 | [ lam xyz => 155 | case xyz 156 | of x => [ left x , left x ] 157 | or yz => [ right (fst yz) , right (snd yz) ] 158 | , lam xyxz => 159 | case fst xyxz 160 | of x => left x 161 | or y => 162 | case snd xyxz 163 | of x => left x 164 | or z => right [ y , z ] 165 | ] 166 | 167 | l7 : forall {a} -> Thm (a || TRUE <=> TRUE) 168 | l7 = 169 | [ lam _ => lam nt => nt 170 | , lam t => right t 171 | ] 172 | 173 | l9 : forall {a b c} -> Thm (a || (b || c) <=> (a || b) || c) 174 | l9 = 175 | [ lam xyz => 176 | case xyz 177 | of x => left (left x) 178 | or yz => 179 | case yz 180 | of y => left (right y) 181 | or z => right z 182 | , lam xyz => 183 | case xyz 184 | of xy => 185 | case xy 186 | of x => left x 187 | or y => right (left y) 188 | or z => right (right z) 189 | ] 190 | 191 | l11 : forall {a b c} -> Thm ((a => (b && c)) <=> (a => b) && (a => c)) 192 | l11 = 193 | [ lam xyz => 194 | [ lam x => fst (xyz $ x) 195 | , lam x => snd (xyz $ x) 196 | ] 197 | , lam xyxz => 198 | lam x => [ fst xyxz $ x , snd xyxz $ x ] 199 | ] 200 | 201 | l12 : forall {a} -> Thm ((a => TRUE) <=> TRUE) 202 | l12 = 203 | [ lam _ => lam nt => nt 204 | , lam t => lam _ => t 205 | ] 206 | 207 | l13 : forall {a b c} -> Thm ((a => (b => c)) <=> ((a && b) => c)) 208 | l13 = 209 | [ lam xyz => 210 | lam xy => xyz $ fst xy $ snd xy 211 | , lam xyz => 212 | lam x => 213 | lam y => xyz $ [ x , y ] 214 | ] 215 | 216 | l16 : forall {a b c} -> Thm (((a && b) => c) <=> (a => (b => c))) 217 | l16 = 218 | [ lam xyz => 219 | lam x => 220 | lam y => xyz $ [ x , y ] 221 | , lam xyz => 222 | lam xy => xyz $ fst xy $ snd xy 223 | ] 224 | 225 | l17 : forall {a} -> Thm ((TRUE => a) <=> a) 226 | l17 = 227 | [ lam tx => tx $ (lam nt => nt) 228 | , lam x => lam _ => x 229 | ] 230 | 231 | l19 : forall {a b c} -> Thm (((a || b) => c) <=> (a => c) && (b => c)) 232 | l19 = 233 | [ lam xyz => 234 | [ lam x => xyz $ left x 235 | , lam y => xyz $ right y 236 | ] 237 | , lam xzyz => 238 | lam xy => 239 | case xy 240 | of x => fst xzyz $ x 241 | or y => snd xzyz $ y 242 | ] 243 | -------------------------------------------------------------------------------- /src/Pf/Mp.hs: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, PHOAS approach, final encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pf.Mp where 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | (:&&) :: Ty -> Ty -> Ty 17 | (:||) :: Ty -> Ty -> Ty 18 | FALSE :: Ty 19 | 20 | infixr 0 :<=> 21 | type a :<=> b = (a :=> b) :&& (b :=> a) 22 | 23 | type NOT a = a :=> FALSE 24 | 25 | type TRUE = FALSE :=> FALSE 26 | 27 | 28 | -- Context and truth judgement 29 | 30 | -- NOTE: Haskell does not support kind synonyms 31 | -- type Cx = Ty -> * 32 | 33 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 34 | 35 | 36 | -- Terms 37 | 38 | infixl 1 .$ 39 | class ArrMpTm (tr :: (Ty -> *) -> Ty -> *) where 40 | var :: IsTrue a tc -> tr tc a 41 | lam' :: (IsTrue a tc -> tr tc b) -> tr tc (a :=> b) 42 | (.$) :: tr tc (a :=> b) -> tr tc a -> tr tc b 43 | 44 | lam :: ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 45 | lam f = lam' $ \x -> f (var x) 46 | 47 | class ArrMpTm tr => MpTm (tr :: (Ty -> *) -> Ty -> *) where 48 | pair' :: tr tc a -> tr tc b -> tr tc (a :&& b) 49 | fst' :: tr tc (a :&& b) -> tr tc a 50 | snd' :: tr tc (a :&& b) -> tr tc b 51 | left :: tr tc a -> tr tc (a :|| b) 52 | right :: tr tc b -> tr tc (a :|| b) 53 | case'' :: tr tc (a :|| b) -> (IsTrue a tc -> tr tc c) -> (IsTrue b tc -> tr tc c) -> tr tc c 54 | 55 | pair :: MpTm tr => (tr tc a, tr tc b) -> tr tc (a :&& b) 56 | pair (a, b) = pair' a b 57 | 58 | case' :: MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 59 | case' xy f g = case'' xy (\x -> f (var x)) (\y -> g (var y)) 60 | 61 | type Thm a = MpTm tr => tr tc a 62 | 63 | 64 | -- Example theorems 65 | 66 | c1 :: Thm (a :&& b :<=> b :&& a) 67 | c1 = 68 | pair 69 | ( lam $ \xy -> pair ( snd' xy , fst' xy ) 70 | , lam $ \yx -> pair ( snd' yx , fst' yx ) 71 | ) 72 | 73 | c2 :: Thm (a :|| b :<=> b :|| a) 74 | c2 = 75 | pair 76 | ( lam $ \xy -> 77 | case' xy 78 | (\x -> right x) 79 | (\y -> left y) 80 | , lam $ \yx -> 81 | case' yx 82 | (\y -> right y) 83 | (\x -> left x) 84 | ) 85 | 86 | i1 :: Thm (a :&& a :<=> a) 87 | i1 = 88 | pair 89 | ( lam $ \xx -> fst' xx 90 | , lam $ \x -> pair ( x , x ) 91 | ) 92 | 93 | i2 :: Thm (a :|| a :<=> a) 94 | i2 = 95 | pair 96 | ( lam $ \xx -> 97 | case' xx 98 | (\x -> x) 99 | (\x -> x) 100 | , lam $ \x -> left x 101 | ) 102 | 103 | l3 :: Thm ((a :=> a) :<=> TRUE) 104 | l3 = 105 | pair 106 | ( lam $ \_ -> lam $ \nt -> nt 107 | , lam $ \_ -> lam $ \x -> x 108 | ) 109 | 110 | l1 :: Thm (a :&& (b :&& c) :<=> (a :&& b) :&& c) 111 | l1 = 112 | pair 113 | ( lam $ \xyz -> 114 | let yz = snd' xyz in 115 | pair 116 | ( pair ( fst' xyz , fst' yz ) 117 | , snd' yz 118 | ) 119 | , lam $ \xyz -> 120 | let xy = fst' xyz in 121 | pair 122 | ( fst' xy 123 | , pair ( snd' xy , snd' xyz ) 124 | )) 125 | 126 | l2 :: Thm (a :&& TRUE :<=> a) 127 | l2 = 128 | pair 129 | ( lam $ \xt -> fst' xt 130 | , lam $ \x -> pair ( x , lam $ \nt -> nt ) 131 | ) 132 | 133 | l4 :: Thm (a :&& (b :|| c) :<=> (a :&& b) :|| (a :&& c)) 134 | l4 = 135 | pair 136 | ( lam $ \xyz -> 137 | let x = fst' xyz in 138 | case' (snd' xyz) 139 | (\y -> left (pair ( x , y ))) 140 | (\z -> right (pair ( x , z ))) 141 | , lam $ \xyxz -> 142 | case' xyxz 143 | (\xy -> pair ( fst' xy , left (snd' xy) )) 144 | (\xz -> pair ( fst' xz , right (snd' xz) )) 145 | ) 146 | 147 | l6 :: Thm (a :|| (b :&& c) :<=> (a :|| b) :&& (a :|| c)) 148 | l6 = 149 | pair 150 | ( lam $ \xyz -> 151 | case' xyz 152 | (\x -> pair ( left x , left x )) 153 | (\yz -> pair ( right (fst' yz) , right (snd' yz) )) 154 | , lam $ \xyxz -> 155 | case' (fst' xyxz) 156 | (\x -> left x) 157 | (\y -> 158 | case' (snd' xyxz) 159 | (\x -> left x) 160 | (\z -> right (pair ( y , z )))) 161 | ) 162 | 163 | l7 :: Thm (a :|| TRUE :<=> TRUE) 164 | l7 = 165 | pair 166 | ( lam $ \_ -> lam $ \nt -> nt 167 | , lam $ \t -> right t 168 | ) 169 | 170 | l9 :: Thm (a :|| (b :|| c) :<=> (a :|| b) :|| c) 171 | l9 = 172 | pair 173 | ( lam $ \xyz -> 174 | case' xyz 175 | (\x -> left (left x)) 176 | (\yz -> 177 | case' yz 178 | (\y -> left (right y)) 179 | (\z -> right z)) 180 | , lam $ \xyz -> 181 | case' xyz 182 | (\xy -> 183 | case' xy 184 | (\x -> left x) 185 | (\y -> right (left y))) 186 | (\z -> right (right z)) 187 | ) 188 | 189 | l11 :: Thm ((a :=> (b :&& c)) :<=> (a :=> b) :&& (a :=> c)) 190 | l11 = 191 | pair 192 | ( lam $ \xyz -> 193 | pair 194 | ( lam $ \x -> fst' (xyz .$ x) 195 | , lam $ \x -> snd' (xyz .$ x) 196 | ) 197 | , lam $ \xyxz -> 198 | lam $ \x -> pair ( fst' xyxz .$ x , snd' xyxz .$ x ) 199 | ) 200 | 201 | l12 :: Thm ((a :=> TRUE) :<=> TRUE) 202 | l12 = 203 | pair 204 | ( lam $ \_ -> lam $ \nt -> nt 205 | , lam $ \t -> lam $ \_ -> t 206 | ) 207 | 208 | l13 :: Thm ((a :=> (b :=> c)) :<=> ((a :&& b) :=> c)) 209 | l13 = 210 | pair 211 | ( lam $ \xyz -> 212 | lam $ \xy -> xyz .$ fst' xy .$ snd' xy 213 | , lam $ \xyz -> 214 | lam $ \x -> 215 | lam $ \y -> xyz .$ pair ( x , y ) 216 | ) 217 | 218 | l16 :: Thm (((a :&& b) :=> c) :<=> (a :=> (b :=> c))) 219 | l16 = 220 | pair 221 | ( lam $ \xyz -> 222 | lam $ \x -> 223 | lam $ \y -> xyz .$ pair ( x , y ) 224 | , lam $ \xyz -> 225 | lam $ \xy -> xyz .$ fst' xy .$ snd' xy 226 | ) 227 | 228 | l17 :: Thm ((TRUE :=> a) :<=> a) 229 | l17 = 230 | pair 231 | ( lam $ \tx -> tx .$ (lam $ \nt -> nt) 232 | , lam $ \x -> lam $ \_ -> x 233 | ) 234 | 235 | l19 :: Thm (((a :|| b) :=> c) :<=> (a :=> c) :&& (b :=> c)) 236 | l19 = 237 | pair 238 | ( lam $ \xyz -> 239 | pair 240 | ( lam $ \x -> xyz .$ left x 241 | , lam $ \y -> xyz .$ right y 242 | ) 243 | , lam $ \xzyz -> 244 | lam $ \xy -> 245 | case' xy 246 | (\x -> fst' xzyz .$ x) 247 | (\y -> snd' xzyz .$ y) 248 | ) 249 | -------------------------------------------------------------------------------- /src/Pf/Mp.idr: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, PHOAS approach, final encoding 2 | 3 | module Pf.Mp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty : Type where 14 | UNIT : Ty 15 | (:=>) : Ty -> Ty -> Ty 16 | (:&&) : Ty -> Ty -> Ty 17 | (:||) : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 :<=> 21 | (:<=>) : Ty -> Ty -> Ty 22 | (:<=>) a b = (a :=> b) :&& (b :=> a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a :=> FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE :=> FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Type 34 | Cx = Ty -> Type 35 | 36 | isTrue : Ty -> Cx -> Type 37 | isTrue a tc = tc a 38 | 39 | 40 | -- Terms 41 | 42 | TmRepr : Type 43 | TmRepr = Cx -> Ty -> Type 44 | 45 | infixl 1 :$ 46 | class ArrMpTm (tr : TmRepr) where 47 | var : isTrue a tc -> tr tc a 48 | lam' : (isTrue a tc -> tr tc b) -> tr tc (a :=> b) 49 | (:$) : tr tc (a :=> b) -> tr tc a -> tr tc b 50 | 51 | lam'' : {tr : TmRepr} -> ArrMpTm tr => (tr tc a -> tr tc b) -> tr tc (a :=> b) 52 | lam'' f = lam' $ \x => f (var x) 53 | 54 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 55 | 56 | class ArrMpTm tr => MpTm (tr : TmRepr) where 57 | pair : tr tc a -> tr tc b -> tr tc (a :&& b) 58 | fst : tr tc (a :&& b) -> tr tc a 59 | snd : tr tc (a :&& b) -> tr tc b 60 | left : tr tc a -> tr tc (a :|| b) 61 | right : tr tc b -> tr tc (a :|| b) 62 | case' : tr tc (a :|| b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c 63 | 64 | case'' : {tr : TmRepr} -> MpTm tr => tr tc (a :|| b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c 65 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 66 | 67 | syntax "[" [a] "," [b] "]" = pair a b 68 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 69 | 70 | Thm : Ty -> Type 71 | Thm a = {tr : TmRepr} -> {tc : Cx} -> MpTm tr => tr tc a 72 | 73 | 74 | -- Example theorems 75 | 76 | c1 : Thm (a :&& b :<=> b :&& a) 77 | c1 = 78 | [ lam xy :=> [ snd xy , fst xy ] 79 | , lam yx :=> [ snd yx , fst yx ] 80 | ] 81 | 82 | c2 : Thm (a :|| b :<=> b :|| a) 83 | c2 = 84 | [ lam xy :=> 85 | case xy 86 | of x :=> right x 87 | or y :=> left y 88 | , lam yx :=> 89 | case yx 90 | of y :=> right y 91 | or x :=> left x 92 | ] 93 | 94 | i1 : Thm (a :&& a :<=> a) 95 | i1 = 96 | [ lam xx :=> fst xx 97 | , lam x :=> [ x , x ] 98 | ] 99 | 100 | i2 : Thm (a :|| a :<=> a) 101 | i2 = 102 | [ lam xx :=> 103 | case xx 104 | of x :=> x 105 | or x :=> x 106 | , lam x :=> left x 107 | ] 108 | 109 | l3 : Thm ((a :=> a) :<=> TRUE) 110 | l3 = 111 | [ lam x :=> lam nt :=> nt 112 | , lam b :=> lam x :=> x 113 | ] 114 | 115 | l1 : Thm (a :&& (b :&& c) :<=> (a :&& b) :&& c) 116 | l1 = 117 | [ lam xyz :=> 118 | (let yz = snd xyz in 119 | [ [ fst xyz , fst yz ] , snd yz ]) 120 | , lam xyz :=> 121 | (let xy = fst xyz in 122 | [ fst xy , [ snd xy , snd xyz ] ]) 123 | ] 124 | 125 | l2 : Thm (a :&& TRUE :<=> a) 126 | l2 = 127 | [ lam xt :=> fst xt 128 | , lam x :=> [ x , lam nt :=> nt ] 129 | ] 130 | 131 | l4 : Thm (a :&& (b :|| c) :<=> (a :&& b) :|| (a :&& c)) 132 | l4 = 133 | [ lam xyz :=> 134 | (let x = fst xyz in 135 | case snd xyz 136 | of y :=> left [ x , y ] 137 | or z :=> right [ x , z ]) 138 | , lam xyxz :=> 139 | case xyxz 140 | of xy :=> ([ fst xy , left (snd xy) ]) 141 | or xz :=> [ fst xz , right (snd xz) ] 142 | ] 143 | 144 | l6 : Thm (a :|| (b :&& c) :<=> (a :|| b) :&& (a :|| c)) 145 | l6 = 146 | [ lam xyz :=> 147 | case xyz 148 | of x :=> ([ left x , left x ]) 149 | or yz :=> [ right (fst yz) , right (snd yz) ] 150 | , lam xyxz :=> 151 | case fst xyxz 152 | of x :=> left x 153 | or y :=> 154 | case snd xyxz 155 | of x :=> left x 156 | or z :=> right [ y , z ] 157 | ] 158 | 159 | l7 : Thm (a :|| TRUE :<=> TRUE) 160 | l7 = 161 | [ lam xt :=> lam nt :=> nt 162 | , lam t :=> right t 163 | ] 164 | 165 | l9 : Thm (a :|| (b :|| c) :<=> (a :|| b) :|| c) 166 | l9 = 167 | [ lam xyz :=> 168 | case xyz 169 | of x :=> left (left x) 170 | or yz :=> 171 | case yz 172 | of y :=> left (right y) 173 | or z :=> right z 174 | , lam xyz :=> 175 | case xyz 176 | of xy :=> 177 | case xy 178 | of x :=> left x 179 | or y :=> right (left y) 180 | or z :=> right (right z) 181 | ] 182 | 183 | l11 : Thm ((a :=> (b :&& c)) :<=> (a :=> b) :&& (a :=> c)) 184 | l11 = 185 | [ lam xyz :=> 186 | [ lam x :=> fst (xyz :$ x) 187 | , lam x :=> snd (xyz :$ x) 188 | ] 189 | , lam xyxz :=> 190 | lam x :=> [ fst xyxz :$ x , snd xyxz :$ x ] 191 | ] 192 | 193 | l12 : Thm ((a :=> TRUE) :<=> TRUE) 194 | l12 = 195 | [ lam f :=> lam nt :=> nt 196 | , lam t :=> lam f :=> t 197 | ] 198 | 199 | l13 : Thm ((a :=> (b :=> c)) :<=> ((a :&& b) :=> c)) 200 | l13 = 201 | [ lam xyz :=> 202 | lam xy :=> xyz :$ fst xy :$ snd xy 203 | , lam xyz :=> 204 | lam x :=> 205 | lam y :=> xyz :$ [ x , y ] 206 | ] 207 | 208 | l16 : Thm (((a :&& b) :=> c) :<=> (a :=> (b :=> c))) 209 | l16 = 210 | [ lam xyz :=> 211 | lam x :=> 212 | lam y :=> xyz :$ [ x , y ] 213 | , lam xyz :=> 214 | lam xy :=> xyz :$ fst xy :$ snd xy 215 | ] 216 | 217 | l17 : Thm ((TRUE :=> a) :<=> a) 218 | l17 = 219 | [ lam tx :=> tx :$ (lam nt :=> nt) 220 | , lam x :=> lam tx :=> x 221 | ] 222 | 223 | l19 : Thm (((a :|| b) :=> c) :<=> (a :=> c) :&& (b :=> c)) 224 | l19 = 225 | [ lam xyz :=> 226 | [ lam x :=> xyz :$ left x 227 | , lam y :=> xyz :$ right y 228 | ] 229 | , lam xzyz :=> 230 | lam xy :=> 231 | case xy 232 | of x :=> fst xzyz :$ x 233 | or y :=> snd xzyz :$ y 234 | ] 235 | -------------------------------------------------------------------------------- /src/Pi/ArrMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, PHOAS approach, initial encoding 2 | 3 | module Pi.ArrMp where 4 | 5 | 6 | -- Types 7 | 8 | infixr 0 _=>_ 9 | data Ty : Set where 10 | UNIT : Ty 11 | _=>_ : Ty -> Ty -> Ty 12 | 13 | 14 | -- Context and truth judgement 15 | 16 | Cx : Set1 17 | Cx = Ty -> Set 18 | 19 | isTrue : Ty -> Cx -> Set 20 | isTrue a tc = tc a 21 | 22 | 23 | -- Terms 24 | 25 | module ArrMp where 26 | infixl 1 _$_ 27 | data Tm (tc : Cx) : Ty -> Set where 28 | var : forall {a} -> isTrue a tc -> Tm tc a 29 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 30 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 31 | 32 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 33 | lam'' f = lam' \x -> f (var x) 34 | 35 | syntax lam'' (\a -> b) = lam a => b 36 | 37 | Thm : Ty -> Set1 38 | Thm a = forall {tc} -> Tm tc a 39 | open ArrMp public 40 | 41 | 42 | -- Example theorems 43 | 44 | aI : forall {a} -> Thm (a => a) 45 | aI = 46 | lam x => x 47 | 48 | aK : forall {a b} -> Thm (a => b => a) 49 | aK = 50 | lam x => 51 | lam _ => x 52 | 53 | aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c) 54 | aS = 55 | lam f => 56 | lam g => 57 | lam x => f $ x $ (g $ x) 58 | 59 | tSKK : forall {a} -> Thm (a => a) 60 | tSKK {a = a} = 61 | aS {b = a => a} $ aK $ aK 62 | -------------------------------------------------------------------------------- /src/Pi/ArrMp.hs: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, PHOAS approach, initial encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pi.ArrMp where 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 :=> 11 | data Ty :: * where 12 | UNIT :: Ty 13 | (:=>) :: Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | -- NOTE: Haskell does not support kind synonyms 19 | -- type Cx = Ty -> * 20 | 21 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 22 | 23 | 24 | -- Terms 25 | 26 | infixl 1 :$ 27 | data Tm :: (Ty -> *) -> Ty -> * where 28 | Var :: IsTrue a tc -> Tm tc a 29 | Lam :: (IsTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 30 | (:$) :: Tm tc (a :=> b) -> Tm tc a -> Tm tc b 31 | 32 | var :: IsTrue a tc -> Tm tc a 33 | var = Var 34 | 35 | lam :: (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 36 | lam f = Lam $ \x -> f (var x) 37 | 38 | type Thm a = forall tc. Tm tc a 39 | 40 | 41 | -- Example theorems 42 | 43 | aI :: Thm (a :=> a) 44 | aI = 45 | lam $ \x -> x 46 | 47 | aK :: Thm (a :=> b :=> a) 48 | aK = 49 | lam $ \x -> 50 | lam $ \_ -> x 51 | 52 | aS :: Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c) 53 | aS = 54 | lam $ \f -> 55 | lam $ \g -> 56 | lam $ \x -> f :$ x :$ (g :$ x) 57 | 58 | tSKK :: Thm (a :=> a) 59 | tSKK = 60 | aS :$ aK :$ aK 61 | -------------------------------------------------------------------------------- /src/Pi/ArrMp.idr: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, PHOAS approach, initial encoding 2 | 3 | module Pi.ArrMp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 :=> 11 | data Ty : Type where 12 | UNIT : Ty 13 | (:=>) : Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | Cx : Type 19 | Cx = Ty -> Type 20 | 21 | isTrue : Ty -> Cx -> Type 22 | isTrue a tc = tc a 23 | 24 | 25 | -- Terms 26 | 27 | infixl 1 :$ 28 | data Tm : Cx -> Ty -> Type where 29 | var : isTrue a tc -> Tm tc a 30 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 31 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 32 | 33 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 34 | lam'' f = lam' $ \x => f (var x) 35 | 36 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 37 | 38 | Thm : Ty -> Type 39 | Thm a = {tc : Cx} -> Tm tc a 40 | 41 | 42 | -- Example theorems 43 | 44 | aI : Thm (a :=> a) 45 | aI = 46 | lam x :=> x 47 | 48 | aK : Thm (a :=> b :=> a) 49 | aK = 50 | lam x :=> 51 | lam y :=> x 52 | 53 | aS : Thm ((a :=> b :=> c) :=> (a :=> b) :=> a :=> c) 54 | aS = 55 | lam f :=> 56 | lam g :=> 57 | lam x :=> f :$ x :$ (g :$ x) 58 | 59 | tSKK : Thm (a :=> a) 60 | tSKK {a} = 61 | aS {b = a :=> a} :$ aK :$ aK 62 | -------------------------------------------------------------------------------- /src/Pi/BoxMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, PHOAS approach, initial encoding 2 | 3 | module Pi.BoxMp where 4 | 5 | open import Lib using (Nat; suc) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | BOX : Ty -> Ty 15 | 16 | 17 | -- Context and truth judgement with modal depth 18 | 19 | Cx : Set1 20 | Cx = Ty -> Nat -> Set 21 | 22 | isTrue : Ty -> Nat -> Cx -> Set 23 | isTrue a d tc = tc a d 24 | 25 | 26 | -- Terms 27 | 28 | module BoxMp where 29 | infixl 1 _$_ 30 | data Tm (d : Nat) (tc : Cx) : Ty -> Set where 31 | var : forall {a} -> isTrue a d tc -> Tm d tc a 32 | lam' : forall {a b} -> (isTrue a d tc -> Tm d tc b) -> Tm d tc (a => b) 33 | _$_ : forall {a b} -> Tm d tc (a => b) -> Tm d tc a -> Tm d tc b 34 | box : forall {a} -> Tm (suc d) tc a -> Tm d tc (BOX a) 35 | unbox' : forall {>d a b} -> Tm d tc (BOX a) -> (isTrue a >d tc -> Tm d tc b) -> Tm d tc b 36 | 37 | lam'' : forall {d tc a b} -> (Tm d tc a -> Tm d tc b) -> Tm d tc (a => b) 38 | lam'' f = lam' \x -> f (var x) 39 | 40 | unbox'' : forall {d >d tc a b} -> Tm d tc (BOX a) -> (Tm >d tc a -> Tm d tc b) -> Tm d tc b 41 | unbox'' x f = unbox' x \y -> f (var y) 42 | 43 | syntax lam'' (\a -> b) = lam a => b 44 | syntax unbox'' x' (\x -> y) = unbox x' as x => y 45 | 46 | Thm : Ty -> Set1 47 | Thm a = forall {d tc} -> Tm d tc a 48 | open BoxMp public 49 | 50 | 51 | -- Example theorems 52 | 53 | rNec : forall {a} -> Thm a -> Thm (BOX a) 54 | rNec x = 55 | box x 56 | 57 | aK : forall {a b} -> Thm (BOX (a => b) => BOX a => BOX b) 58 | aK = 59 | lam f' => 60 | lam x' => 61 | unbox f' as f => 62 | unbox x' as x => 63 | box (f $ x) 64 | 65 | aT : forall {a} -> Thm (BOX a => a) 66 | aT = 67 | lam x' => 68 | unbox x' as x => x 69 | 70 | a4 : forall {a} -> Thm (BOX a => BOX (BOX a)) 71 | a4 = 72 | lam x' => 73 | unbox x' as x => box (box x) 74 | 75 | t1 : forall {a} -> Thm (a => BOX (a => a)) 76 | t1 = 77 | lam _ => box (lam y => y) 78 | -------------------------------------------------------------------------------- /src/Pi/BoxMp.hs: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, PHOAS approach, initial encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pi.BoxMp where 6 | 7 | import Lib (Nat (Suc)) 8 | 9 | 10 | -- Types 11 | 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | BOX :: Ty -> Ty 17 | 18 | 19 | -- Context and truth judgement with modal depth 20 | 21 | -- NOTE: Haskell does not support kind synonyms 22 | -- type Cx = Ty -> * 23 | 24 | type IsTrue (a :: Ty) (d :: Nat) (tc :: Ty -> Nat -> *) = tc a d 25 | 26 | 27 | -- Terms 28 | 29 | infixl 1 :$ 30 | data Tm :: Nat -> (Ty -> Nat -> *) -> Ty -> * where 31 | Var :: IsTrue a d tc -> Tm d tc a 32 | Lam :: (IsTrue a d tc -> Tm d tc b) -> Tm d tc (a :=> b) 33 | (:$) :: Tm d tc (a :=> b) -> Tm d tc a -> Tm d tc b 34 | Box :: Tm (Suc d) tc a -> Tm d tc (BOX a) 35 | Unbox :: Tm d tc (BOX a) -> (IsTrue a gd tc -> Tm d tc b) -> Tm d tc b 36 | 37 | var :: IsTrue a d tc -> Tm d tc a 38 | var = Var 39 | 40 | lam :: (Tm d tc a -> Tm d tc b) -> Tm d tc (a :=> b) 41 | lam f = Lam $ \x -> f (var x) 42 | 43 | box :: Tm (Suc d) tc a -> Tm d tc (BOX a) 44 | box = Box 45 | 46 | unbox :: Tm d tc (BOX a) -> (Tm gd tc a -> Tm d tc b) -> Tm d tc b 47 | unbox x' f = Unbox x' $ \x -> f (var x) 48 | 49 | type Thm a = forall d tc. Tm d tc a 50 | 51 | 52 | -- Example theorems 53 | 54 | rNec :: Thm a -> Thm (BOX a) 55 | rNec x = 56 | box x 57 | 58 | aK :: Thm (BOX (a :=> b) :=> BOX a :=> BOX b) 59 | aK = 60 | lam $ \f' -> 61 | lam $ \x' -> 62 | unbox f' $ \f -> 63 | unbox x' $ \x -> box (f :$ x) 64 | 65 | aT :: Thm (BOX a :=> a) 66 | aT = 67 | lam $ \x' -> 68 | unbox x' $ \x -> x 69 | 70 | a4 :: Thm (BOX a :=> BOX (BOX a)) 71 | a4 = 72 | lam $ \x' -> 73 | unbox x' $ \x -> box (box x) 74 | 75 | t1 :: Thm (a :=> BOX (a :=> a)) 76 | t1 = 77 | lam $ \_ -> box (lam $ \y -> y) 78 | -------------------------------------------------------------------------------- /src/Pi/BoxMp.idr: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, PHOAS approach, initial encoding 2 | 3 | module Pi.BoxMp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 :=> 11 | data Ty : Type where 12 | UNIT : Ty 13 | (:=>) : Ty -> Ty -> Ty 14 | BOX : Ty -> Ty 15 | 16 | 17 | -- Context and truth judgement with modal depth 18 | 19 | Cx : Type 20 | Cx = Nat -> Ty -> Type 21 | 22 | isTrue : Ty -> Nat -> Cx -> Type 23 | isTrue a d tc = tc d a 24 | 25 | 26 | -- Terms 27 | 28 | infixl 1 :$ 29 | data Tm : Nat -> Cx -> Ty -> Type where 30 | var : isTrue a d tc -> Tm d tc a 31 | lam' : (isTrue a d tc -> Tm d tc b) -> Tm d tc (a :=> b) 32 | (:$) : Tm d tc (a :=> b) -> Tm d tc a -> Tm d tc b 33 | box : Tm (succ d) tc a -> Tm d tc (BOX a) 34 | unbox' : Tm d tc (BOX a) -> (isTrue a gd tc -> Tm d tc b) -> Tm d tc b 35 | 36 | lam'' : (Tm d tc a -> Tm d tc b) -> Tm d tc (a :=> b) 37 | lam'' f = lam' $ \x => f (var x) 38 | 39 | unbox'' : Tm d tc (BOX a) -> (Tm gd tc a -> Tm d tc b) -> Tm d tc b 40 | unbox'' x' f = unbox' x' $ \x => f (var x) 41 | 42 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 43 | syntax "unbox" [a'] as {a} ":=>" [b] = unbox'' a' (\a => b) 44 | 45 | Thm : Ty -> Type 46 | Thm a = {d : Nat} -> {tc : Cx} -> Tm d tc a 47 | 48 | 49 | -- Example theorems 50 | 51 | rNec : Thm a -> Thm (BOX a) 52 | rNec x = 53 | box x 54 | 55 | aK : Thm (BOX (a :=> b) :=> BOX a :=> BOX b) 56 | aK = 57 | lam f' :=> 58 | lam x' :=> 59 | unbox f' as f :=> 60 | unbox x' as x :=> box (f :$ x) 61 | 62 | aT : Thm (BOX a :=> a) 63 | aT = 64 | lam x' :=> 65 | unbox x' as x :=> x 66 | 67 | a4 : Thm (BOX a :=> BOX (BOX a)) 68 | a4 = 69 | lam x' :=> 70 | unbox x' as x :=> box (box x) 71 | 72 | t1 : Thm (a :=> BOX (a :=> a)) 73 | t1 = 74 | lam x :=> box (lam y :=> y) 75 | -------------------------------------------------------------------------------- /src/Pi/C.agda: -------------------------------------------------------------------------------- 1 | -- Classical logic, PHOAS approach, initial encoding 2 | 3 | module Pi.C (Indiv : Set) where 4 | 5 | 6 | -- Types 7 | 8 | data Ty : Set 9 | 10 | Pred : Set 11 | Pred = Indiv -> Ty 12 | 13 | infixl 2 _&&_ 14 | infixl 1 _||_ 15 | infixr 0 _=>_ 16 | data Ty where 17 | UNIT : Ty 18 | _=>_ : Ty -> Ty -> Ty 19 | _&&_ : Ty -> Ty -> Ty 20 | _||_ : Ty -> Ty -> Ty 21 | FALSE : Ty 22 | FORALL : Pred -> Ty 23 | EXISTS : Pred -> Ty 24 | 25 | infixr 0 _<=>_ 26 | _<=>_ : Ty -> Ty -> Ty 27 | a <=> b = (a => b) && (b => a) 28 | 29 | NOT : Ty -> Ty 30 | NOT a = a => FALSE 31 | 32 | TRUE : Ty 33 | TRUE = FALSE => FALSE 34 | 35 | 36 | -- Context and truth/individual judgement 37 | 38 | data El : Set where 39 | mkTrue : Ty -> El 40 | mkIndiv : Indiv -> El 41 | 42 | Cx : Set1 43 | Cx = El -> Set 44 | 45 | isTrue : Ty -> Cx -> Set 46 | isTrue a tc = tc (mkTrue a) 47 | 48 | isIndiv : Indiv -> Cx -> Set 49 | isIndiv x tc = tc (mkIndiv x) 50 | 51 | 52 | -- Terms 53 | 54 | module C where 55 | infixl 2 _$$_ 56 | infixl 1 _$_ 57 | data Tm (tc : Cx) : Ty -> Set where 58 | var : forall {a} -> isTrue a tc -> Tm tc a 59 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 60 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 61 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 62 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 63 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 64 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 65 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 66 | case' : forall {a b c} -> Tm tc (a || b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 67 | pi' : forall {p} -> (forall {x} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p) 68 | _$$_ : forall {p x} -> Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x) 69 | sig' : forall {p x} -> isIndiv x tc -> Tm tc (p x) -> Tm tc (EXISTS p) 70 | split' : forall {p x a} -> Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a 71 | abort' : forall {a} -> (isTrue (NOT a) tc -> Tm tc FALSE) -> Tm tc a 72 | 73 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 74 | lam'' f = lam' \x -> f (var x) 75 | 76 | case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 77 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 78 | 79 | split'' : forall {tc p x a} -> Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a 80 | split'' x f = split' x \y -> f (var y) 81 | 82 | abort'' : forall {tc a} -> (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a 83 | abort'' f = abort' \na -> f (var na) 84 | 85 | syntax lam'' (\a -> b) = lam a => b 86 | syntax pair' x y = [ x , y ] 87 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 88 | syntax pi' (\x -> px) = pi x => px 89 | syntax sig' x px = [ x ,, px ] 90 | syntax split'' x (\y -> z) = split x as y => z 91 | syntax abort'' (\x -> y) = abort x => y 92 | 93 | Thm : Ty -> Set1 94 | Thm a = forall {tc} -> Tm tc a 95 | open C public 96 | 97 | 98 | -- Example theorems 99 | 100 | t214 : forall {p} -> Thm (NOT (FORALL (\x -> NOT (p x))) => EXISTS p) 101 | t214 = 102 | lam f => 103 | abort g => 104 | f $ (pi x => 105 | lam p => g $ [ x ,, p ]) 106 | -------------------------------------------------------------------------------- /src/Pi/C.idr: -------------------------------------------------------------------------------- 1 | -- Classical logic, PHOAS approach, initial encoding 2 | 3 | module Pi.C 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | data Indiv : Type where 11 | TODO : Indiv 12 | 13 | Ty : Type 14 | 15 | Pred : Type 16 | Pred = Indiv -> Ty 17 | 18 | infixl 2 :&& 19 | infixl 1 :|| 20 | infixr 0 :=> 21 | data Ty : Type where 22 | UNIT : Ty 23 | (:=>) : Ty -> Ty -> Ty 24 | (:&&) : Ty -> Ty -> Ty 25 | (:||) : Ty -> Ty -> Ty 26 | FALSE : Ty 27 | FORALL : Pred -> Ty 28 | EXISTS : Pred -> Ty 29 | 30 | infixr 0 :<=> 31 | (:<=>) : Ty -> Ty -> Ty 32 | (:<=>) a b = (a :=> b) :&& (b :=> a) 33 | 34 | NOT : Ty -> Ty 35 | NOT a = a :=> FALSE 36 | 37 | TRUE : Ty 38 | TRUE = FALSE :=> FALSE 39 | 40 | 41 | -- Context and truth judgement 42 | 43 | data El : Type where 44 | mkTrue : Ty -> El 45 | mkIndiv : Indiv -> El 46 | 47 | Cx : Type 48 | Cx = El -> Type 49 | 50 | isTrue : Ty -> Cx -> Type 51 | isTrue a tc = tc (mkTrue a) 52 | 53 | isIndiv : Indiv -> Cx -> Type 54 | isIndiv x tc = tc (mkIndiv x) 55 | 56 | 57 | -- Terms 58 | 59 | infixl 2 :$$ 60 | infixl 1 :$ 61 | 62 | data Tm : Cx -> Ty -> Type where 63 | var : isTrue a tc -> Tm tc a 64 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 65 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 66 | pair : Tm tc a -> Tm tc b -> Tm tc (a :&& b) 67 | fst : Tm tc (a :&& b) -> Tm tc a 68 | snd : Tm tc (a :&& b) -> Tm tc b 69 | left : Tm tc a -> Tm tc (a :|| b) 70 | right : Tm tc b -> Tm tc (a :|| b) 71 | case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 72 | pi' : ({x : Indiv} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p) 73 | (:$$) : Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x) 74 | sig : isIndiv x tc -> Tm tc (p x) -> Tm tc (EXISTS p) 75 | split' : Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a 76 | abort' : (isTrue (NOT a) tc -> Tm tc FALSE) -> Tm tc a 77 | 78 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 79 | lam'' f = lam' $ \x => f (var x) 80 | 81 | case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 82 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 83 | 84 | split'' : Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a 85 | split'' x f = split' x $ \y => f (var y) 86 | 87 | abort'' : (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a 88 | abort'' f = abort' $ \na => f (var na) 89 | 90 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 91 | syntax "[" [a] "," [b] "]" = pair a b 92 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 93 | syntax "pi" {x} ":=>" [y] = pi' (\x => y) 94 | syntax "[" [x] ",," [y] "]" = sig x y 95 | syntax "split" [x] as {y} ":=>" [z] = split'' x (\y => z) 96 | syntax "abort" {a} ":=>" [b] = abort'' (\a => b) 97 | 98 | Thm : Ty -> Type 99 | Thm a = {tc : Cx} -> Tm tc a 100 | 101 | 102 | -- Example theorems 103 | 104 | t214 : Thm (NOT (FORALL (\x => NOT (p x))) :=> EXISTS p) 105 | t214 = 106 | lam f :=> 107 | abort g :=> 108 | f :$ (pi x :=> 109 | lam p :=> g :$ [ x ,, p ]) 110 | -------------------------------------------------------------------------------- /src/Pi/Cp.agda: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, PHOAS approach, initial encoding 2 | 3 | module Pi.Cp where 4 | 5 | 6 | -- Types 7 | 8 | infixl 2 _&&_ 9 | infixl 1 _||_ 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | _&&_ : Ty -> Ty -> Ty 15 | _||_ : Ty -> Ty -> Ty 16 | FALSE : Ty 17 | 18 | infixr 0 _<=>_ 19 | _<=>_ : Ty -> Ty -> Ty 20 | a <=> b = (a => b) && (b => a) 21 | 22 | NOT : Ty -> Ty 23 | NOT a = a => FALSE 24 | 25 | TRUE : Ty 26 | TRUE = FALSE => FALSE 27 | 28 | 29 | -- Context and truth judgement 30 | 31 | Cx : Set1 32 | Cx = Ty -> Set 33 | 34 | isTrue : Ty -> Cx -> Set 35 | isTrue a tc = tc a 36 | 37 | 38 | -- Terms 39 | 40 | module Cp where 41 | infixl 1 _$_ 42 | data Tm (tc : Cx) : Ty -> Set where 43 | var : forall {a} -> isTrue a tc -> Tm tc a 44 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 45 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 46 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 47 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 48 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 49 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 50 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 51 | case' : forall {a b c} -> Tm tc (a || b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 52 | abort' : forall {a} -> (isTrue (NOT a) tc -> Tm tc FALSE) -> Tm tc a 53 | 54 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 55 | lam'' f = lam' \x -> f (var x) 56 | 57 | case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 58 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 59 | 60 | abort'' : forall {tc a} -> (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a 61 | abort'' f = abort' \na -> f (var na) 62 | 63 | syntax lam'' (\a -> b) = lam a => b 64 | syntax pair' x y = [ x , y ] 65 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 66 | syntax abort'' (\x -> y) = abort x => y 67 | 68 | Thm : Ty -> Set1 69 | Thm a = forall {tc} -> Tm tc a 70 | open Cp public 71 | -------------------------------------------------------------------------------- /src/Pi/Cp.hs: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, PHOAS approach, initial encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pi.Cp where 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | (:&&) :: Ty -> Ty -> Ty 17 | (:||) :: Ty -> Ty -> Ty 18 | FALSE :: Ty 19 | 20 | infixr 0 :<=> 21 | type a :<=> b = (a :=> b) :&& (b :=> a) 22 | 23 | type NOT a = a :=> FALSE 24 | 25 | type TRUE = FALSE :=> FALSE 26 | 27 | 28 | -- Context and truth judgement 29 | 30 | -- NOTE: Haskell does not support kind synonyms 31 | -- type Cx = Ty -> * 32 | 33 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 34 | 35 | 36 | -- Terms 37 | 38 | infixl 1 :$ 39 | data Tm :: (Ty -> *) -> Ty -> * where 40 | Var :: IsTrue a tc -> Tm tc a 41 | Lam :: (IsTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 42 | (:$) :: Tm tc (a :=> b) -> Tm tc a -> Tm tc b 43 | Pair :: Tm tc a -> Tm tc b -> Tm tc (a :&& b) 44 | Fst :: Tm tc (a :&& b) -> Tm tc a 45 | Snd :: Tm tc (a :&& b) -> Tm tc b 46 | Left' :: Tm tc a -> Tm tc (a :|| b) 47 | Right' :: Tm tc b -> Tm tc (a :|| b) 48 | Match :: Tm tc (a :|| b) -> (IsTrue a tc -> Tm tc c) -> (IsTrue b tc -> Tm tc c) -> Tm tc c 49 | Abort :: (IsTrue (NOT a) tc -> Tm tc FALSE) -> Tm tc a 50 | 51 | var :: IsTrue a tc -> Tm tc a 52 | var = Var 53 | 54 | lam :: (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 55 | lam f = Lam $ \x -> f (var x) 56 | 57 | pair :: (Tm tc a, Tm tc b) -> Tm tc (a :&& b) 58 | pair (a, b) = Pair a b 59 | 60 | fst' :: Tm tc (a :&& b) -> Tm tc a 61 | fst' = Fst 62 | 63 | snd' :: Tm tc (a :&& b) -> Tm tc b 64 | snd' = Snd 65 | 66 | left :: Tm tc a -> Tm tc (a :|| b) 67 | left = Left' 68 | 69 | right :: Tm tc b -> Tm tc (a :|| b) 70 | right = Right' 71 | 72 | case' :: Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 73 | case' xy f g = Match xy (\x -> f (var x)) (\y -> g (var y)) 74 | 75 | abort :: (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a 76 | abort f = Abort $ \na -> f (var na) 77 | 78 | type Thm a = forall tc. Tm tc a 79 | -------------------------------------------------------------------------------- /src/Pi/Cp.idr: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, PHOAS approach, initial encoding 2 | 3 | module Pi.Cp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty : Type where 14 | UNIT : Ty 15 | (:=>) : Ty -> Ty -> Ty 16 | (:&&) : Ty -> Ty -> Ty 17 | (:||) : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 :<=> 21 | (:<=>) : Ty -> Ty -> Ty 22 | (:<=>) a b = (a :=> b) :&& (b :=> a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a :=> FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE :=> FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Type 34 | Cx = Ty -> Type 35 | 36 | isTrue : Ty -> Cx -> Type 37 | isTrue a tc = tc a 38 | 39 | 40 | -- Terms 41 | 42 | infixl 1 :$ 43 | data Tm : Cx -> Ty -> Type where 44 | var : isTrue a tc -> Tm tc a 45 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 46 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 47 | pair : Tm tc a -> Tm tc b -> Tm tc (a :&& b) 48 | fst : Tm tc (a :&& b) -> Tm tc a 49 | snd : Tm tc (a :&& b) -> Tm tc b 50 | left : Tm tc a -> Tm tc (a :|| b) 51 | right : Tm tc b -> Tm tc (a :|| b) 52 | case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 53 | abort' : (isTrue (NOT a) tc -> Tm tc FALSE) -> Tm tc a 54 | 55 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 56 | lam'' f = lam' $ \x => f (var x) 57 | 58 | case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 59 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 60 | 61 | abort'' : (Tm tc (NOT a) -> Tm tc FALSE) -> Tm tc a 62 | abort'' f = abort' $ \na => f (var na) 63 | 64 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 65 | syntax "[" [a] "," [b] "]" = pair a b 66 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 67 | syntax "abort" {a} ":=>" [b] = abort'' (\a => b) 68 | 69 | Thm : Ty -> Type 70 | Thm a = {tc : Cx} -> Tm tc a 71 | -------------------------------------------------------------------------------- /src/Pi/I.agda: -------------------------------------------------------------------------------- 1 | -- Intuitionistic logic, PHOAS approach, initial encoding 2 | 3 | module Pi.I (Indiv : Set) where 4 | 5 | 6 | -- Types 7 | 8 | data Ty : Set 9 | 10 | Pred : Set 11 | Pred = Indiv -> Ty 12 | 13 | infixl 2 _&&_ 14 | infixl 1 _||_ 15 | infixr 0 _=>_ 16 | data Ty where 17 | UNIT : Ty 18 | _=>_ : Ty -> Ty -> Ty 19 | _&&_ : Ty -> Ty -> Ty 20 | _||_ : Ty -> Ty -> Ty 21 | FALSE : Ty 22 | FORALL : Pred -> Ty 23 | EXISTS : Pred -> Ty 24 | 25 | infixr 0 _<=>_ 26 | _<=>_ : Ty -> Ty -> Ty 27 | a <=> b = (a => b) && (b => a) 28 | 29 | NOT : Ty -> Ty 30 | NOT a = a => FALSE 31 | 32 | TRUE : Ty 33 | TRUE = FALSE => FALSE 34 | 35 | 36 | -- Context and truth/individual judgement 37 | 38 | data El : Set where 39 | mkTrue : Ty -> El 40 | mkIndiv : Indiv -> El 41 | 42 | Cx : Set1 43 | Cx = El -> Set 44 | 45 | isTrue : Ty -> Cx -> Set 46 | isTrue a tc = tc (mkTrue a) 47 | 48 | isIndiv : Indiv -> Cx -> Set 49 | isIndiv x tc = tc (mkIndiv x) 50 | 51 | 52 | -- Terms 53 | 54 | module I where 55 | infixl 2 _$$_ 56 | infixl 1 _$_ 57 | data Tm (tc : Cx) : Ty -> Set where 58 | var : forall {a} -> isTrue a tc -> Tm tc a 59 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 60 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 61 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 62 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 63 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 64 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 65 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 66 | case' : forall {a b c} -> Tm tc (a || b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 67 | pi' : forall {p} -> (forall {x} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p) 68 | _$$_ : forall {p x} -> Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x) 69 | sig' : forall {p x} -> isIndiv x tc -> Tm tc (p x) -> Tm tc (EXISTS p) 70 | split' : forall {p x a} -> Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a 71 | abort : forall {a} -> Tm tc FALSE -> Tm tc a 72 | 73 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 74 | lam'' f = lam' \x -> f (var x) 75 | 76 | case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 77 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 78 | 79 | split'' : forall {tc p x a} -> Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a 80 | split'' x f = split' x \y -> f (var y) 81 | 82 | syntax lam'' (\a -> b) = lam a => b 83 | syntax pair' x y = [ x , y ] 84 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 85 | syntax pi' (\x -> px) = pi x => px 86 | syntax sig' x px = [ x ,, px ] 87 | syntax split'' x (\y -> z) = split x as y => z 88 | 89 | Thm : Ty -> Set1 90 | Thm a = forall {tc} -> Tm tc a 91 | open I public 92 | 93 | 94 | -- Example theorems 95 | 96 | t214 : forall {p q : Pred} -> Thm ( 97 | FORALL (\x -> p x || NOT (p x)) && FORALL (\x -> p x => EXISTS (\y -> q y)) => 98 | FORALL (\x -> EXISTS (\y -> p x => q y))) 99 | t214 = 100 | lam fg => 101 | pi x => 102 | case fst fg $$ x 103 | of px => 104 | split snd fg $$ x $ px 105 | as qy => 106 | [ x ,, lam _ => qy ] 107 | or npx => 108 | [ x ,, lam px => abort (npx $ px) ] 109 | 110 | l5 : forall {a} -> Thm (a && FALSE <=> FALSE) 111 | l5 = 112 | [ lam xnt => snd xnt 113 | , lam nt => abort nt 114 | ] 115 | 116 | l10 : forall {a} -> Thm (a || FALSE <=> a) 117 | l10 = 118 | [ lam xnt => 119 | case xnt 120 | of x => x 121 | or nt => abort nt 122 | , lam x => left x 123 | ] 124 | 125 | l20 : forall {a} -> Thm ((FALSE => a) <=> TRUE) 126 | l20 = 127 | [ lam _ => lam nt => nt 128 | , lam _ => lam nt => abort nt 129 | ] 130 | -------------------------------------------------------------------------------- /src/Pi/I.idr: -------------------------------------------------------------------------------- 1 | -- Intuitionistic logic, PHOAS approach, initial encoding 2 | 3 | module Pi.I 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | data Indiv : Type where 11 | TODO : Indiv 12 | 13 | Ty : Type 14 | 15 | Pred : Type 16 | Pred = Indiv -> Ty 17 | 18 | infixl 2 :&& 19 | infixl 1 :|| 20 | infixr 0 :=> 21 | data Ty : Type where 22 | UNIT : Ty 23 | (:=>) : Ty -> Ty -> Ty 24 | (:&&) : Ty -> Ty -> Ty 25 | (:||) : Ty -> Ty -> Ty 26 | FALSE : Ty 27 | FORALL : Pred -> Ty 28 | EXISTS : Pred -> Ty 29 | 30 | infixr 0 :<=> 31 | (:<=>) : Ty -> Ty -> Ty 32 | (:<=>) a b = (a :=> b) :&& (b :=> a) 33 | 34 | NOT : Ty -> Ty 35 | NOT a = a :=> FALSE 36 | 37 | TRUE : Ty 38 | TRUE = FALSE :=> FALSE 39 | 40 | 41 | -- Context and truth judgement 42 | 43 | data El : Type where 44 | mkTrue : Ty -> El 45 | mkIndiv : Indiv -> El 46 | 47 | Cx : Type 48 | Cx = El -> Type 49 | 50 | isTrue : Ty -> Cx -> Type 51 | isTrue a tc = tc (mkTrue a) 52 | 53 | isIndiv : Indiv -> Cx -> Type 54 | isIndiv x tc = tc (mkIndiv x) 55 | 56 | 57 | -- Terms 58 | 59 | infixl 2 :$$ 60 | infixl 1 :$ 61 | 62 | data Tm : Cx -> Ty -> Type where 63 | var : isTrue a tc -> Tm tc a 64 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 65 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 66 | pair : Tm tc a -> Tm tc b -> Tm tc (a :&& b) 67 | fst : Tm tc (a :&& b) -> Tm tc a 68 | snd : Tm tc (a :&& b) -> Tm tc b 69 | left : Tm tc a -> Tm tc (a :|| b) 70 | right : Tm tc b -> Tm tc (a :|| b) 71 | case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 72 | pi' : ({x : Indiv} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p) 73 | (:$$) : Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x) 74 | sig : isIndiv x tc -> Tm tc (p x) -> Tm tc (EXISTS p) 75 | split' : Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a 76 | abort : Tm tc FALSE -> Tm tc a 77 | 78 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 79 | lam'' f = lam' $ \x => f (var x) 80 | 81 | case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 82 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 83 | 84 | split'' : Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a 85 | split'' x f = split' x $ \y => f (var y) 86 | 87 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 88 | syntax "[" [a] "," [b] "]" = pair a b 89 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 90 | syntax "pi" {x} ":=>" [y] = pi' (\x => y) 91 | syntax "[" [x] ",," [y] "]" = sig x y 92 | syntax "split" [x] as {y} ":=>" [z] = split'' x (\y => z) 93 | 94 | Thm : Ty -> Type 95 | Thm a = {tc : Cx} -> Tm tc a 96 | 97 | 98 | -- Example theorems 99 | 100 | t214 : {p, q : Pred} -> Thm ( 101 | FORALL (\x => p x :|| NOT (p x)) :&& FORALL (\x => p x :=> EXISTS (\y => q y)) :=> 102 | FORALL (\x => EXISTS (\y => p x :=> q y))) 103 | t214 = 104 | lam fg :=> 105 | pi x :=> 106 | case fst fg :$$ x 107 | of px :=> 108 | split (snd fg :$$ x :$ px) as qy :=> [ x ,, lam y :=> qy ] 109 | or npx :=> 110 | [ x ,, lam px :=> abort (npx :$ px) ] 111 | 112 | l5 : Thm (a :&& FALSE :<=> FALSE) 113 | l5 = 114 | [ lam xnt :=> snd xnt 115 | , lam nt :=> abort nt 116 | ] 117 | 118 | l10 : Thm (a :|| FALSE :<=> a) 119 | l10 = 120 | [ lam xnt :=> 121 | case xnt 122 | of x :=> x 123 | or nt :=> abort nt 124 | , lam x :=> left x 125 | ] 126 | 127 | l20 : Thm ((FALSE :=> a) :<=> TRUE) 128 | l20 = 129 | [ lam f :=> lam nt :=> nt 130 | , lam t :=> lam nt :=> abort nt 131 | ] 132 | -------------------------------------------------------------------------------- /src/Pi/Ip.agda: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, PHOAS approach, initial encoding 2 | 3 | module Pi.Ip where 4 | 5 | 6 | -- Types 7 | 8 | infixl 2 _&&_ 9 | infixl 1 _||_ 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | _&&_ : Ty -> Ty -> Ty 15 | _||_ : Ty -> Ty -> Ty 16 | FALSE : Ty 17 | 18 | infixr 0 _<=>_ 19 | _<=>_ : Ty -> Ty -> Ty 20 | a <=> b = (a => b) && (b => a) 21 | 22 | NOT : Ty -> Ty 23 | NOT a = a => FALSE 24 | 25 | TRUE : Ty 26 | TRUE = FALSE => FALSE 27 | 28 | 29 | -- Context and truth judgement 30 | 31 | Cx : Set1 32 | Cx = Ty -> Set 33 | 34 | isTrue : Ty -> Cx -> Set 35 | isTrue a tc = tc a 36 | 37 | 38 | -- Terms 39 | 40 | module Ip where 41 | infixl 1 _$_ 42 | data Tm (tc : Cx) : Ty -> Set where 43 | var : forall {a} -> isTrue a tc -> Tm tc a 44 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 45 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 46 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 47 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 48 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 49 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 50 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 51 | case' : forall {a b c} -> Tm tc (a || b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 52 | abort : forall {a} -> Tm tc FALSE -> Tm tc a 53 | 54 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 55 | lam'' f = lam' \x -> f (var x) 56 | 57 | case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 58 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 59 | 60 | syntax lam'' (\a -> b) = lam a => b 61 | syntax pair' x y = [ x , y ] 62 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 63 | 64 | Thm : Ty -> Set1 65 | Thm a = forall {tc} -> Tm tc a 66 | open Ip public 67 | 68 | 69 | -- Example theorems 70 | 71 | t1 : forall {a b} -> Thm (a => NOT a => b) 72 | t1 = 73 | lam x => 74 | lam f => abort (f $ x) 75 | 76 | t2 : forall {a b} -> Thm (NOT a => a => b) 77 | t2 = 78 | lam f => 79 | lam x => abort (f $ x) 80 | 81 | t3 : forall {a} -> Thm (a => NOT (NOT a)) 82 | t3 = 83 | lam x => 84 | lam f => f $ x 85 | 86 | t4 : forall {a} -> Thm (NOT a <=> NOT (NOT (NOT a))) 87 | t4 = 88 | [ lam f => 89 | lam g => g $ f 90 | , lam g => 91 | lam x => g $ (lam f => f $ x) 92 | ] 93 | -------------------------------------------------------------------------------- /src/Pi/Ip.hs: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, PHOAS approach, initial encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pi.Ip where 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | (:&&) :: Ty -> Ty -> Ty 17 | (:||) :: Ty -> Ty -> Ty 18 | FALSE :: Ty 19 | 20 | infixr 0 :<=> 21 | type a :<=> b = (a :=> b) :&& (b :=> a) 22 | 23 | type NOT a = a :=> FALSE 24 | 25 | type TRUE = FALSE :=> FALSE 26 | 27 | 28 | -- Context and truth judgement 29 | 30 | -- NOTE: Haskell does not support kind synonyms 31 | -- type Cx = Ty -> * 32 | 33 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 34 | 35 | 36 | -- Terms 37 | 38 | infixl 1 :$ 39 | data Tm :: (Ty -> *) -> Ty -> * where 40 | Var :: IsTrue a tc -> Tm tc a 41 | Lam :: (IsTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 42 | (:$) :: Tm tc (a :=> b) -> Tm tc a -> Tm tc b 43 | Pair :: Tm tc a -> Tm tc b -> Tm tc (a :&& b) 44 | Fst :: Tm tc (a :&& b) -> Tm tc a 45 | Snd :: Tm tc (a :&& b) -> Tm tc b 46 | Left' :: Tm tc a -> Tm tc (a :|| b) 47 | Right' :: Tm tc b -> Tm tc (a :|| b) 48 | Match :: Tm tc (a :|| b) -> (IsTrue a tc -> Tm tc c) -> (IsTrue b tc -> Tm tc c) -> Tm tc c 49 | Abort :: Tm tc FALSE -> Tm tc a 50 | 51 | var :: IsTrue a tc -> Tm tc a 52 | var = Var 53 | 54 | lam :: (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 55 | lam f = Lam $ \x -> f (var x) 56 | 57 | pair :: (Tm tc a, Tm tc b) -> Tm tc (a :&& b) 58 | pair (a, b) = Pair a b 59 | 60 | fst' :: Tm tc (a :&& b) -> Tm tc a 61 | fst' = Fst 62 | 63 | snd' :: Tm tc (a :&& b) -> Tm tc b 64 | snd' = Snd 65 | 66 | left :: Tm tc a -> Tm tc (a :|| b) 67 | left = Left' 68 | 69 | right :: Tm tc b -> Tm tc (a :|| b) 70 | right = Right' 71 | 72 | case' :: Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 73 | case' xy f g = Match xy (\x -> f (var x)) (\y -> g (var y)) 74 | 75 | abort :: Tm tc FALSE -> Tm tc a 76 | abort = Abort 77 | 78 | type Thm a = forall tc. Tm tc a 79 | 80 | 81 | -- Example theorems 82 | 83 | t1 :: Thm (a :=> NOT a :=> b) 84 | t1 = 85 | lam $ \x -> 86 | lam $ \f -> abort (f :$ x) 87 | 88 | t2 :: Thm (NOT a :=> a :=> b) 89 | t2 = 90 | lam $ \f -> 91 | lam $ \x -> abort (f :$ x) 92 | 93 | t3 :: Thm (a :=> NOT (NOT a)) 94 | t3 = 95 | lam $ \x -> 96 | lam $ \f -> f :$ x 97 | 98 | t4 :: Thm (NOT a :<=> NOT (NOT (NOT a))) 99 | t4 = 100 | pair 101 | ( lam $ \f -> 102 | lam $ \g -> g :$ f 103 | , lam $ \g -> 104 | lam $ \x -> g :$ (lam $ \f -> f :$ x) 105 | ) 106 | -------------------------------------------------------------------------------- /src/Pi/Ip.idr: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, PHOAS approach, initial encoding 2 | 3 | module Pi.Ip 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty : Type where 14 | UNIT : Ty 15 | (:=>) : Ty -> Ty -> Ty 16 | (:&&) : Ty -> Ty -> Ty 17 | (:||) : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 :<=> 21 | (:<=>) : Ty -> Ty -> Ty 22 | (:<=>) a b = (a :=> b) :&& (b :=> a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a :=> FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE :=> FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Type 34 | Cx = Ty -> Type 35 | 36 | isTrue : Ty -> Cx -> Type 37 | isTrue a tc = tc a 38 | 39 | 40 | -- Terms 41 | 42 | infixl 1 :$ 43 | data Tm : Cx -> Ty -> Type where 44 | var : isTrue a tc -> Tm tc a 45 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 46 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 47 | pair : Tm tc a -> Tm tc b -> Tm tc (a :&& b) 48 | fst : Tm tc (a :&& b) -> Tm tc a 49 | snd : Tm tc (a :&& b) -> Tm tc b 50 | left : Tm tc a -> Tm tc (a :|| b) 51 | right : Tm tc b -> Tm tc (a :|| b) 52 | case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 53 | abort : Tm tc FALSE -> Tm tc a 54 | 55 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 56 | lam'' f = lam' $ \x => f (var x) 57 | 58 | case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 59 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 60 | 61 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 62 | syntax "[" [a] "," [b] "]" = pair a b 63 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 64 | 65 | Thm : Ty -> Type 66 | Thm a = {tc : Cx} -> Tm tc a 67 | 68 | 69 | -- Example theorems 70 | 71 | t1 : Thm (a :=> NOT a :=> b) 72 | t1 = 73 | lam x :=> 74 | lam f :=> abort (f :$ x) 75 | 76 | t2 : Thm (NOT a :=> a :=> b) 77 | t2 = 78 | lam f :=> 79 | lam x :=> abort (f :$ x) 80 | 81 | t3 : Thm (a :=> NOT (NOT a)) 82 | t3 = 83 | lam x :=> 84 | lam f :=> f :$ x 85 | 86 | t4 : Thm (NOT a :<=> NOT (NOT (NOT a))) 87 | t4 = 88 | [ lam f :=> 89 | lam g :=> g :$ f 90 | , lam g :=> 91 | lam x :=> g :$ (lam f :=> f :$ x) 92 | ] 93 | -------------------------------------------------------------------------------- /src/Pi/M.agda: -------------------------------------------------------------------------------- 1 | -- Minimal logic, PHOAS approach, initial encoding 2 | 3 | module Pi.M (Indiv : Set) where 4 | 5 | 6 | -- Types 7 | 8 | data Ty : Set 9 | 10 | Pred : Set 11 | Pred = Indiv -> Ty 12 | 13 | infixl 2 _&&_ 14 | infixl 1 _||_ 15 | infixr 0 _=>_ 16 | data Ty where 17 | UNIT : Ty 18 | _=>_ : Ty -> Ty -> Ty 19 | _&&_ : Ty -> Ty -> Ty 20 | _||_ : Ty -> Ty -> Ty 21 | FALSE : Ty 22 | FORALL : Pred -> Ty 23 | EXISTS : Pred -> Ty 24 | 25 | infixr 0 _<=>_ 26 | _<=>_ : Ty -> Ty -> Ty 27 | a <=> b = (a => b) && (b => a) 28 | 29 | NOT : Ty -> Ty 30 | NOT a = a => FALSE 31 | 32 | TRUE : Ty 33 | TRUE = FALSE => FALSE 34 | 35 | 36 | -- Context and truth/individual judgement 37 | 38 | data El : Set where 39 | mkTrue : Ty -> El 40 | mkIndiv : Indiv -> El 41 | 42 | Cx : Set1 43 | Cx = El -> Set 44 | 45 | isTrue : Ty -> Cx -> Set 46 | isTrue a tc = tc (mkTrue a) 47 | 48 | isIndiv : Indiv -> Cx -> Set 49 | isIndiv x tc = tc (mkIndiv x) 50 | 51 | 52 | -- Terms 53 | 54 | module M where 55 | infixl 2 _$$_ 56 | infixl 1 _$_ 57 | data Tm (tc : Cx) : Ty -> Set where 58 | var : forall {a} -> isTrue a tc -> Tm tc a 59 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 60 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 61 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 62 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 63 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 64 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 65 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 66 | case' : forall {a b c} -> Tm tc (a || b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 67 | pi' : forall {p} -> (forall {x} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p) 68 | _$$_ : forall {p x} -> Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x) 69 | sig' : forall {p x} -> isIndiv x tc -> Tm tc (p x) -> Tm tc (EXISTS p) 70 | split' : forall {p x a} -> Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a 71 | 72 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 73 | lam'' f = lam' \x -> f (var x) 74 | 75 | case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 76 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 77 | 78 | split'' : forall {tc p x a} -> Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a 79 | split'' x f = split' x \y -> f (var y) 80 | 81 | syntax lam'' (\a -> b) = lam a => b 82 | syntax pair' x y = [ x , y ] 83 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 84 | syntax pi' (\x -> px) = pi x => px 85 | syntax sig' x px = [ x ,, px ] 86 | syntax split'' x (\y -> z) = split x as y => z 87 | 88 | Thm : Ty -> Set1 89 | Thm a = forall {tc} -> Tm tc a 90 | open M public 91 | -------------------------------------------------------------------------------- /src/Pi/M.idr: -------------------------------------------------------------------------------- 1 | -- Minimal logic, PHOAS approach, initial encoding 2 | 3 | module Pi.M 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | data Indiv : Type where 11 | TODO : Indiv 12 | 13 | Ty : Type 14 | 15 | Pred : Type 16 | Pred = Indiv -> Ty 17 | 18 | infixl 2 :&& 19 | infixl 1 :|| 20 | infixr 0 :=> 21 | data Ty : Type where 22 | UNIT : Ty 23 | (:=>) : Ty -> Ty -> Ty 24 | (:&&) : Ty -> Ty -> Ty 25 | (:||) : Ty -> Ty -> Ty 26 | FALSE : Ty 27 | FORALL : Pred -> Ty 28 | EXISTS : Pred -> Ty 29 | 30 | infixr 0 :<=> 31 | (:<=>) : Ty -> Ty -> Ty 32 | (:<=>) a b = (a :=> b) :&& (b :=> a) 33 | 34 | NOT : Ty -> Ty 35 | NOT a = a :=> FALSE 36 | 37 | TRUE : Ty 38 | TRUE = FALSE :=> FALSE 39 | 40 | 41 | -- Context and truth judgement 42 | 43 | data El : Type where 44 | mkTrue : Ty -> El 45 | mkIndiv : Indiv -> El 46 | 47 | Cx : Type 48 | Cx = El -> Type 49 | 50 | isTrue : Ty -> Cx -> Type 51 | isTrue a tc = tc (mkTrue a) 52 | 53 | isIndiv : Indiv -> Cx -> Type 54 | isIndiv x tc = tc (mkIndiv x) 55 | 56 | 57 | -- Terms 58 | 59 | infixl 2 :$$ 60 | infixl 1 :$ 61 | 62 | data Tm : Cx -> Ty -> Type where 63 | var : isTrue a tc -> Tm tc a 64 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 65 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 66 | pair : Tm tc a -> Tm tc b -> Tm tc (a :&& b) 67 | fst : Tm tc (a :&& b) -> Tm tc a 68 | snd : Tm tc (a :&& b) -> Tm tc b 69 | left : Tm tc a -> Tm tc (a :|| b) 70 | right : Tm tc b -> Tm tc (a :|| b) 71 | case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 72 | pi' : ({x : Indiv} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p) 73 | (:$$) : Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x) 74 | sig : isIndiv x tc -> Tm tc (p x) -> Tm tc (EXISTS p) 75 | split' : Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a 76 | 77 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 78 | lam'' f = lam' $ \x => f (var x) 79 | 80 | case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 81 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 82 | 83 | split'' : Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a 84 | split'' x f = split' x $ \y => f (var y) 85 | 86 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 87 | syntax "[" [a] "," [b] "]" = pair a b 88 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 89 | syntax "pi" {x} ":=>" [y] = pi' (\x => y) 90 | syntax "[" [x] ",," [y] "]" = sig x y 91 | syntax "split" [x] as {y} ":=>" [z] = split'' x (\y => z) 92 | 93 | Thm : Ty -> Type 94 | Thm a = {tc : Cx} -> Tm tc a 95 | -------------------------------------------------------------------------------- /src/Pi/Mp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, PHOAS approach, initial encoding 2 | 3 | module Pi.Mp where 4 | 5 | 6 | -- Types 7 | 8 | infixl 2 _&&_ 9 | infixl 1 _||_ 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | _&&_ : Ty -> Ty -> Ty 15 | _||_ : Ty -> Ty -> Ty 16 | FALSE : Ty 17 | 18 | infixr 0 _<=>_ 19 | _<=>_ : Ty -> Ty -> Ty 20 | a <=> b = (a => b) && (b => a) 21 | 22 | NOT : Ty -> Ty 23 | NOT a = a => FALSE 24 | 25 | TRUE : Ty 26 | TRUE = FALSE => FALSE 27 | 28 | 29 | -- Context and truth judgement 30 | 31 | Cx : Set1 32 | Cx = Ty -> Set 33 | 34 | isTrue : Ty -> Cx -> Set 35 | isTrue a tc = tc a 36 | 37 | 38 | -- Terms 39 | 40 | module Mp where 41 | infixl 1 _$_ 42 | data Tm (tc : Cx) : Ty -> Set where 43 | var : forall {a} -> isTrue a tc -> Tm tc a 44 | lam' : forall {a b} -> (isTrue a tc -> Tm tc b) -> Tm tc (a => b) 45 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 46 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 47 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 48 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 49 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 50 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 51 | case' : forall {a b c} -> Tm tc (a || b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 52 | 53 | lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b) 54 | lam'' f = lam' \x -> f (var x) 55 | 56 | case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 57 | case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y)) 58 | 59 | syntax lam'' (\a -> b) = lam a => b 60 | syntax pair' x y = [ x , y ] 61 | syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2 62 | 63 | Thm : Ty -> Set1 64 | Thm a = forall {tc} -> Tm tc a 65 | open Mp public 66 | 67 | 68 | -- Example theorems 69 | 70 | c1 : forall {a b} -> Thm (a && b <=> b && a) 71 | c1 = 72 | [ lam xy => [ snd xy , fst xy ] 73 | , lam yx => [ snd yx , fst yx ] 74 | ] 75 | 76 | c2 : forall {a b} -> Thm (a || b <=> b || a) 77 | c2 = 78 | [ lam xy => 79 | case xy 80 | of x => right x 81 | or y => left y 82 | , lam yx => 83 | case yx 84 | of y => right y 85 | or x => left x 86 | ] 87 | 88 | i1 : forall {a} -> Thm (a && a <=> a) 89 | i1 = 90 | [ lam xx => fst xx 91 | , lam x => [ x , x ] 92 | ] 93 | 94 | i2 : forall {a} -> Thm (a || a <=> a) 95 | i2 = 96 | [ lam xx => 97 | case xx 98 | of x => x 99 | or x => x 100 | , lam x => left x 101 | ] 102 | 103 | l3 : forall {a} -> Thm ((a => a) <=> TRUE) 104 | l3 = 105 | [ lam _ => lam nt => nt 106 | , lam _ => lam x => x 107 | ] 108 | 109 | l1 : forall {a b c} -> Thm (a && (b && c) <=> (a && b) && c) 110 | l1 = 111 | [ lam xyz => 112 | (let yz = snd xyz in 113 | [ [ fst xyz , fst yz ] , snd yz ]) 114 | , lam xyz => 115 | (let xy = fst xyz in 116 | [ fst xy , [ snd xy , snd xyz ] ]) 117 | ] 118 | 119 | l2 : forall {a} -> Thm (a && TRUE <=> a) 120 | l2 = 121 | [ lam xt => fst xt 122 | , lam x => [ x , lam nt => nt ] 123 | ] 124 | 125 | l4 : forall {a b c} -> Thm (a && (b || c) <=> (a && b) || (a && c)) 126 | l4 = 127 | [ lam xyz => 128 | (let x = fst xyz in 129 | case snd xyz 130 | of y => left [ x , y ] 131 | or z => right [ x , z ]) 132 | , lam xyxz => 133 | case xyxz 134 | of xy => [ fst xy , left (snd xy) ] 135 | or xz => [ fst xz , right (snd xz) ] 136 | ] 137 | 138 | l6 : forall {a b c} -> Thm (a || (b && c) <=> (a || b) && (a || c)) 139 | l6 = 140 | [ lam xyz => 141 | case xyz 142 | of x => [ left x , left x ] 143 | or yz => [ right (fst yz) , right (snd yz) ] 144 | , lam xyxz => 145 | case fst xyxz 146 | of x => left x 147 | or y => 148 | case snd xyxz 149 | of x => left x 150 | or z => right [ y , z ] 151 | ] 152 | 153 | l7 : forall {a} -> Thm (a || TRUE <=> TRUE) 154 | l7 = 155 | [ lam _ => lam nt => nt 156 | , lam t => right t 157 | ] 158 | 159 | l9 : forall {a b c} -> Thm (a || (b || c) <=> (a || b) || c) 160 | l9 = 161 | [ lam xyz => 162 | case xyz 163 | of x => left (left x) 164 | or yz => 165 | case yz 166 | of y => left (right y) 167 | or z => right z 168 | , lam xyz => 169 | case xyz 170 | of xy => 171 | case xy 172 | of x => left x 173 | or y => right (left y) 174 | or z => right (right z) 175 | ] 176 | 177 | l11 : forall {a b c} -> Thm ((a => (b && c)) <=> (a => b) && (a => c)) 178 | l11 = 179 | [ lam xyz => 180 | [ lam x => fst (xyz $ x) 181 | , lam x => snd (xyz $ x) 182 | ] 183 | , lam xyxz => 184 | lam x => [ fst xyxz $ x , snd xyxz $ x ] 185 | ] 186 | 187 | l12 : forall {a} -> Thm ((a => TRUE) <=> TRUE) 188 | l12 = 189 | [ lam _ => lam nt => nt 190 | , lam t => lam _ => t 191 | ] 192 | 193 | l13 : forall {a b c} -> Thm ((a => (b => c)) <=> ((a && b) => c)) 194 | l13 = 195 | [ lam xyz => 196 | lam xy => xyz $ fst xy $ snd xy 197 | , lam xyz => 198 | lam x => 199 | lam y => xyz $ [ x , y ] 200 | ] 201 | 202 | l16 : forall {a b c} -> Thm (((a && b) => c) <=> (a => (b => c))) 203 | l16 = 204 | [ lam xyz => 205 | lam x => 206 | lam y => xyz $ [ x , y ] 207 | , lam xyz => 208 | lam xy => xyz $ fst xy $ snd xy 209 | ] 210 | 211 | l17 : forall {a} -> Thm ((TRUE => a) <=> a) 212 | l17 = 213 | [ lam tx => tx $ (lam nt => nt) 214 | , lam x => lam _ => x 215 | ] 216 | 217 | l19 : forall {a b c} -> Thm (((a || b) => c) <=> (a => c) && (b => c)) 218 | l19 = 219 | [ lam xyz => 220 | [ lam x => xyz $ left x 221 | , lam y => xyz $ right y 222 | ] 223 | , lam xzyz => 224 | lam xy => 225 | case xy 226 | of x => fst xzyz $ x 227 | or y => snd xzyz $ y 228 | ] 229 | -------------------------------------------------------------------------------- /src/Pi/Mp.hs: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, PHOAS approach, initial encoding 2 | 3 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, Rank2Types, Safe, TypeOperators #-} 4 | 5 | module Pi.Mp where 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty :: * where 14 | UNIT :: Ty 15 | (:=>) :: Ty -> Ty -> Ty 16 | (:&&) :: Ty -> Ty -> Ty 17 | (:||) :: Ty -> Ty -> Ty 18 | FALSE :: Ty 19 | 20 | infixr 0 :<=> 21 | type a :<=> b = (a :=> b) :&& (b :=> a) 22 | 23 | type NOT a = a :=> FALSE 24 | 25 | type TRUE = FALSE :=> FALSE 26 | 27 | 28 | -- Context and truth judgement 29 | 30 | -- NOTE: Haskell does not support kind synonyms 31 | -- type Cx = Ty -> * 32 | 33 | type IsTrue (a :: Ty) (tc :: Ty -> *) = tc a 34 | 35 | 36 | -- Terms 37 | 38 | infixl 1 :$ 39 | data Tm :: (Ty -> *) -> Ty -> * where 40 | Var :: IsTrue a tc -> Tm tc a 41 | Lam :: (IsTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 42 | (:$) :: Tm tc (a :=> b) -> Tm tc a -> Tm tc b 43 | Pair :: Tm tc a -> Tm tc b -> Tm tc (a :&& b) 44 | Fst :: Tm tc (a :&& b) -> Tm tc a 45 | Snd :: Tm tc (a :&& b) -> Tm tc b 46 | Left' :: Tm tc a -> Tm tc (a :|| b) 47 | Right' :: Tm tc b -> Tm tc (a :|| b) 48 | Match :: Tm tc (a :|| b) -> (IsTrue a tc -> Tm tc c) -> (IsTrue b tc -> Tm tc c) -> Tm tc c 49 | 50 | var :: IsTrue a tc -> Tm tc a 51 | var = Var 52 | 53 | lam :: (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 54 | lam f = Lam $ \x -> f (var x) 55 | 56 | pair :: (Tm tc a, Tm tc b) -> Tm tc (a :&& b) 57 | pair (a, b) = Pair a b 58 | 59 | fst' :: Tm tc (a :&& b) -> Tm tc a 60 | fst' = Fst 61 | 62 | snd' :: Tm tc (a :&& b) -> Tm tc b 63 | snd' = Snd 64 | 65 | left :: Tm tc a -> Tm tc (a :|| b) 66 | left = Left' 67 | 68 | right :: Tm tc b -> Tm tc (a :|| b) 69 | right = Right' 70 | 71 | case' :: Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 72 | case' xy f g = Match xy (\x -> f (var x)) (\y -> g (var y)) 73 | 74 | type Thm a = forall tc. Tm tc a 75 | 76 | 77 | -- Example theorems 78 | 79 | c1 :: Thm (a :&& b :<=> b :&& a) 80 | c1 = 81 | pair 82 | ( lam $ \xy -> pair ( snd' xy , fst' xy ) 83 | , lam $ \yx -> pair ( snd' yx , fst' yx ) 84 | ) 85 | 86 | c2 :: Thm (a :|| b :<=> b :|| a) 87 | c2 = 88 | pair 89 | ( lam $ \xy -> 90 | case' xy 91 | (\x -> right x) 92 | (\y -> left y) 93 | , lam $ \yx -> 94 | case' yx 95 | (\y -> right y) 96 | (\x -> left x) 97 | ) 98 | 99 | i1 :: Thm (a :&& a :<=> a) 100 | i1 = 101 | pair 102 | ( lam $ \xx -> fst' xx 103 | , lam $ \x -> pair ( x , x ) 104 | ) 105 | 106 | i2 :: Thm (a :|| a :<=> a) 107 | i2 = 108 | pair 109 | ( lam $ \xx -> 110 | case' xx 111 | (\x -> x) 112 | (\x -> x) 113 | , lam $ \x -> left x 114 | ) 115 | 116 | l3 :: Thm ((a :=> a) :<=> TRUE) 117 | l3 = 118 | pair 119 | ( lam $ \_ -> lam $ \nt -> nt 120 | , lam $ \_ -> lam $ \x -> x 121 | ) 122 | 123 | l1 :: Thm (a :&& (b :&& c) :<=> (a :&& b) :&& c) 124 | l1 = 125 | pair 126 | ( lam $ \xyz -> 127 | let yz = snd' xyz in 128 | pair 129 | ( pair ( fst' xyz , fst' yz ) 130 | , snd' yz 131 | ) 132 | , lam $ \xyz -> 133 | let xy = fst' xyz in 134 | pair 135 | ( fst' xy 136 | , pair ( snd' xy , snd' xyz ) 137 | )) 138 | 139 | l2 :: Thm (a :&& TRUE :<=> a) 140 | l2 = 141 | pair 142 | ( lam $ \xt -> fst' xt 143 | , lam $ \x -> pair ( x , lam $ \nt -> nt ) 144 | ) 145 | 146 | l4 :: Thm (a :&& (b :|| c) :<=> (a :&& b) :|| (a :&& c)) 147 | l4 = 148 | pair 149 | ( lam $ \xyz -> 150 | let x = fst' xyz in 151 | case' (snd' xyz) 152 | (\y -> left (pair ( x , y ))) 153 | (\z -> right (pair ( x , z ))) 154 | , lam $ \xyxz -> 155 | case' xyxz 156 | (\xy -> pair ( fst' xy , left (snd' xy) )) 157 | (\xz -> pair ( fst' xz , right (snd' xz) )) 158 | ) 159 | 160 | l6 :: Thm (a :|| (b :&& c) :<=> (a :|| b) :&& (a :|| c)) 161 | l6 = 162 | pair 163 | ( lam $ \xyz -> 164 | case' xyz 165 | (\x -> pair ( left x , left x )) 166 | (\yz -> pair ( right (fst' yz) , right (snd' yz) )) 167 | , lam $ \xyxz -> 168 | case' (fst' xyxz) 169 | (\x -> left x) 170 | (\y -> 171 | case' (snd' xyxz) 172 | (\x -> left x) 173 | (\z -> right (pair ( y , z )))) 174 | ) 175 | 176 | l7 :: Thm (a :|| TRUE :<=> TRUE) 177 | l7 = 178 | pair 179 | ( lam $ \_ -> lam $ \nt -> nt 180 | , lam $ \t -> right t 181 | ) 182 | 183 | l9 :: Thm (a :|| (b :|| c) :<=> (a :|| b) :|| c) 184 | l9 = 185 | pair 186 | ( lam $ \xyz -> 187 | case' xyz 188 | (\x -> left (left x)) 189 | (\yz -> 190 | case' yz 191 | (\y -> left (right y)) 192 | (\z -> right z)) 193 | , lam $ \xyz -> 194 | case' xyz 195 | (\xy -> 196 | case' xy 197 | (\x -> left x) 198 | (\y -> right (left y))) 199 | (\z -> right (right z)) 200 | ) 201 | 202 | l11 :: Thm ((a :=> (b :&& c)) :<=> (a :=> b) :&& (a :=> c)) 203 | l11 = 204 | pair 205 | ( lam $ \xyz -> 206 | pair 207 | ( lam $ \x -> fst' (xyz :$ x) 208 | , lam $ \x -> snd' (xyz :$ x) 209 | ) 210 | , lam $ \xyxz -> 211 | lam $ \x -> pair ( fst' xyxz :$ x , snd' xyxz :$ x ) 212 | ) 213 | 214 | l12 :: Thm ((a :=> TRUE) :<=> TRUE) 215 | l12 = 216 | pair 217 | ( lam $ \_ -> lam $ \nt -> nt 218 | , lam $ \t -> lam $ \_ -> t 219 | ) 220 | 221 | l13 :: Thm ((a :=> (b :=> c)) :<=> ((a :&& b) :=> c)) 222 | l13 = 223 | pair 224 | ( lam $ \xyz -> 225 | lam $ \xy -> xyz :$ fst' xy :$ snd' xy 226 | , lam $ \xyz -> 227 | lam $ \x -> 228 | lam $ \y -> xyz :$ pair ( x , y ) 229 | ) 230 | 231 | l16 :: Thm (((a :&& b) :=> c) :<=> (a :=> (b :=> c))) 232 | l16 = 233 | pair 234 | ( lam $ \xyz -> 235 | lam $ \x -> 236 | lam $ \y -> xyz :$ pair ( x , y ) 237 | , lam $ \xyz -> 238 | lam $ \xy -> xyz :$ fst' xy :$ snd' xy 239 | ) 240 | 241 | l17 :: Thm ((TRUE :=> a) :<=> a) 242 | l17 = 243 | pair 244 | ( lam $ \tx -> tx :$ (lam $ \nt -> nt) 245 | , lam $ \x -> lam $ \_ -> x 246 | ) 247 | 248 | l19 :: Thm (((a :|| b) :=> c) :<=> (a :=> c) :&& (b :=> c)) 249 | l19 = 250 | pair 251 | ( lam $ \xyz -> 252 | pair 253 | ( lam $ \x -> xyz :$ left x 254 | , lam $ \y -> xyz :$ right y 255 | ) 256 | , lam $ \xzyz -> 257 | lam $ \xy -> 258 | case' xy 259 | (\x -> fst' xzyz :$ x) 260 | (\y -> snd' xzyz :$ y) 261 | ) 262 | -------------------------------------------------------------------------------- /src/Pi/Mp.idr: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, PHOAS approach, initial encoding 2 | 3 | module Pi.Mp 4 | 5 | %default total 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 :&& 11 | infixl 1 :|| 12 | infixr 0 :=> 13 | data Ty : Type where 14 | UNIT : Ty 15 | (:=>) : Ty -> Ty -> Ty 16 | (:&&) : Ty -> Ty -> Ty 17 | (:||) : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 :<=> 21 | (:<=>) : Ty -> Ty -> Ty 22 | (:<=>) a b = (a :=> b) :&& (b :=> a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a :=> FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE :=> FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Type 34 | Cx = Ty -> Type 35 | 36 | isTrue : Ty -> Cx -> Type 37 | isTrue a tc = tc a 38 | 39 | 40 | -- Terms 41 | 42 | infixl 1 :$ 43 | data Tm : Cx -> Ty -> Type where 44 | var : isTrue a tc -> Tm tc a 45 | lam' : (isTrue a tc -> Tm tc b) -> Tm tc (a :=> b) 46 | (:$) : Tm tc (a :=> b) -> Tm tc a -> Tm tc b 47 | pair : Tm tc a -> Tm tc b -> Tm tc (a :&& b) 48 | fst : Tm tc (a :&& b) -> Tm tc a 49 | snd : Tm tc (a :&& b) -> Tm tc b 50 | left : Tm tc a -> Tm tc (a :|| b) 51 | right : Tm tc b -> Tm tc (a :|| b) 52 | case' : Tm tc (a :|| b) -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c 53 | 54 | lam'' : (Tm tc a -> Tm tc b) -> Tm tc (a :=> b) 55 | lam'' f = lam' $ \x => f (var x) 56 | 57 | case'' : Tm tc (a :|| b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c 58 | case'' xy f g = case' xy (\x => f (var x)) (\y => g (var y)) 59 | 60 | syntax "lam" {a} ":=>" [b] = lam'' (\a => b) 61 | syntax "[" [a] "," [b] "]" = pair a b 62 | syntax "case" [ab] "of" {a} ":=>" [c1] or {b} ":=>" [c2] = case'' ab (\a => c1) (\b => c2) 63 | 64 | Thm : Ty -> Type 65 | Thm a = {tc : Cx} -> Tm tc a 66 | 67 | 68 | -- Example theorems 69 | 70 | c1 : Thm (a :&& b :<=> b :&& a) 71 | c1 = 72 | [ lam xy :=> [ snd xy , fst xy ] 73 | , lam yx :=> [ snd yx , fst yx ] 74 | ] 75 | 76 | c2 : Thm (a :|| b :<=> b :|| a) 77 | c2 = 78 | [ lam xy :=> 79 | case xy 80 | of x :=> right x 81 | or y :=> left y 82 | , lam yx :=> 83 | case yx 84 | of y :=> right y 85 | or x :=> left x 86 | ] 87 | 88 | i1 : Thm (a :&& a :<=> a) 89 | i1 = 90 | [ lam xx :=> fst xx 91 | , lam x :=> [ x , x ] 92 | ] 93 | 94 | i2 : Thm (a :|| a :<=> a) 95 | i2 = 96 | [ lam xx :=> 97 | case xx 98 | of x :=> x 99 | or x :=> x 100 | , lam x :=> left x 101 | ] 102 | 103 | l3 : Thm ((a :=> a) :<=> TRUE) 104 | l3 = 105 | [ lam x :=> lam nt :=> nt 106 | , lam b :=> lam x :=> x 107 | ] 108 | 109 | l1 : Thm (a :&& (b :&& c) :<=> (a :&& b) :&& c) 110 | l1 = 111 | [ lam xyz :=> 112 | (let yz = snd xyz in 113 | [ [ fst xyz , fst yz ] , snd yz ]) 114 | , lam xyz :=> 115 | (let xy = fst xyz in 116 | [ fst xy , [ snd xy , snd xyz ] ]) 117 | ] 118 | 119 | l2 : Thm (a :&& TRUE :<=> a) 120 | l2 = 121 | [ lam xt :=> fst xt 122 | , lam x :=> [ x , lam nt :=> nt ] 123 | ] 124 | 125 | l4 : Thm (a :&& (b :|| c) :<=> (a :&& b) :|| (a :&& c)) 126 | l4 = 127 | [ lam xyz :=> 128 | (let x = fst xyz in 129 | case snd xyz 130 | of y :=> left [ x , y ] 131 | or z :=> right [ x , z ]) 132 | , lam xyxz :=> 133 | case xyxz 134 | of xy :=> ([ fst xy , left (snd xy) ]) 135 | or xz :=> [ fst xz , right (snd xz) ] 136 | ] 137 | 138 | l6 : Thm (a :|| (b :&& c) :<=> (a :|| b) :&& (a :|| c)) 139 | l6 = 140 | [ lam xyz :=> 141 | case xyz 142 | of x :=> ([ left x , left x ]) 143 | or yz :=> [ right (fst yz) , right (snd yz) ] 144 | , lam xyxz :=> 145 | case fst xyxz 146 | of x :=> left x 147 | or y :=> 148 | case snd xyxz 149 | of x :=> left x 150 | or z :=> right [ y , z ] 151 | ] 152 | 153 | l7 : Thm (a :|| TRUE :<=> TRUE) 154 | l7 = 155 | [ lam xt :=> lam nt :=> nt 156 | , lam t :=> right t 157 | ] 158 | 159 | l9 : Thm (a :|| (b :|| c) :<=> (a :|| b) :|| c) 160 | l9 = 161 | [ lam xyz :=> 162 | case xyz 163 | of x :=> left (left x) 164 | or yz :=> 165 | case yz 166 | of y :=> left (right y) 167 | or z :=> right z 168 | , lam xyz :=> 169 | case xyz 170 | of xy :=> 171 | case xy 172 | of x :=> left x 173 | or y :=> right (left y) 174 | or z :=> right (right z) 175 | ] 176 | 177 | l11 : Thm ((a :=> (b :&& c)) :<=> (a :=> b) :&& (a :=> c)) 178 | l11 = 179 | [ lam xyz :=> 180 | [ lam x :=> fst (xyz :$ x) 181 | , lam x :=> snd (xyz :$ x) 182 | ] 183 | , lam xyxz :=> 184 | lam x :=> [ fst xyxz :$ x , snd xyxz :$ x ] 185 | ] 186 | 187 | l12 : Thm ((a :=> TRUE) :<=> TRUE) 188 | l12 = 189 | [ lam f :=> lam nt :=> nt 190 | , lam t :=> lam f :=> t 191 | ] 192 | 193 | l13 : Thm ((a :=> (b :=> c)) :<=> ((a :&& b) :=> c)) 194 | l13 = 195 | [ lam xyz :=> 196 | lam xy :=> xyz :$ fst xy :$ snd xy 197 | , lam xyz :=> 198 | lam x :=> 199 | lam y :=> xyz :$ [ x , y ] 200 | ] 201 | 202 | l16 : Thm (((a :&& b) :=> c) :<=> (a :=> (b :=> c))) 203 | l16 = 204 | [ lam xyz :=> 205 | lam x :=> 206 | lam y :=> xyz :$ [ x , y ] 207 | , lam xyz :=> 208 | lam xy :=> xyz :$ fst xy :$ snd xy 209 | ] 210 | 211 | l17 : Thm ((TRUE :=> a) :<=> a) 212 | l17 = 213 | [ lam tx :=> tx :$ (lam nt :=> nt) 214 | , lam x :=> lam tx :=> x 215 | ] 216 | 217 | l19 : Thm (((a :|| b) :=> c) :<=> (a :=> c) :&& (b :=> c)) 218 | l19 = 219 | [ lam xyz :=> 220 | [ lam x :=> xyz :$ left x 221 | , lam y :=> xyz :$ right y 222 | ] 223 | , lam xzyz :=> 224 | lam xy :=> 225 | case xy 226 | of x :=> fst xzyz :$ x 227 | or y :=> snd xzyz :$ y 228 | ] 229 | -------------------------------------------------------------------------------- /src/Vi/ArrMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational logic, vector-based de Bruijn approach, initial encoding 2 | 3 | module Vi.ArrMp where 4 | 5 | open import Lib using (Nat; suc; _+_; Fin; fin; Vec; _,_; proj; VMem; mem) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | 15 | 16 | -- Context and truth judgement 17 | 18 | Cx : Nat -> Set 19 | Cx n = Vec Ty n 20 | 21 | isTrue : forall {tn} -> Ty -> Fin tn -> Cx tn -> Set 22 | isTrue a i tc = VMem a i tc 23 | 24 | 25 | -- Terms 26 | 27 | module ArrMp where 28 | infixr 0 lam=>_ 29 | infixl 1 _$_ 30 | data Tm {tn} (tc : Cx tn) : Ty -> Set where 31 | var : forall {a i} -> isTrue a i tc -> Tm tc a 32 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 33 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 34 | 35 | v : forall {tn} (k : Nat) {tc : Cx (suc (k + tn))} -> Tm tc (proj tc (fin k)) 36 | v i = var (mem i) 37 | 38 | Thm : Ty -> Set 39 | Thm a = forall {tn} {tc : Cx tn} -> Tm tc a 40 | open ArrMp public 41 | 42 | 43 | -- Example theorems 44 | 45 | aI : forall {a} -> Thm (a => a) 46 | aI = 47 | lam=> v 0 48 | 49 | aK : forall {a b} -> Thm (a => b => a) 50 | aK = 51 | lam=> 52 | lam=> v 1 53 | 54 | aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c) 55 | aS = 56 | lam=> 57 | lam=> 58 | lam=> v 2 $ v 0 $ (v 1 $ v 0) 59 | 60 | tSKK : forall {a} -> Thm (a => a) 61 | tSKK {a = a} = 62 | aS {b = a => a} $ aK $ aK 63 | -------------------------------------------------------------------------------- /src/Vi/BoxMp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal implicational modal logic, vector-based de Bruijn approach, initial encoding 2 | 3 | module Vi.BoxMp where 4 | 5 | open import Lib using (Nat; suc; _+_; Fin; fin; Vec; []; _,_; proj; VMem; mem) 6 | 7 | 8 | -- Types 9 | 10 | infixr 0 _=>_ 11 | data Ty : Set where 12 | UNIT : Ty 13 | _=>_ : Ty -> Ty -> Ty 14 | BOX : Ty -> Ty 15 | 16 | 17 | -- Context and truth/validity judgements 18 | 19 | Cx : Nat -> Set 20 | Cx n = Vec Ty n 21 | 22 | isTrue : forall {tn} -> Ty -> Fin tn -> Cx tn -> Set 23 | isTrue a i tc = VMem a i tc 24 | 25 | isValid : forall {vn} -> Ty -> Fin vn -> Cx vn -> Set 26 | isValid a i vc = VMem a i vc 27 | 28 | 29 | -- Terms 30 | 31 | module BoxMp where 32 | infixl 1 _$_ 33 | infixr 0 lam=>_ 34 | data Tm {vn tn} (vc : Cx vn) (tc : Cx tn) : Ty -> Set where 35 | var : forall {a i} -> isTrue a i tc -> Tm vc tc a 36 | lam=>_ : forall {a b} -> Tm vc (tc , a) b -> Tm vc tc (a => b) 37 | _$_ : forall {a b} -> Tm vc tc (a => b) -> Tm vc tc a -> Tm vc tc b 38 | var# : forall {a i} -> isValid a i vc -> Tm vc tc a 39 | box : forall {a} -> Tm vc [] a -> Tm vc tc (BOX a) 40 | unbox'' : forall {a b} -> Tm vc tc (BOX a) -> Tm (vc , a) tc b -> Tm vc tc b 41 | 42 | syntax unbox'' x' x = unbox x' => x 43 | 44 | v : forall {vn tn} {vc : Cx vn} (k : Nat) {tc : Cx (suc (k + tn))} -> Tm vc tc (proj tc (fin k)) 45 | v i = var (mem i) 46 | 47 | v# : forall {vn tn} (k : Nat) {vc : Cx (suc (k + vn))} {tc : Cx tn} -> Tm vc tc (proj vc (fin k)) 48 | v# i = var# (mem i) 49 | 50 | Thm : Ty -> Set 51 | Thm a = forall {vn tn} {vc : Cx vn} {tc : Cx tn} -> Tm vc tc a 52 | open BoxMp public 53 | 54 | 55 | -- Example theorems 56 | 57 | rNec : forall {a} -> Thm a -> Thm (BOX a) 58 | rNec x = 59 | box x 60 | 61 | aK : forall {a b} -> Thm (BOX (a => b) => BOX a => BOX b) 62 | aK = 63 | lam=> 64 | lam=> 65 | (unbox v 1 => 66 | unbox v 0 => 67 | box (v# 1 $ v# 0)) 68 | 69 | aT : forall {a} -> Thm (BOX a => a) 70 | aT = 71 | lam=> 72 | (unbox v 0 => v# 0) 73 | 74 | a4 : forall {a} -> Thm (BOX a => BOX (BOX a)) 75 | a4 = 76 | lam=> 77 | (unbox v 0 => box (box (v# 0))) 78 | 79 | t1 : forall {a} -> Thm (a => BOX (a => a)) 80 | t1 = 81 | lam=> box (lam=> (v 0)) 82 | -------------------------------------------------------------------------------- /src/Vi/Cp.agda: -------------------------------------------------------------------------------- 1 | -- Classical propositional logic, vector-based de Bruijn approach, initial encoding 2 | 3 | module Vi.Cp where 4 | 5 | open import Lib using (Nat; suc; _+_; Fin; fin; Vec; _,_; proj; VMem; mem) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Nat -> Set 34 | Cx n = Vec Ty n 35 | 36 | isTrue : forall {tn} -> Ty -> Fin tn -> Cx tn -> Set 37 | isTrue a i tc = VMem a i tc 38 | 39 | 40 | -- Terms 41 | 42 | module Cp where 43 | infixl 1 _$_ 44 | infixr 0 lam=>_ 45 | infixr 0 abort=>_ 46 | data Tm {tn} (tc : Cx tn) : Ty -> Set where 47 | var : forall {a i} -> isTrue a i tc -> Tm tc a 48 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 49 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 50 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 51 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 52 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 53 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 54 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 55 | case' : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c 56 | abort=>_ : forall {a} -> Tm (tc , NOT a) FALSE -> Tm tc a 57 | 58 | syntax pair' x y = [ x , y ] 59 | syntax case' xy x y = case xy => x => y 60 | 61 | v : forall {tn} (k : Nat) {tc : Cx (suc (k + tn))} -> Tm tc (proj tc (fin k)) 62 | v i = var (mem i) 63 | 64 | Thm : Ty -> Set 65 | Thm a = forall {tn} {tc : Cx tn} -> Tm tc a 66 | open Cp public 67 | -------------------------------------------------------------------------------- /src/Vi/Ip.agda: -------------------------------------------------------------------------------- 1 | -- Intuitionistic propositional logic, vector-based de Bruijn approach, initial encoding 2 | 3 | module Vi.Ip where 4 | 5 | open import Lib using (Nat; suc; _+_; Fin; fin; Vec; _,_; proj; VMem; mem) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Nat -> Set 34 | Cx n = Vec Ty n 35 | 36 | isTrue : forall {tn} -> Ty -> Fin tn -> Cx tn -> Set 37 | isTrue a i tc = VMem a i tc 38 | 39 | 40 | -- Terms 41 | 42 | module Ip where 43 | infixl 1 _$_ 44 | infixr 0 lam=>_ 45 | data Tm {tn} (tc : Cx tn) : Ty -> Set where 46 | var : forall {a i} -> isTrue a i tc -> Tm tc a 47 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 48 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 49 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 50 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 51 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 52 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 53 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 54 | case' : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c 55 | abort : forall {a} -> Tm tc FALSE -> Tm tc a 56 | 57 | syntax pair' x y = [ x , y ] 58 | syntax case' xy x y = case xy => x => y 59 | 60 | v : forall {tn} (k : Nat) {tc : Cx (suc (k + tn))} -> Tm tc (proj tc (fin k)) 61 | v i = var (mem i) 62 | 63 | Thm : Ty -> Set 64 | Thm a = forall {tn} {tc : Cx tn} -> Tm tc a 65 | open Ip public 66 | 67 | 68 | -- Example theorems 69 | 70 | t1 : forall {a b} -> Thm (a => NOT a => b) 71 | t1 = 72 | lam=> 73 | lam=> abort (v 0 $ v 1) 74 | 75 | t2 : forall {a b} -> Thm (NOT a => a => b) 76 | t2 = 77 | lam=> 78 | lam=> abort (v 1 $ v 0) 79 | 80 | t3 : forall {a} -> Thm (a => NOT (NOT a)) 81 | t3 = 82 | lam=> 83 | lam=> v 0 $ v 1 84 | 85 | t4 : forall {a} -> Thm (NOT a <=> NOT (NOT (NOT a))) 86 | t4 = 87 | [ lam=> 88 | lam=> v 0 $ v 1 89 | , lam=> 90 | lam=> v 1 $ (lam=> v 0 $ v 1) 91 | ] 92 | -------------------------------------------------------------------------------- /src/Vi/Mp.agda: -------------------------------------------------------------------------------- 1 | -- Minimal propositional logic, vector-based de Bruijn approach, initial encoding 2 | 3 | module Vi.Mp where 4 | 5 | open import Lib using (Nat; suc; _+_; Fin; fin; Vec; _,_; proj; VMem; mem) 6 | 7 | 8 | -- Types 9 | 10 | infixl 2 _&&_ 11 | infixl 1 _||_ 12 | infixr 0 _=>_ 13 | data Ty : Set where 14 | UNIT : Ty 15 | _=>_ : Ty -> Ty -> Ty 16 | _&&_ : Ty -> Ty -> Ty 17 | _||_ : Ty -> Ty -> Ty 18 | FALSE : Ty 19 | 20 | infixr 0 _<=>_ 21 | _<=>_ : Ty -> Ty -> Ty 22 | a <=> b = (a => b) && (b => a) 23 | 24 | NOT : Ty -> Ty 25 | NOT a = a => FALSE 26 | 27 | TRUE : Ty 28 | TRUE = FALSE => FALSE 29 | 30 | 31 | -- Context and truth judgement 32 | 33 | Cx : Nat -> Set 34 | Cx n = Vec Ty n 35 | 36 | isTrue : forall {tn} -> Ty -> Fin tn -> Cx tn -> Set 37 | isTrue a i tc = VMem a i tc 38 | 39 | 40 | -- Terms 41 | 42 | module Mp where 43 | infixl 1 _$_ 44 | infixr 0 lam=>_ 45 | data Tm {tn} (tc : Cx tn) : Ty -> Set where 46 | var : forall {a i} -> isTrue a i tc -> Tm tc a 47 | lam=>_ : forall {a b} -> Tm (tc , a) b -> Tm tc (a => b) 48 | _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b 49 | pair' : forall {a b} -> Tm tc a -> Tm tc b -> Tm tc (a && b) 50 | fst : forall {a b} -> Tm tc (a && b) -> Tm tc a 51 | snd : forall {a b} -> Tm tc (a && b) -> Tm tc b 52 | left : forall {a b} -> Tm tc a -> Tm tc (a || b) 53 | right : forall {a b} -> Tm tc b -> Tm tc (a || b) 54 | case' : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c 55 | 56 | syntax pair' x y = [ x , y ] 57 | syntax case' xy x y = case xy => x => y 58 | 59 | v : forall {tn} (k : Nat) {tc : Cx (suc (k + tn))} -> Tm tc (proj tc (fin k)) 60 | v i = var (mem i) 61 | 62 | Thm : Ty -> Set 63 | Thm a = forall {tn} {tc : Cx tn} -> Tm tc a 64 | open Mp public 65 | 66 | 67 | -- Example theorems 68 | 69 | c1 : forall {a b} -> Thm (a && b <=> b && a) 70 | c1 = 71 | [ lam=> [ snd (v 0) , fst (v 0) ] 72 | , lam=> [ snd (v 0) , fst (v 0) ] 73 | ] 74 | 75 | c2 : forall {a b} -> Thm (a || b <=> b || a) 76 | c2 = 77 | [ lam=> 78 | (case v 0 79 | => right (v 0) 80 | => left (v 0)) 81 | , lam=> 82 | (case v 0 83 | => right (v 0) 84 | => left (v 0)) 85 | ] 86 | 87 | i1 : forall {a} -> Thm (a && a <=> a) 88 | i1 = 89 | [ lam=> fst (v 0) 90 | , lam=> [ v 0 , v 0 ] 91 | ] 92 | 93 | i2 : forall {a} -> Thm (a || a <=> a) 94 | i2 = 95 | [ lam=> 96 | (case v 0 97 | => v 0 98 | => v 0) 99 | , lam=> left (v 0) 100 | ] 101 | 102 | l3 : forall {a} -> Thm ((a => a) <=> TRUE) 103 | l3 = 104 | [ lam=> lam=> v 0 105 | , lam=> lam=> v 0 106 | ] 107 | 108 | l1 : forall {a b c} -> Thm (a && (b && c) <=> (a && b) && c) 109 | l1 = 110 | [ lam=> 111 | [ [ fst (v 0) , fst (snd (v 0)) ] 112 | , snd (snd (v 0)) 113 | ] 114 | , lam=> 115 | [ fst (fst (v 0)) 116 | , [ snd (fst (v 0)) , snd (v 0) ] 117 | ] 118 | ] 119 | 120 | l2 : forall {a} -> Thm (a && TRUE <=> a) 121 | l2 = 122 | [ lam=> fst (v 0) 123 | , lam=> [ v 0 , lam=> v 0 ] 124 | ] 125 | 126 | l4 : forall {a b c} -> Thm (a && (b || c) <=> (a && b) || (a && c)) 127 | l4 = 128 | [ lam=> 129 | (case snd (v 0) 130 | => left [ fst (v 1) , v 0 ] 131 | => right [ fst (v 1) , v 0 ]) 132 | , lam=> 133 | (case v 0 134 | => [ fst (v 0) , left (snd (v 0)) ] 135 | => [ fst (v 0) , right (snd (v 0)) ]) 136 | ] 137 | 138 | l6 : forall {a b c} -> Thm (a || (b && c) <=> (a || b) && (a || c)) 139 | l6 = 140 | [ lam=> 141 | (case v 0 142 | => [ left (v 0) , left (v 0) ] 143 | => [ right (fst (v 0)) , right (snd (v 0)) ]) 144 | , lam=> 145 | (case fst (v 0) 146 | => left (v 0) 147 | => 148 | case snd (v 1) 149 | => left (v 0) 150 | => right [ v 1 , v 0 ]) 151 | ] 152 | 153 | l7 : forall {a} -> Thm (a || TRUE <=> TRUE) 154 | l7 = 155 | [ lam=> lam=> v 0 156 | , lam=> right (v 0) 157 | ] 158 | 159 | l9 : forall {a b c} -> Thm (a || (b || c) <=> (a || b) || c) 160 | l9 = 161 | [ lam=> 162 | (case v 0 163 | => left (left (v 0)) 164 | => 165 | case v 0 166 | => left (right (v 0)) 167 | => right (v 0)) 168 | , lam=> 169 | (case v 0 170 | => 171 | case v 0 172 | => left (v 0) 173 | => right (left (v 0)) 174 | => right (right (v 0))) 175 | ] 176 | 177 | l11 : forall {a b c} -> Thm ((a => (b && c)) <=> (a => b) && (a => c)) 178 | l11 = 179 | [ lam=> 180 | [ lam=> fst (v 1 $ v 0) 181 | , lam=> snd (v 1 $ v 0) 182 | ] 183 | , lam=> 184 | lam=> [ fst (v 1) $ v 0 , snd (v 1) $ v 0 ] 185 | ] 186 | 187 | l12 : forall {a} -> Thm ((a => TRUE) <=> TRUE) 188 | l12 = 189 | [ lam=> lam=> v 0 190 | , lam=> lam=> v 1 191 | ] 192 | 193 | l13 : forall {a b c} -> Thm ((a => (b => c)) <=> ((a && b) => c)) 194 | l13 = 195 | [ lam=> 196 | lam=> v 1 $ fst (v 0) $ snd (v 0) 197 | , lam=> 198 | lam=> 199 | lam=> v 2 $ [ v 1 , v 0 ] 200 | ] 201 | 202 | l16 : forall {a b c} -> Thm (((a && b) => c) <=> (a => (b => c))) 203 | l16 = 204 | [ lam=> 205 | lam=> 206 | lam=> v 2 $ [ v 1 , v 0 ] 207 | , lam=> 208 | lam=> v 1 $ fst (v 0) $ snd (v 0) 209 | ] 210 | 211 | l17 : forall {a} -> Thm ((TRUE => a) <=> a) 212 | l17 = 213 | [ lam=> v 0 $ (lam=> v 0) 214 | , lam=> lam=> v 1 215 | ] 216 | 217 | l19 : forall {a b c} -> Thm (((a || b) => c) <=> (a => c) && (b => c)) 218 | l19 = 219 | [ lam=> 220 | [ lam=> v 1 $ left (v 0) 221 | , lam=> v 1 $ right (v 0) 222 | ] 223 | , lam=> 224 | lam=> 225 | (case v 0 226 | => fst (v 2) $ (v 0) 227 | => snd (v 2) $ (v 0)) 228 | ] 229 | --------------------------------------------------------------------------------