├── .gitignore ├── arrowm ├── add.ml ├── common.ml ├── dune ├── init.ml ├── lambda.ml ├── mult.ml ├── pow.ml ├── tetra.ml └── up.ml ├── boardgames ├── builder.ml ├── burning_floor.ml ├── doors.ml ├── dune ├── hands.ml └── line.ml ├── chess ├── dune ├── problem.ml └── tour.ml ├── dune-project └── units ├── axiomatic.ml ├── dune └── si.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | -------------------------------------------------------------------------------- /arrowm/add.ml: -------------------------------------------------------------------------------- 1 | module B = Init 2 | 3 | 4 | module type t = B.t -> B.t 5 | module Zero = functor (Zero:B.t) -> Zero 6 | 7 | module S(N:t)(X:B.t) = B.S.M(N(X)) 8 | 9 | module type T = sig module type t end 10 | module TypeOf(X:sig module type t end) = struct 11 | module type t = sig 12 | module type t = X.t 13 | module M: t 14 | end 15 | end 16 | module Compose(X:B.t)(N:t)(M:t) = struct 17 | module type t = TypeOf(N(M(X))).t 18 | end 19 | 20 | module Op(N:t)(M:t)(X:B.t): module type of N(M(X)) = N(M(X)) 21 | module Fix(N:t) = N(B.Z) 22 | 23 | 24 | module One = S(Zero) 25 | module Two = S(One) 26 | module Four = Op(Two)(Two) 27 | module M4 = Fix(Four) 28 | 29 | module T = M4.M.A.A.A.A 30 | 31 | (* 32 | 33 | module type fty = functor(Zero:ty) -> 34 | sig 35 | module type nat 36 | module type t = Zero.t -> nat 37 | module M: t 38 | end 39 | 40 | 41 | module S(N:fty) = struct 42 | module type nat = sig 43 | module type t = sig module A: N.nat end 44 | module M: t 45 | end 46 | module type t = ty -> nat 47 | module M = functor (X:ty) -> struct 48 | module type t = sig module A:N.nat end 49 | module M: t = struct module A = N.M(X) end 50 | end 51 | end 52 | 53 | 54 | module Op(N:fty)(M:fty) = struct 55 | module type nat = sig 56 | module type t = sig module A: N.nat end 57 | module M: t 58 | end 59 | module type t = ty -> nat 60 | module M = functor (X:ty) -> struct 61 | module type t = sig module A:N.nat end 62 | module M: t = struct module A = N.M(X) end 63 | end 64 | end 65 | 66 | *) 67 | -------------------------------------------------------------------------------- /arrowm/common.ml: -------------------------------------------------------------------------------- 1 | module type ty = sig 2 | module type t 3 | module M:t 4 | end 5 | -------------------------------------------------------------------------------- /arrowm/dune: -------------------------------------------------------------------------------- 1 | (library (name arrowm)) 2 | -------------------------------------------------------------------------------- /arrowm/init.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | module type t = ty 4 | module Z = struct 5 | module type t = sig end 6 | module M = struct end 7 | end 8 | 9 | module S = struct 10 | module type t = functor(X:ty) -> 11 | sig 12 | module type t = sig 13 | module A: X.t 14 | end 15 | module M:t 16 | end 17 | module M(X:ty) = struct 18 | module type t = sig 19 | module A: X.t 20 | end 21 | module M = struct 22 | module A = X.M 23 | end 24 | end 25 | end 26 | 27 | module One = S.M(Z) 28 | module Two = S.M(One) 29 | -------------------------------------------------------------------------------- /arrowm/lambda.ml: -------------------------------------------------------------------------------- 1 | module type Ty = sig module type t end 2 | 3 | module Id(T:Ty)(X:T.t) = X 4 | 5 | module type bool = functor(T:Ty)(X:T.t)(Y:T.t) -> T.t 6 | 7 | module True(T:Ty)(X:T.t)(Y:T.t) = X 8 | 9 | module False(T:Ty)(X:T.t)(Y:T.t) = Y 10 | 11 | module If(T:Ty)(P:bool)(X:T.t)(Y:T.t) = P(T)(X)(Y) 12 | 13 | module type nat = functor(T:Ty)(F:T.t->T.t)(X:T.t) -> T.t 14 | 15 | module Zero(T:Ty)(F:T.t->T.t)(X:T.t) = X 16 | module Succ(N:nat)(T:Ty)(F:T.t->T.t)(X:T.t) = F(N(T)(F)(X)) 17 | 18 | module Two = Succ(Succ(Zero)) 19 | 20 | 21 | module IsZero(T:Ty)(X:nat) = 22 | X(struct module type t = module type of True(T) end)(functor (X:module type of True(T)) -> False(T))(True(T)) 23 | 24 | 25 | module Fst(A:Ty)(B:Ty)(X:A.t)(Y:B.t) = X 26 | module Snd(A:Ty)(B:Ty)(X:A.t)(Y:B.t) = Y 27 | 28 | module Pair(A:Ty)(B:Ty)(X:A.t)(Y:B.t)(R:Ty)(F: functor(X:A.t)(Y:B.t) -> R.t) = F(X)(Y) 29 | 30 | module BI = Pair(struct module type t = bool end)(struct module type t = nat end)(True)(Two) 31 | 32 | 33 | module Int = struct module type t = sig val x: int end end 34 | module Int_1 = struct let x = 0 end 35 | module Int_2 = struct let x = 0 end 36 | module Test = IsZero(Int)(Two)(Int_1)(Int_2) 37 | -------------------------------------------------------------------------------- /arrowm/mult.ml: -------------------------------------------------------------------------------- 1 | 2 | module B = Add 3 | 4 | 5 | module type t = B.t -> B.t 6 | module One = functor (Zero:B.t) -> Zero 7 | 8 | module S(N:t)(X:B.t) = B.Op(N(X))(X) 9 | module Op(N:t)(M:t)(X:B.t): module type of N(M(X)) = N(M(X)) 10 | module Fix(N:t) = N(B.One)(B.B.Z) 11 | 12 | 13 | module Two = S(One) 14 | module Four = Op(Two)(Two) 15 | module Sixteen = Op(Four)(Four) 16 | 17 | module F16 = Fix(Sixteen) 18 | module T = 19 | F16.M 20 | .A.A.A.A 21 | .A.A.A.A 22 | .A.A.A.A 23 | .A.A.A.A 24 | -------------------------------------------------------------------------------- /arrowm/pow.ml: -------------------------------------------------------------------------------- 1 | 2 | module B = Mult 3 | 4 | 5 | module type t = sig 6 | module F: B.t -> B.t 7 | module X: B.t 8 | end 9 | 10 | module One = struct 11 | module F = functor (Zero:B.t) -> Zero 12 | module X = B.One 13 | end 14 | 15 | module S(N:t) = struct 16 | module F(X:B.t)= B.Op(N.F(X))(X) 17 | module X = B.S(N.X) 18 | end 19 | module Op(N:t)(M:t) = struct 20 | module F(X:B.t) = N.F(M.F(X)) 21 | module X = M.X 22 | end 23 | module Fix(N:t) = B.Fix(N.F(N.X)) 24 | 25 | 26 | module Two = S(One) 27 | module Three = S(Two) 28 | module Four = S(Three) 29 | 30 | module F256 = Fix(Four) 31 | module T = 32 | F256.M 33 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 34 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 35 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 36 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 37 | 38 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 39 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 40 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 41 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 42 | 43 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 44 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 45 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 46 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 47 | 48 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 49 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 50 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 51 | .A.A.A.A.A.A.A.A.A.A.A.A.A.A.A.A 52 | 53 | -------------------------------------------------------------------------------- /arrowm/tetra.ml: -------------------------------------------------------------------------------- 1 | module B = Pow 2 | 3 | 4 | module type t = sig 5 | module F: B.t -> B.t 6 | module X: B.t 7 | end 8 | 9 | module One = struct 10 | module F = functor (Zero:B.t) -> Zero 11 | module X = B.One 12 | end 13 | 14 | module S(N:t) = struct 15 | module F(X:B.t)= B.Op(N.F(X))(X) 16 | module X = B.S(N.X) 17 | end 18 | module Op(N:t)(M:t) = struct 19 | module F(X:B.t) = N.F(M.F(X)) 20 | module X = M.X 21 | end 22 | module Fix(N:t) = B.Fix(N.F(N.X)) 23 | 24 | 25 | module Two = S(One) 26 | module Three = S(Two) 27 | module Four = S(Three) 28 | 29 | -------------------------------------------------------------------------------- /arrowm/up.ml: -------------------------------------------------------------------------------- 1 | module type t = sig 2 | module B: sig 3 | module type t 4 | module Fix: t -> Init.t 5 | end 6 | module type t = sig 7 | module F: B.t -> B.t 8 | module X: B.t 9 | end 10 | module One: t 11 | module S: t -> t 12 | module Op: functor(X:t)(Y:t) -> sig 13 | module F(Z:B.t): module type of X.F(Y.F(Z)) 14 | module X: B.t 15 | end 16 | module Fix: functor(X:t) -> module type of B.Fix(X.F(X.X)) 17 | end 18 | 19 | module S(B:t) = struct 20 | 21 | module type t = sig 22 | module F: B.t -> B.t 23 | module X: B.t 24 | end 25 | 26 | module One = struct 27 | module F = functor (Zero:B.t) -> Zero 28 | module X = B.One 29 | end 30 | 31 | module S(N:t) = struct 32 | module F(X:B.t)= B.Op(N.F(X))(X) 33 | module X = B.S(N.X) 34 | end 35 | module Op(N:t)(M:t) = struct 36 | module F(X:B.t) = N.F(M.F(X)) 37 | module X = M.X 38 | end 39 | module Fix(N:t) = B.Fix(N.F(N.X)) 40 | 41 | 42 | end 43 | 44 | module Penta = S(Tetra) 45 | 46 | module Two = Penta.S(Penta.One) 47 | module M = Penta.Fix(Two) 48 | module T = M.M.A 49 | -------------------------------------------------------------------------------- /boardgames/builder.ml: -------------------------------------------------------------------------------- 1 | 2 | type empty = Empty 3 | type key = Key 4 | type _ free = 5 | | Empty: empty free 6 | | Key: key free 7 | type door = Door 8 | 9 | type with_key = With_key 10 | type empty_handed = Empty_handed 11 | 12 | type _ player = 13 | | With_key: with_key player 14 | | Empty_handed: empty_handed player 15 | 16 | type ('a,'b) state = 17 | type _ case = 18 | | Case: empty free case 19 | | Key: key free case 20 | | Door: door case 21 | 22 | type 'a board = 'a 23 | constraint 'a = < left:'l; player:'p player; at:'c free; right: 'r > 24 | 25 | type e = empty free 26 | type k = key free 27 | type d = door 28 | 29 | module type T = sig type t end 30 | type 'a ty = (module T with type t = 'a) 31 | type 'a tyw = Ty 32 | 33 | module Builder = struct 34 | type _ t = 35 | | []: e t 36 | | (::): 'a case * 'b t -> ('a * 'b) t 37 | 38 | 39 | let typeOf (type x) (_: x tyw): x ty = 40 | (module struct type t = x end) 41 | let start (x:'a t) = 42 | typeOf(Ty: tyw) 43 | end 44 | 45 | let st = Builder.[Case;Key;Key;Case;Door;Door;Case] 46 | module Start = (val Builder.start st) 47 | 48 | type 'a stop = as 'a 49 | type 'arg right = 50 | < 51 | left:'at free *'l 52 | ; player:'p 53 | ; at:'r free 54 | ; right:'r2 55 | > board 56 | constraint 'arg = < 57 | left:'l; 58 | player:'p; 59 | at:'at free; 60 | right:'r free * 'r2 61 | > board 62 | 63 | type 'arg left = 64 | board 65 | constraint 'arg = 66 | board 72 | 73 | type 'arg take_key = 74 | < 75 | left:'l; 76 | player: with_key player; 77 | right:'r; 78 | at: empty free 79 | > 80 | constraint 'arg = < 81 | left:'l; 82 | player: empty_handed player; 83 | right:'r; 84 | at: key free 85 | > 86 | 87 | type 'arg open_door = 88 | 92 | constraint 'arg = < 93 | left:'l; 94 | player: with_key player; 95 | right: door * 'r; 96 | at:'at 97 | > 98 | 99 | 100 | type ('a,'b) move = 101 | | L: ('arg, 'arg left) move 102 | | R: ('arg, 'arg right) move 103 | | K: ('arg, 'arg take_key) move 104 | | O: ('arg, 'arg open_door) move 105 | 106 | type _ play = 107 | | []: Start.t play 108 | | (::): ('a,'b) move * 'a play -> 'b play 109 | 110 | let s = [] 111 | let n1 = [R] 112 | let t = [O;R;K;R] 113 | 114 | (* 115 | let win: _ stop play -> unit = function 116 | | [_;_;_;_;_;_;_] -> . 117 | | [_;_;_;_;_;_;_;_] -> . 118 | | [_;_;_;_;_;_;_;_;_] -> . 119 | | [_;_;_;_;_;_;_;_;_;_] -> . 120 | | [_;_;_;_;_;_;_;_;_;_;_] -> . 121 | | [_;_;_;_;_;_;_;_;_;_;_;_] -> . 122 | | [_;_;_;_;_;_;_;_;_;_;_;_;_] -> . 123 | 124 | | [_] -> . 125 | | _ -> . 126 | *) 127 | -------------------------------------------------------------------------------- /boardgames/burning_floor.ml: -------------------------------------------------------------------------------- 1 | 2 | type z = Zero 3 | type 'a s = Succ 4 | 5 | type three = z s s s 6 | type 'a timed = three * 'a 7 | 8 | 9 | type empty = Empty 10 | type key = Key 11 | type _ free = 12 | | Empty: empty free 13 | | Key: key free 14 | type door = Door 15 | 16 | type with_key = With_key 17 | type empty_handed = Empty_handed 18 | 19 | type _ player = 20 | | With_key: with_key player 21 | | Empty_handed: empty_handed player 22 | 23 | type ('a,'b) state = 24 | type _ case = 25 | | Case: empty free case 26 | | Key: key free case 27 | | Door: door case 28 | 29 | type 'a board = 'a 30 | constraint 'a = < left:'l; player:'p player; at:'c; right: 'r > 31 | 32 | type e = empty free 33 | type k = key free 34 | type d = door 35 | 36 | module type T = sig type t end 37 | type 'a ty = (module T with type t = 'a) 38 | type 'a tyw = Ty 39 | 40 | module Builder = struct 41 | type _ t = 42 | | []: e t 43 | | (::): 'a case * 'b t -> ('a timed * 'b) t 44 | 45 | 46 | let typeOf (type x) (_: x tyw): x ty = 47 | (module struct type t = x end) 48 | let start (x:'a t) = 49 | typeOf(Ty: tyw) 50 | end 51 | 52 | let st = Builder.[Case;Key;Key;Case;Door;Door;Case] 53 | module Start = (val Builder.start st) 54 | 55 | type 'a stop = as 'a 56 | type 'arg right = 57 | < 58 | left:'at *'l 59 | ; player:'p 60 | ; at:'n * 'r free 61 | ; right:'r2 62 | > board 63 | constraint 'arg = < 64 | left:'l; 65 | player:'p; 66 | at: 'at; 67 | right: ('n s * 'r free) * 'r2 68 | > board 69 | 70 | type 'arg left = 71 | board 72 | constraint 'arg = 73 | board 79 | 80 | type 'arg take_key = 81 | < 82 | left:'l; 83 | player: with_key player; 84 | right:'r; 85 | at: 'n * empty free 86 | > 87 | constraint 'arg = < 88 | left:'l; 89 | player: empty_handed player; 90 | right:'r; 91 | at: 'n * key free 92 | > 93 | 94 | type 'arg open_door = 95 | 99 | constraint 'arg = < 100 | left:'l; 101 | player: with_key player; 102 | right: ('n * door) * 'r; 103 | at:'at 104 | > 105 | 106 | 107 | type ('a,'b) move = 108 | | L: ('arg, 'arg left) move 109 | | R: ('arg, 'arg right) move 110 | | K: ('arg, 'arg take_key) move 111 | | O: ('arg, 'arg open_door) move 112 | 113 | type _ play = 114 | | []: Start.t play 115 | | (::): ('a,'b) move * 'a play -> 'b play 116 | 117 | let s = [] 118 | let n1 = [O;R;R;K;R;R] 119 | let t = [O;R;R;K;R;R] 120 | 121 | (* 122 | let win: _ stop play -> unit = function 123 | | [_;_;_;_;_;_;_] -> . 124 | | [_;_;_;_;_;_;_;_] -> . 125 | | [_;_;_;_;_;_;_;_;_] -> . 126 | | [_;_;_;_;_;_;_;_;_;_] -> . 127 | | [_;_;_;_;_;_;_;_;_;_;_] -> . 128 | | [_;_;_;_;_;_;_;_;_;_;_;_] -> . 129 | | [_;_;_;_;_;_;_;_;_;_;_;_;_] -> . 130 | 131 | | [_] -> . 132 | | _ -> . 133 | *) 134 | -------------------------------------------------------------------------------- /boardgames/doors.ml: -------------------------------------------------------------------------------- 1 | 2 | type empty = Empty 3 | type key = Key 4 | type _ free = 5 | | Empty: empty free 6 | | Key: key free 7 | type door = Door 8 | 9 | type with_key = With_key 10 | type empty_handed = Empty_handed 11 | 12 | type _ player = 13 | | With_key: with_key player 14 | | Empty_handed: empty_handed player 15 | 16 | type ('a,'b) state = 17 | type _ case = 18 | | Case: empty free case 19 | | Key: key free case 20 | | Door: door case 21 | 22 | type 'a board = 'a 23 | constraint 'a = < left:'l; player:'p player; at:'c free; right: 'r > 24 | 25 | type e = empty free case 26 | type k = key free case 27 | type d = door case 28 | 29 | type start = board 33 | 34 | type 'a stop = as 'a 35 | type 'arg right = 36 | < 37 | left:'at free case*'l 38 | ; player:'p 39 | ; at:'r free 40 | ; right:'r2 41 | > board 42 | constraint 'arg = < 43 | left:'l; 44 | player:'p; 45 | at:'at free; 46 | right:'r free case * 'r2 47 | > board 48 | 49 | type 'arg left = 50 | board 51 | constraint 'arg = 52 | board 58 | 59 | type 'arg take_key = 60 | < 61 | left:'l; 62 | player: with_key player; 63 | right:'r; 64 | at: empty free 65 | > 66 | constraint 'arg = < 67 | left:'l; 68 | player: empty_handed player; 69 | right:'r; 70 | at: key free 71 | > 72 | 73 | type 'arg open_door = 74 | 78 | constraint 'arg = < 79 | left:'l; 80 | player: with_key player; 81 | right: door case * 'r; 82 | at:'at 83 | > 84 | 85 | 86 | type ('a,'b) move = 87 | | L: ('arg, 'arg left) move 88 | | R: ('arg, 'arg right) move 89 | | K: ('arg, 'arg take_key) move 90 | | O: ('arg, 'arg open_door) move 91 | 92 | type _ play = 93 | | []: start play 94 | | (::): ('a,'b) move * 'a play -> 'b play 95 | 96 | let s = [] 97 | let n1 = [R] 98 | let t = [K;R;R] 99 | 100 | let win: _ stop play -> unit = function 101 | | [_;_;_;_;_;_;_] -> . 102 | | [_] -> . 103 | | _ -> . 104 | -------------------------------------------------------------------------------- /boardgames/dune: -------------------------------------------------------------------------------- 1 | (library (name boardgames)) 2 | -------------------------------------------------------------------------------- /boardgames/hands.ml: -------------------------------------------------------------------------------- 1 | 2 | type empty = Empty 3 | type key = Key 4 | type _ free = 5 | | Empty: empty free 6 | | Key: key free 7 | type door = Door 8 | 9 | 10 | type 'p player = 11 | constraint 'p = 'a * 'b 12 | 13 | type ('a,'b) state = 14 | type _ case = 15 | | Case: empty free case 16 | | Key: key free case 17 | | Door: door case 18 | 19 | type 'a board = 'a 20 | constraint 'a = < left:'l; player:'p player; at:'c free; right: 'r > 21 | 22 | type e = empty free 23 | type k = key free 24 | type d = door 25 | 26 | module type T = sig type t end 27 | type 'a ty = (module T with type t = 'a) 28 | type 'a tyw = Ty 29 | 30 | module Builder = struct 31 | type _ t = 32 | | []: e t 33 | | (::): 'a case * 'b t -> ('a * 'b) t 34 | 35 | 36 | let typeOf (type x) (_: x tyw): x ty = 37 | (module struct type t = x end) 38 | let start (x:'a t) = 39 | typeOf(Ty: tyw) 40 | end 41 | 42 | let st = Builder.[Case;Key;Key;Case;Door;Door;Case] 43 | module Start = (val Builder.start st) 44 | 45 | type 'a stop = as 'a 46 | type 'arg right = 47 | < 48 | left:'at free *'l 49 | ; player:'p 50 | ; at:'r free 51 | ; right:'r2 52 | > board 53 | constraint 'arg = < 54 | left:'l; 55 | player:'p; 56 | at:'at free; 57 | right:'r free * 'r2 58 | > board 59 | 60 | type 'arg left = 61 | board 62 | constraint 'arg = 63 | board 69 | 70 | type 'arg take = 71 | < 72 | left:'l; 73 | player: ; 74 | right:'r; 75 | at: 'rh free 76 | > 77 | constraint 'arg = < 78 | left:'l; 79 | player: ; 80 | right:'r; 81 | at: 'on_floor free 82 | > 83 | 84 | type 'arg open_door = 85 | ; 87 | right: e * 'r; 88 | at: 'at > 89 | constraint 'arg = < 90 | left:'l; 91 | player: ; 92 | right: door * 'r; 93 | at:'at 94 | > 95 | 96 | type 'arg swap = 97 | < 98 | left:'l; 99 | player: ; 100 | right:'r; 101 | at: 'at 102 | > 103 | constraint 'arg = < 104 | left:'l; 105 | player: ; 106 | right:'r; 107 | at: 'at 108 | > 109 | 110 | type winning = Win 111 | type 'a the_end = winning constraint 'a = 112 | 113 | 114 | 115 | type ('a,'b) move = 116 | | L: ('arg, 'arg left) move 117 | | R: ('arg, 'arg right) move 118 | | T: ('arg, 'arg take) move 119 | | S: ('arg, 'arg swap) move 120 | | O: ('arg, 'arg open_door) move 121 | | End: ('arg, 'arg the_end) move 122 | 123 | type _ play = 124 | | []: Start.t play 125 | | (::): ('a,'b) move * 'a play -> 'b play 126 | 127 | let s = [] 128 | let n1 = [R] 129 | let t = [End;R;R;O;R;S;O;R;T;R;T;R;R] 130 | -------------------------------------------------------------------------------- /boardgames/line.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | type case = Case 4 | 5 | type 'a board = 'a 6 | constraint 'a = < left:'l; at:case; right: 'r > 7 | 8 | type start = board 9 | 10 | type stop = board 11 | constraint start = 12 | 13 | type 'arg right = 14 | board 15 | constraint 'arg = board 16 | 17 | type 'arg left = 18 | board 19 | constraint 'arg = board 20 | 21 | type ('a,'b) move = 22 | | L: ('arg, 'arg left) move 23 | | R: ('arg, 'arg right) move 24 | 25 | type _ play = 26 | | []: start play 27 | | (::): ('a,'b) move * 'a play -> 'b play 28 | 29 | 30 | let t = [R] 31 | 32 | let win: stop play -> unit = function 33 | | [_;_;_;_;_] -> . 34 | | [_] -> . 35 | | _ -> . 36 | -------------------------------------------------------------------------------- /chess/dune: -------------------------------------------------------------------------------- 1 | (library (name knight_tour)) -------------------------------------------------------------------------------- /chess/problem.ml: -------------------------------------------------------------------------------- 1 | type 'a line = 'a 2 | constraint 'a = 3 | 4 | 5 | 6 | 7 | 8 | type 'a not_a_king = [ `pawn of 'a | `queen of 'a | `bishop of 'a | `rook of 'a | `knight of 'a ] 9 | 10 | type 'a piece = [ `king of 'a | 'a not_a_king ] 11 | type 'a case = [ `border | `free | 'a piece ] 12 | 13 | 14 | type 'a dup = 'a * ('a * 'a) 15 | 16 | 17 | type b = [ `border ] 18 | type o = [ `free ] 19 | 20 | 21 | type 'a hline = 22 | 23 | 24 | type halfbline = 25 | type bline = b hline 26 | type fline = o hline 27 | 28 | 29 | type status = [ `win | `white | `black ] 30 | 31 | type 'a board = 'a 32 | constraint 'a = 33 | 34 | type ('p) append = 'a * ('b * 'c) 35 | constraint 'p = ('a*'b) * 'c 36 | 37 | type 't move_left = 38 | constraint 't = 39 | 40 | type 't move_left_all = 41 | 'a move_left * ('b move_left * 'c move_left) 42 | constraint 't = 'a * ('b * 'c) 43 | 44 | 45 | type 't move_right = 46 | constraint 't = 47 | 48 | type 't move_right_all = 49 | 'a move_right * ('b move_right * 'c move_right) 50 | constraint 't = 'a * ('b * 'c) 51 | 52 | type 's turn = [< `white | `black ] as 's 53 | 54 | type white = < opp: black; tag: [ `white ] > 55 | and black = < opp: white; tag: [ `black ] > 56 | 57 | 58 | 59 | type 'x up = 60 | 66 | constraint 'x = 67 | 68 | 69 | type 'x down = 70 | 76 | constraint 'x = 77 | 78 | 79 | type 'x left = 80 | 86 | constraint 'x = 87 | 88 | 89 | type 'x right = 90 | 96 | constraint 'x = 97 | 98 | 99 | 100 | type ('a,'b,'c,'d) case = 101 | | A1: ('a,'a,'b,'b) case 102 | | A2: ('a,'a right,'b,'b left) case 103 | | A3: ('a,'a right right,'b,'b left left) case 104 | 105 | 106 | type ('st, 'c, 'fst, 'fc, 'all) status_and_case = 107 | ; 109 | down:'down; 110 | border:'b; 111 | status:'fst 112 | > 113 | constraint 114 | 'all = 115 | ; 117 | down:'down; 118 | border:'b; 119 | status:'st 120 | > 121 | 122 | type ('a,'b,'c,'d,'p) piece_move = 123 | White_pawn: ('a,'a up,'b,'b down, [ `pawn of white ]) piece_move 124 | 125 | type ('p, 'me, 'opponent, 'x) move = 126 | ; 128 | down:'down; 129 | border:'b; 130 | status:'opponent 131 | > 132 | constraint 133 | 'x = 134 | ; 136 | down:'down; 137 | border:'b; 138 | status:'me 139 | > 140 | 141 | 142 | type 'x opp = 'o constraint 'x = < opp:'o; ..> 143 | 144 | type ('st,'c, 'p, 'fst,'fc) action = 145 | | Move: ('st, [< `free | 'st opp not_a_king ], 'p, 'st opp, 'p ) action 146 | | Win: ('st, [ `king of 'st opp ], 'p, [ `win ], 'p ) action 147 | 148 | 149 | type ('a,'b) game = 150 | | [] : ('a,'a) game 151 | | (::): 152 | (('a, 'b, 'e, 'f) case 153 | * ('b,'c, ('st,'c,'fst,'fc, 'c) status_and_case,'e, 'p) piece_move 154 | * ('st,'c,'p,'fst,'fc) action) * 155 | ('start,'a) game -> ('start, 'f) game 156 | 157 | 158 | type half = 159 | type vhalf = 160 | 161 | 162 | 163 | type start = 164 | ; 166 | down: half dup; 167 | border:halfbline; 168 | status:white; 169 | > 170 | 171 | type 'a test_game = (start, 'a) game 172 | 173 | let (+) (l:_ test_game) x = x :: l 174 | -------------------------------------------------------------------------------- /chess/tour.ml: -------------------------------------------------------------------------------- 1 | type 'a line = 'a 2 | constraint 'a = 3 | 4 | 5 | type 'a case = Case 6 | type g = Ongoing 7 | type d = Done 8 | type o = g case 9 | type s = d case 10 | type b = Border 11 | type x = Visited 12 | 13 | type 'a dup = 'a * ('a * 'a) 14 | 15 | type 'a hline = 16 | 17 | 18 | type halfbline = 19 | type bline = b hline 20 | type fline = o hline 21 | 22 | 23 | type 'a board = 'a 24 | constraint 'a = 25 | 26 | type ('p) append = 'a * ('b * 'c) 27 | constraint 'p = ('a*'b) * 'c 28 | 29 | type 't move_left = 30 | constraint 't = 31 | 32 | type 't move_left_all = 33 | 'a move_left * ('b move_left * 'c move_left) 34 | constraint 't = 'a * ('b * 'c) 35 | 36 | 37 | type 't move_right = 38 | constraint 't = 39 | 40 | type 't move_right_all = 41 | 'a move_right * ('b move_right * 'c move_right) 42 | constraint 't = 'a * ('b * 'c) 43 | 44 | type 'x mark = 45 | ; 47 | down:'down; 48 | border:'b; 49 | status:'st 50 | > 51 | constraint 52 | 'x = 53 | ; 55 | down:'down; 56 | border:'b; 57 | status:g 58 | > 59 | 60 | type 'x up = 61 | 67 | constraint 'x = 68 | 69 | 70 | type 'x down = 71 | 77 | constraint 'x = 78 | 79 | 80 | type 'x left = 81 | 87 | constraint 'x = 88 | 89 | 90 | type 'x right = 91 | 97 | constraint 'x = 98 | 99 | 100 | type ('a,'b) move = 101 | | UUL: ('a,'a up up left mark) move 102 | | UUR: ('a,'a up up right mark) move 103 | | LLU: ('a,'a left left up mark) move 104 | | LLD: ('a,'a left left down mark) move 105 | | DDL: ('a,'a down down left mark) move 106 | | DDR: ('a,'a down down right mark) move 107 | | RRU: ('a,'a right right up mark) move 108 | | RRD: ('a,'a right right down mark) move 109 | 110 | 111 | type half = 112 | type shalf = 113 | type vhalf = 114 | 115 | 116 | type start = 117 | 123 | type tour = 124 | 130 | 131 | type (_,_) path = 132 | | []: ('a,'a) path 133 | | (::): ('a,'b) move * ('b,'c) path -> ('a,'c) path 134 | 135 | 136 | let ( + ) l x = x :: l 137 | 138 | let test = 139 | [] + RRD + LLD + RRD + UUL 140 | 141 | let t = [] + DDR + UUR 142 | 143 | let tour: 'a. (start,tour) path -> 'a = function 144 | | [_] -> . 145 | | [_;_] -> . 146 | | [_;_;_] -> . 147 | | [_;_;_;_] -> . 148 | | [_;_;_; 149 | _;_] -> . 150 | | [_;_;_; 151 | _;_;_] -> . 152 | | [_;_;_; 153 | _;_;_] -> . 154 | | [_;_;_; 155 | _;_;_; 156 | _] -> . 157 | | [_;_;_; 158 | _;_;_; 159 | _;_] -> . 160 | | [_;_;_; 161 | _;_;_; 162 | _;_;_] -> . 163 | | [_;_;_; 164 | _;_;_; 165 | _;_;_; 166 | _] -> . 167 | | [_;_;_; 168 | _;_;_; 169 | _;_;_; 170 | _;_] -> . 171 | | [_;_;_; 172 | _;_;_; 173 | _;_;_; 174 | _;_;_] -> . 175 | | _ -> . 176 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | -------------------------------------------------------------------------------- /units/axiomatic.ml: -------------------------------------------------------------------------------- 1 | 2 | type stop = Stop 3 | type zero = Zero 4 | type one = One 5 | type ('a,'b) mult = Mult 6 | type 'a neg = Neg 7 | 8 | type ('a,'b) eq = Refl: ('a,'a) eq 9 | 10 | let cast (type a b) (Refl:(a,b) eq) (x:a) = (x:b) 11 | let (%) (type a b c) (Refl:(a,b) eq) (Refl:(b,c) eq) = (Refl:(a,c) eq) 12 | let rev (type a b) (Refl: (a,b) eq) = (Refl : (b,a) eq) 13 | 14 | module type group_axioms = sig 15 | type 'a t 16 | type ('a,'b) eqt = ('a t, 'b t) eq 17 | val inv: ('a * 'a neg, zero) eqt 18 | val assoc: ('a * ('b * 'c), ('a * 'b) * 'c) eqt 19 | val e: (zero * 'a, 'a) eqt 20 | val com: ('a * 'b, 'b * 'a) eqt 21 | end 22 | 23 | module type eq_monad = 24 | sig 25 | type ('a,'b) eqt 26 | val pure: ('a,'b) eq -> ('a,'b) eqt 27 | val bind: (('a,'b) eq -> ('c,'d) eqt) -> ('a,'b) eqt -> ('c,'d) eqt 28 | val (>>=): ('a,'b) eqt -> (('a,'b) eq -> ('c,'d) eqt) -> ('c,'d) eqt 29 | end 30 | 31 | 32 | module Z: sig 33 | 34 | type +'a t 35 | 36 | val zero: zero t 37 | val one: one t 38 | val ( + ) : 'a t -> 'b t -> ('a * 'b) t 39 | val ( - ) : 'a t -> 'b t -> ('a * 'b neg) t 40 | 41 | module Axioms: sig 42 | include group_axioms with type 'a t := 'a t 43 | include eq_monad with type ('a,'b) eqt := ('a,'b) eqt 44 | end 45 | end = struct 46 | type 'a t = int 47 | let zero = 0 48 | let one = 1 49 | let ( + ) = ( + ) 50 | let ( - ) = ( - ) 51 | 52 | module Axioms = struct 53 | type ('a,'b) eqt = ('a t, 'b t) eq 54 | let bind _f _x = Refl 55 | let pure _ = Refl 56 | let (>>=) x f = bind f x 57 | let inv = Refl 58 | let assoc = Refl 59 | let e = Refl 60 | let com = Refl 61 | end 62 | 63 | end 64 | 65 | module Units : sig 66 | type +'a t 67 | 68 | val scalar: float -> zero t 69 | 70 | val ( + ) : 'a t -> 'a t -> 'a t 71 | val ( - ) : 'a t -> 'a t -> 'a t 72 | 73 | val ( * ) : 'a t -> 'b t -> ('a * 'b) t 74 | 75 | 76 | val ( / ) : 'a t -> 'b t -> ('a * 'b neg) t 77 | 78 | module Axioms: sig 79 | include group_axioms with type 'a t := 'a t 80 | val pure: ('a,'b) eq -> ('a,'b) eqt 81 | val bind: (('a,'b) eq -> ('c,'d) eqt) -> ('a,'b) eqt -> ('c,'d) eqt 82 | val (>>=): ('a,'b) eqt -> (('a,'b) eq -> ('c,'d) eqt) -> ('c,'d) eqt 83 | end 84 | 85 | module Make(): sig 86 | type u 87 | val one: u t 88 | end 89 | 90 | 91 | 92 | end = struct 93 | 94 | type 'a t = float 95 | let scalar x = x 96 | let ( + ) = ( +.) 97 | let ( - ) = ( -. ) 98 | let ( * ) = ( *. ) 99 | let ( / ) = ( /. ) 100 | 101 | module Axioms = struct 102 | type ('a,'b) eqt = ('a t, 'b t) eq 103 | let bind _f _x = Refl 104 | let pure _ = Refl 105 | let (>>=) x f = bind f x 106 | let inv = Refl 107 | let assoc = Refl 108 | let e = Refl 109 | let com = Refl 110 | end 111 | 112 | module Make() = struct 113 | type u 114 | let one = 1. 115 | end 116 | 117 | 118 | end 119 | 120 | 121 | module Meter = Units.Make() 122 | module Second = Units.Make() 123 | 124 | let m = Meter.one 125 | let s = Second.one 126 | 127 | 128 | open Units 129 | 130 | module A = Axioms 131 | 132 | 133 | let ( *. ) s x = cast A.e (scalar s * x) 134 | 135 | let e_rev_inv (type a z) (x: (a * a neg, z) eq): (z, a * a neg) eq = 136 | let Refl = x in 137 | Refl 138 | 139 | 140 | let ( let* ) = A.(>>=) 141 | 142 | let (>>|) x f = let open A in 143 | let* eq = x in 144 | pure (f eq) 145 | 146 | let (>>=) = A.(>>=) 147 | 148 | let neg eq = 149 | let neg0 (type a b) (Refl:(a,b) eq) : (a neg, b neg) A.eqt = Refl in 150 | eq >>= neg0 151 | 152 | let fst eq = 153 | let fst (type a b c) (Refl:(a,b) eq): (a * c, b * c) A.eqt = Refl in 154 | eq >>= fst 155 | 156 | let snd eq = 157 | let snd (type x y a) (Refl:(x,y) eq): (a * x, a * y) A.eqt = Refl in 158 | eq >>= snd 159 | 160 | 161 | 162 | let rev_inv () = (A.inv >>| e_rev_inv ) 163 | 164 | let e_inv_unicity (type a b z) (a: (a * a neg, z) eq) (x:(a * b, z) eq) : (b, a neg) A.eqt = 165 | let Refl = x in 166 | let Refl = e_rev_inv a in 167 | Refl 168 | 169 | 170 | let inv_unicity x = 171 | let* inv = A.inv in 172 | let* x = x in 173 | e_inv_unicity inv x 174 | 175 | let involution () (type a): (a neg neg, a) A.eqt = 176 | rev @@ inv_unicity @@ A.com % A.inv 177 | 178 | let distrib () (type a b) : (a neg * b neg, (a * b) neg) A.eqt = 179 | let inv = A.inv in (* x + -x = 0 *) 180 | let zpair = rev (rev inv % rev A.e) in (* 0 + x + -x = 0 *) 181 | let dpair = fst inv % zpair in (* (y + -y) + x + -x = 0 *) 182 | let c = A.assoc % fst A.com % dpair in (* -y + (y + (x + -x) = 0 *) 183 | let d = snd (rev A.assoc) % c in (* -y + ( (y + x) + -x) = 0 *) 184 | let e = snd (A.com) % d in (* -y + ( -x + (y + x)) = 0 *) 185 | let p = rev A.assoc % e in (* (-y + -x + (y + x) = 0 *) 186 | let p' = A.com % p in (* (y + x) + -y + -x = 0 *) 187 | inv_unicity p' (* -y + -x = -(y+x) *) 188 | 189 | let sound = 340. *. m / s 190 | 191 | let g = 9.81 *. m / (s * s) 192 | 193 | let time = sound / g (* (m / s) / (m / (s * s)) *) 194 | 195 | let time = cast (snd (rev @@ distrib ())) time (* ((m / s) / m) / (s * s) ^-1 *) 196 | let time = cast (rev A.assoc) time (* ( m * (( s^-1 / m) / (s * s)^-1) *) 197 | let time = cast (snd A.com) time (* ( m * m^-1 / (s * s)^-1) * s^-1 *) 198 | let time = cast (snd (rev A.assoc)) time (* m * ( m^-1 / (s * s)^-1) * s^-1 ) *) 199 | let time = cast A.assoc time (* m / m / (s * s)^-1) * s^-1 *) 200 | let time = cast (fst A.inv) time (* zero / (s * s)^-1) s^-1 *) 201 | let time = cast A.e time (* ((s * s)^-1)^1 * s^-1 *) 202 | let time = cast (fst @@ involution ()) time (* s * s / s *) 203 | let time = cast A.(com % assoc) time (* (s^-1 s) * s *) 204 | let time : Second.u t = cast A.(fst (com % inv) % e) time (* s *) 205 | -------------------------------------------------------------------------------- /units/dune: -------------------------------------------------------------------------------- 1 | (library (name units)) 2 | -------------------------------------------------------------------------------- /units/si.ml: -------------------------------------------------------------------------------- 1 | 2 | type z = Zero 3 | type 'a succ = S 4 | 5 | type 'a zero = 'a * 'a 6 | 7 | type 'a one = 'a * 'a succ 8 | type 'a two = 'a * 'a succ succ 9 | type 'a mone = 'a succ * 'a 10 | 11 | module Unit: sig 12 | type +'a t 13 | 14 | (* Generators *) 15 | val scalar: float -> t 16 | val float: t -> float 17 | val m: t 18 | val s: t 19 | val kg: t 20 | 21 | (* Arithmetic operations *) 22 | val ( + ): 'a t -> 'a t -> 'a t 23 | val ( * ): 24 | t -> 25 | t -> 26 | t 27 | 28 | val ( / ) : 29 | t -> 30 | t -> 31 | t 32 | 33 | (* normalization *) 34 | val unshift_m : 'b succ) as 'm; s:'s; kg:'kg> t -> t 35 | val unshift_s : 'b succ) as 's; kg:'kg> t -> t 36 | val unshift_kg : 'b succ) as 'kg> t -> t 37 | 38 | end = struct 39 | type +'a t = float 40 | 41 | let scalar x = x 42 | let float x = x 43 | let ( + ) = ( +. ) 44 | 45 | let ( * ) = ( *. ) 46 | let ( / ) = ( /. ) 47 | 48 | let m = 1. 49 | let s = 1. 50 | let kg = 1. 51 | 52 | let unshift_m x = x 53 | let unshift_s x = x 54 | let unshift_kg x = x 55 | 56 | end 57 | 58 | open Unit 59 | 60 | let ( *. ) x y = scalar x * y 61 | 62 | let c : t = 299_792_458. *. m / s 63 | 64 | let t = m / m + s/s 65 | 66 | let ua = 149_597_870_700. *. m 67 | 68 | let year = 86400. *. (365. *. s) 69 | 70 | let test = float @@ (c * year) / ua 71 | 72 | 73 | let what x y = m * x + ((y/m) * m) * m 74 | 75 | (* 76 | let what x = m * x + ((x/m) * m) * m 77 | let wrong = year + ua 78 | *) 79 | --------------------------------------------------------------------------------