├── examples ├── a.txt ├── LEM.txt ├── id.txt ├── K.txt ├── NLEM.txt ├── Peirce.txt ├── DeMorgan1.txt ├── DeMorgan2.txt ├── NPeirce.txt ├── S.txt └── distr1.txt ├── twitter-config.rb.example ├── make-image.sh ├── mastodon-config.toml.example ├── Gemfile ├── .gitignore ├── kripke.mli ├── twitter-make-image.sh ├── mastodon-make-image.sh ├── sat.mli ├── Makefile ├── solver.mli ├── parser.mly ├── README.md ├── term.mli ├── lf_proof.mli ├── nj_proof.mli ├── sat.ml ├── Gemfile.lock ├── lexer.mll ├── twitter.rb ├── kripke.ml ├── term.ml ├── main.ml ├── mastodon.rb ├── solver.ml ├── lf_proof.ml ├── nj_proof.ml └── OCamlMakefile /examples/a.txt: -------------------------------------------------------------------------------- 1 | A 2 | -------------------------------------------------------------------------------- /examples/LEM.txt: -------------------------------------------------------------------------------- 1 | P \/ ~P 2 | -------------------------------------------------------------------------------- /examples/id.txt: -------------------------------------------------------------------------------- 1 | A -> A 2 | -------------------------------------------------------------------------------- /examples/K.txt: -------------------------------------------------------------------------------- 1 | A -> B -> A 2 | -------------------------------------------------------------------------------- /examples/NLEM.txt: -------------------------------------------------------------------------------- 1 | ~~(P \/ ~P) 2 | -------------------------------------------------------------------------------- /examples/Peirce.txt: -------------------------------------------------------------------------------- 1 | ((A -> B) -> A) -> A 2 | -------------------------------------------------------------------------------- /examples/DeMorgan1.txt: -------------------------------------------------------------------------------- 1 | ~A /\ ~B <-> ~(A \/ B) 2 | -------------------------------------------------------------------------------- /examples/DeMorgan2.txt: -------------------------------------------------------------------------------- 1 | ~~(~(A /\ B) <-> ~A \/ ~B) 2 | -------------------------------------------------------------------------------- /examples/NPeirce.txt: -------------------------------------------------------------------------------- 1 | ~~(((A -> B) -> A) -> A) 2 | -------------------------------------------------------------------------------- /examples/S.txt: -------------------------------------------------------------------------------- 1 | (A -> B -> C) -> (A -> B) -> A -> C 2 | -------------------------------------------------------------------------------- /examples/distr1.txt: -------------------------------------------------------------------------------- 1 | ~~(((A/\B)->C)<->((A->C)\/(B->C))) 2 | -------------------------------------------------------------------------------- /twitter-config.rb.example: -------------------------------------------------------------------------------- 1 | $twitter_config = { 2 | :consumer_key => "", 3 | :consumer_secret => "", 4 | :access_token => "", 5 | :access_token_secret => "", 6 | } 7 | -------------------------------------------------------------------------------- /make-image.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | ulimit -St 10 3 | ulimit -Sf 300000 4 | ulimit -Sv 512000 5 | name="test" 6 | ./ipc_solver > $name.tex && \ 7 | latex -halt-on-error $name.tex && \ 8 | dvipng $name.dvi 9 | -------------------------------------------------------------------------------- /mastodon-config.toml.example: -------------------------------------------------------------------------------- 1 | [app] 2 | domain = "mastodon.example" 3 | 4 | [user] 5 | # Required permissions: 6 | # - read:accounts 7 | # - read:notifications 8 | # - read:statuses 9 | # - write:media 10 | # - write:statuses 11 | access_token = "foobar" 12 | -------------------------------------------------------------------------------- /Gemfile: -------------------------------------------------------------------------------- 1 | source 'https://rubygems.org' 2 | 3 | gem 'faraday', '~> 2.0' 4 | gem 'faraday-multipart', '~> 1.0' 5 | gem "websocket-client-simple", "~> 0.6.1" 6 | 7 | gem 'sqlite3', '~> 1.6' 8 | gem 'tomlrb', '~> 2.0' 9 | gem "nokogiri", "~> 1.14" 10 | 11 | gem 'twitter', '~> 7.0' 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.cmi 2 | *.cmo 3 | ._bcdi/ 4 | ._d/ 5 | /doc/ 6 | /lexer.ml 7 | /parser.ml 8 | /parser.mli 9 | /ipc_solver 10 | 11 | /twitter-config.rb 12 | /twitter-db 13 | /twitter-log.txt 14 | /workdir 15 | 16 | /mastodon-config.toml 17 | /mastodon.sqlite3 18 | /workdir_mastodon 19 | -------------------------------------------------------------------------------- /kripke.mli: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | type kripke_result = 4 | Refutable of int * bool array array * (pterm, bool array) Hashtbl.t 5 | | Irrefutable 6 | | NotDetermined 7 | 8 | val solve_n : name_env -> int -> pterm -> kripke_result 9 | val solve : name_env -> pterm -> kripke_result 10 | -------------------------------------------------------------------------------- /twitter-make-image.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -ue 3 | name=$1; shift 4 | 5 | ulimit -St 10 6 | ulimit -Sf 300000 7 | ulimit -Sv 512000 8 | cd workdir 9 | ../ipc_solver --latex $name.tex "$@" < $name-prop.txt > $name.out 2>$name.log 10 | latex -halt-on-error $name.tex >>$name.log 2>&1 11 | dvipng $name.dvi 12 | -------------------------------------------------------------------------------- /mastodon-make-image.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -ue 3 | name=$1; shift 4 | 5 | ulimit -St 10 6 | ulimit -Sf 300000 7 | ulimit -Sv 512000 8 | cd workdir_mastodon 9 | ../ipc_solver --latex $name.tex "$@" < $name-prop.txt > $name.out 2>$name.log 10 | latex -halt-on-error $name.tex >>$name.log 2>&1 11 | dvipng $name.dvi 12 | -------------------------------------------------------------------------------- /sat.mli: -------------------------------------------------------------------------------- 1 | type environment 2 | 3 | val new_environment : unit -> environment 4 | val fresh_var : environment -> int 5 | val add_clause : environment -> int array -> unit 6 | 7 | type result = 8 | | Satisfiable of bool array 9 | | Unsatisfiable 10 | | NotDetermined 11 | 12 | val invoke_minisat : environment -> result 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | 3 | SOURCES := \ 4 | term.mli term.ml \ 5 | parser.mly \ 6 | lexer.mll \ 7 | solver.mli solver.ml \ 8 | lf_proof.mli lf_proof.ml \ 9 | nj_proof.mli nj_proof.ml \ 10 | sat.mli sat.ml \ 11 | kripke.mli kripke.ml \ 12 | main.ml 13 | 14 | RESULT := ipc_solver 15 | 16 | OCAMLFLAGS := -w Aelyz 17 | 18 | include OCamlMakefile 19 | 20 | -------------------------------------------------------------------------------- /solver.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * This solver is based on: 3 | * JÖRG HUDELMAIER, 4 | * An O(n log n)-Space Decision Procedure 5 | * for Intuitionistic Propositional Logic. 6 | * J Logic Computation (1993) 3 (1): 63-75. 7 | * DOI: http://dx.doi.org/10.1093/logcom/3.1.63 8 | *) 9 | (* author: Masaki Hara *) 10 | 11 | open Term 12 | open Lf_proof 13 | 14 | val solve : int -> pterm -> lf_proof option 15 | -------------------------------------------------------------------------------- /parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Term 3 | %} 4 | %token IDENT 5 | %token EOF 6 | %token LPAREN RPAREN 7 | %token ARROW EQUIV AND OR NOT BOT TOP 8 | %token STRAY 9 | %nonassoc EQUIV 10 | %right ARROW 11 | %right OR 12 | %right AND 13 | %nonassoc NOT 14 | %start main 15 | %type main 16 | %type expression 17 | 18 | %% 19 | 20 | main: 21 | | expression EOF { $1 } 22 | expression: 23 | | IDENT { PNVarName $1 } 24 | | LPAREN expression RPAREN { $2 } 25 | | expression EQUIV expression { 26 | let t1 = $1 in 27 | let t2 = $3 in 28 | PNAnd (PNArrow (t1,t2),PNArrow (t2,t1)) 29 | } 30 | | expression ARROW expression { PNArrow ($1,$3) } 31 | | expression OR expression { PNOr ($1,$3) } 32 | | expression AND expression { PNAnd ($1,$3) } 33 | | NOT expression { PNArrow ($2,PNBot) } 34 | | TOP { PNTop } 35 | | BOT { PNBot } 36 | ; 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # IPC solver 2 | 3 | ## Description 4 | 5 | It determines whether a given statement in Intuitionistic 6 | Propositional Calculus (IPC) is provable or not. 7 | 8 | ## Dependencies 9 | 10 | - OCaml 11 | - MiniSat executable (for refutation by Kripke models) 12 | - LaTeX (for drawing proof diagrams) 13 | 14 | ## Usage (Command Line) 15 | 16 | ``` 17 | $ make 18 | $ ./ipc_solver <<< "~~(A \/ ~A)" 19 | $ ./ipc_solver <<< "A \/ ~A" 20 | ``` 21 | 22 | ## Usage (LaTeX) 23 | 24 | ``` 25 | $ make 26 | $ ./ipc_solver --latex ipc.tex <<< "~~(A \/ ~A)" 27 | $ latex ipc.tex 28 | $ dvipdfmx ipc.dvi 29 | ``` 30 | 31 | ## Usage (Twitter Bot) 32 | 33 | Please prepare your consumer key, consumer secret, access token, and access token secret. 34 | 35 | ``` 36 | $ make 37 | $ cp twitter-config.rb.example twitter-config.rb 38 | $ vim twitter-config.rb 39 | $ bundle exec ruby twitter.rb 40 | ``` 41 | 42 | 43 | -------------------------------------------------------------------------------- /term.mli: -------------------------------------------------------------------------------- 1 | type pnterm = 2 | | PNVarName of string 3 | | PNArrow of pnterm * pnterm 4 | | PNOr of pnterm * pnterm 5 | | PNAnd of pnterm * pnterm 6 | | PNTop 7 | | PNBot 8 | 9 | val pp_print_pnterm : Format.formatter -> pnterm -> unit 10 | 11 | 12 | type pterm = 13 | | PVar of int 14 | | PArrow of pterm * pterm 15 | | POr of pterm * pterm 16 | | PAnd of pterm * pterm 17 | | PTop 18 | | PBot 19 | 20 | type name_env = { 21 | mutable maxvar : int; 22 | dict : (string, int) Hashtbl.t; 23 | reverse_dict : (int, string) Hashtbl.t; 24 | } 25 | 26 | val new_name_env : unit -> name_env 27 | val empty_env : name_env 28 | 29 | val convert_name : pnterm -> pterm * name_env 30 | 31 | val pp_print_pterm : name_env -> Format.formatter -> pterm -> unit 32 | val pp_print_pterm_latex_internal : 33 | name_env -> int -> Format.formatter -> pterm -> unit 34 | val pp_print_pterm_latex : 35 | name_env -> int -> Format.formatter -> pterm -> unit 36 | -------------------------------------------------------------------------------- /lf_proof.mli: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | (* 4 | * R = succedent 5 | * L = antecedent 6 | * T = top 7 | * B = bottom 8 | * C = conjunction 9 | * D = disjunction 10 | * I = implication 11 | * P = atomic proposition 12 | *) 13 | type lf_proof = 14 | | LF_ax of int 15 | | LF_RT 16 | | LF_RC of lf_proof * lf_proof 17 | | LF_RDL of lf_proof 18 | | LF_RDR of lf_proof 19 | | LF_RI of lf_proof 20 | | LF_LT of int * lf_proof 21 | | LF_LB of int 22 | | LF_LC of int * lf_proof 23 | | LF_LD of int * lf_proof * lf_proof 24 | | LF_LIT of int * lf_proof 25 | | LF_LIB of int * lf_proof 26 | | LF_LIP of int * int * lf_proof 27 | | LF_LIC of int * lf_proof 28 | | LF_LID of int * lf_proof 29 | | LF_LII of int * lf_proof * lf_proof 30 | 31 | val pp_print_proofitem : Format.formatter -> lf_proof -> unit 32 | val pp_print_proof_internal : 33 | name_env -> int -> int -> (pterm * int) list -> 34 | pterm option -> pterm -> Format.formatter -> lf_proof -> unit 35 | val pp_print_proof : 36 | name_env -> int -> pterm -> Format.formatter -> lf_proof -> unit 37 | -------------------------------------------------------------------------------- /nj_proof.mli: -------------------------------------------------------------------------------- 1 | open Term 2 | open Lf_proof 3 | 4 | type nj_proof = 5 | | NJ_var of pterm * int 6 | | NJ_app of pterm * nj_proof * nj_proof 7 | | NJ_abs of pterm * pterm * nj_proof 8 | | NJ_tt (* True *) 9 | | NJ_ab of pterm * nj_proof (* False -> A *) 10 | | NJ_conj of pterm * nj_proof * nj_proof (* A -> B -> A /\ B *) 11 | | NJ_fst of pterm * nj_proof (* A /\ B -> A *) 12 | | NJ_snd of pterm * nj_proof(* A /\ B -> B *) 13 | | NJ_left of pterm * nj_proof (* A -> A \/ B *) 14 | | NJ_right of pterm * nj_proof (* B -> A \/ B *) 15 | | NJ_disj of pterm * nj_proof * nj_proof * nj_proof (* A \/B -> (A -> C) -> (B -> C) -> C *) 16 | 17 | val nj_type : nj_proof -> pterm 18 | val pp_print_lambda : name_env -> Format.formatter -> nj_proof -> unit 19 | val nj_check_type : pterm list -> nj_proof -> pterm 20 | val convert_lf : pterm -> lf_proof -> nj_proof 21 | val postproc_proof : nj_proof -> nj_proof 22 | 23 | 24 | type proof_tree = 25 | | PTassumption of string 26 | | PTaxiom of string * string 27 | | PTunary of string * string * proof_tree 28 | | PTbinary of string * string * proof_tree * proof_tree 29 | | PTtrinary of string * string * proof_tree * proof_tree * proof_tree 30 | 31 | val print_nj_latex : name_env -> Format.formatter -> nj_proof -> unit 32 | -------------------------------------------------------------------------------- /sat.ml: -------------------------------------------------------------------------------- 1 | type environment = { 2 | mutable maxvar: int; 3 | mutable clauses: int array list 4 | } 5 | 6 | let new_environment () = { 7 | maxvar = 0; 8 | clauses = [] 9 | } 10 | 11 | let fresh_var sat_env = 12 | let varid = sat_env.maxvar + 1 in 13 | sat_env.maxvar <- varid; 14 | varid 15 | 16 | let add_clause sat_env c = 17 | sat_env.clauses <- c :: sat_env.clauses 18 | 19 | let output_clauses sat_env f = 20 | Printf.fprintf f "p cnf %d %d\n" 21 | sat_env.maxvar (List.length sat_env.clauses); 22 | List.iter (fun clause -> 23 | Array.iter (fun literal -> 24 | Printf.fprintf f "%d " literal 25 | ) clause; 26 | Printf.fprintf f "0\n" 27 | ) sat_env.clauses 28 | 29 | type result = 30 | | Satisfiable of bool array 31 | | Unsatisfiable 32 | | NotDetermined 33 | 34 | let read_sat_output sat_env b = 35 | let status = Scanf.bscanf b "%s " (fun s -> s) in 36 | if status = "SAT" then begin 37 | let result = Array.make (sat_env.maxvar + 1) false in 38 | for i = 1 to sat_env.maxvar do 39 | result.(i) <- Scanf.bscanf b "%d " (fun i -> i) > 0 40 | done; 41 | Satisfiable result 42 | end else if status = "UNSAT" then 43 | Unsatisfiable 44 | else 45 | NotDetermined 46 | 47 | let invoke_minisat sat_env = 48 | let (minisat_in_path, minisat_in) = 49 | Filename.open_temp_file "ipc_kripke" ".cnf" in 50 | output_clauses sat_env minisat_in; 51 | close_out minisat_in; 52 | let (minisat_out_path, minisat_out) = 53 | Filename.open_temp_file "ipc_kripke" ".out" in 54 | close_out minisat_out; 55 | ignore (Sys.command ("minisat -verb=0 -cpu-lim=1 -mem-lim=256 " ^ minisat_in_path ^ " " ^ minisat_out_path ^ ">/dev/null 2>/dev/null")); 56 | let minisat_out = open_in minisat_out_path in 57 | let minisat_out_buf = Scanf.Scanning.from_channel minisat_out in 58 | let minisat_result = read_sat_output sat_env minisat_out_buf in 59 | Sys.remove minisat_in_path; 60 | Sys.remove minisat_out_path; 61 | minisat_result 62 | -------------------------------------------------------------------------------- /Gemfile.lock: -------------------------------------------------------------------------------- 1 | GEM 2 | remote: https://rubygems.org/ 3 | specs: 4 | addressable (2.8.1) 5 | public_suffix (>= 2.0.2, < 6.0) 6 | buftok (0.2.0) 7 | domain_name (0.5.20190701) 8 | unf (>= 0.0.5, < 1.0.0) 9 | equalizer (0.0.11) 10 | event_emitter (0.2.6) 11 | faraday (2.7.4) 12 | faraday-net_http (>= 2.0, < 3.1) 13 | ruby2_keywords (>= 0.0.4) 14 | faraday-multipart (1.0.4) 15 | multipart-post (~> 2) 16 | faraday-net_http (3.0.2) 17 | ffi (1.15.5) 18 | ffi-compiler (1.0.1) 19 | ffi (>= 1.0.0) 20 | rake 21 | http (4.4.1) 22 | addressable (~> 2.3) 23 | http-cookie (~> 1.0) 24 | http-form_data (~> 2.2) 25 | http-parser (~> 1.2.0) 26 | http-cookie (1.0.5) 27 | domain_name (~> 0.5) 28 | http-form_data (2.3.0) 29 | http-parser (1.2.3) 30 | ffi-compiler (>= 1.0, < 2.0) 31 | http_parser.rb (0.6.0) 32 | memoizable (0.4.2) 33 | thread_safe (~> 0.3, >= 0.3.1) 34 | multipart-post (2.3.0) 35 | naught (1.1.0) 36 | nokogiri (1.14.2-x86_64-linux) 37 | racc (~> 1.4) 38 | public_suffix (5.0.1) 39 | racc (1.6.2) 40 | rake (13.0.6) 41 | ruby2_keywords (0.0.5) 42 | simple_oauth (0.3.1) 43 | sqlite3 (1.6.2-x86_64-linux) 44 | thread_safe (0.3.6) 45 | tomlrb (2.0.3) 46 | twitter (7.0.0) 47 | addressable (~> 2.3) 48 | buftok (~> 0.2.0) 49 | equalizer (~> 0.0.11) 50 | http (~> 4.0) 51 | http-form_data (~> 2.0) 52 | http_parser.rb (~> 0.6.0) 53 | memoizable (~> 0.4.0) 54 | multipart-post (~> 2.0) 55 | naught (~> 1.0) 56 | simple_oauth (~> 0.3.0) 57 | unf (0.1.4) 58 | unf_ext 59 | unf_ext (0.0.8.2) 60 | websocket (1.2.9) 61 | websocket-client-simple (0.6.1) 62 | event_emitter 63 | websocket 64 | 65 | PLATFORMS 66 | x86_64-linux 67 | 68 | DEPENDENCIES 69 | faraday (~> 2.0) 70 | faraday-multipart (~> 1.0) 71 | nokogiri (~> 1.14) 72 | sqlite3 (~> 1.6) 73 | tomlrb (~> 2.0) 74 | twitter (~> 7.0) 75 | websocket-client-simple (~> 0.6.1) 76 | 77 | BUNDLED WITH 78 | 2.4.10 79 | -------------------------------------------------------------------------------- /lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | let keyword_table = Hashtbl.create 1010 4 | let latex_table = Hashtbl.create 10101 5 | let _ = 6 | List.iter (fun (kwd, tok) -> Hashtbl.add keyword_table kwd tok) 7 | [ "IMPLIES", ARROW; 8 | "Implies", ARROW; 9 | "implies", ARROW; 10 | "IFF", EQUIV; 11 | "Iff", EQUIV; 12 | "iff", EQUIV; 13 | "AND", AND; 14 | "And", AND; 15 | "and", AND; 16 | "OR", OR; 17 | "Or", OR; 18 | "or", OR; 19 | "NOT", NOT; 20 | "Not", NOT; 21 | "not", NOT; 22 | "FALSE", BOT; 23 | "False", BOT; 24 | "false", BOT; 25 | "TRUE", TOP; 26 | "True", TOP; 27 | "true", TOP; 28 | ] 29 | let _ = 30 | List.iter (fun (kwd, tok) -> Hashtbl.add latex_table kwd tok) 31 | [ "to", ARROW; 32 | "Rightarrow", ARROW; 33 | "supset", ARROW; 34 | "implies", ARROW; 35 | "Leftrightarrow", EQUIV; 36 | "equiv", EQUIV; 37 | "leftrightarrow", EQUIV; 38 | "iff", EQUIV; 39 | "wedge", AND; 40 | "land", AND; 41 | "vee", OR; 42 | "lor", OR; 43 | "lnot", NOT; 44 | "neg", NOT; 45 | "sim", NOT; 46 | "bot", BOT; 47 | "top", TOP; 48 | ] 49 | } 50 | rule token = 51 | parse [' ' '\t' '\n'] { token lexbuf } 52 | | "(*" { in_comment lexbuf; token lexbuf } 53 | | (['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '_']*) as id { 54 | try 55 | Hashtbl.find keyword_table id 56 | with Not_found -> 57 | IDENT id } 58 | | "\\" (['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9']*) as id { 59 | Hashtbl.find latex_table id } 60 | | "=>" { ARROW } 61 | | "->" { ARROW } 62 | | "→" { ARROW } 63 | | "⇒" { ARROW } 64 | | "<=>" { EQUIV } 65 | | "<->" { EQUIV } 66 | | "=" { EQUIV } 67 | | "⇔" { EQUIV } 68 | | "&&" { AND } 69 | | "&" { AND } 70 | | "＆" { AND } 71 | | "*" { AND } 72 | | "/\\" { AND } 73 | | "∧" { AND } 74 | | "||" { OR } 75 | | "|" { OR } 76 | | "｜" { OR } 77 | | "+" { OR } 78 | | "\\/" { OR } 79 | | "∨" { OR } 80 | | "~" { NOT } 81 | | "!" { NOT } 82 | | "-" { NOT } 83 | | "￢" { NOT } 84 | | "¬" { NOT } 85 | | "_|_" { BOT } 86 | | "⊥" { BOT } 87 | | "0" { BOT } 88 | | "1" { TOP } 89 | | "⊤" { TOP } 90 | | "(" { LPAREN } 91 | | "（" { LPAREN } 92 | | ")" { RPAREN } 93 | | "）" { RPAREN } 94 | | _ { STRAY } 95 | | eof { EOF } 96 | and in_comment = 97 | parse "(*" { in_comment lexbuf; in_comment lexbuf } 98 | | "*)" { () } 99 | | _ { in_comment lexbuf } 100 | -------------------------------------------------------------------------------- /twitter.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/ruby 2 | # -*- coding: utf-8 -*- 3 | 4 | require "pstore" 5 | require "twitter" 6 | load "./twitter-config.rb" 7 | 8 | `test -d workdir || mkdir workdir` 9 | 10 | $dblock = Mutex.new 11 | $db = PStore.new("twitter-db") 12 | 13 | def crush_error(sleep_length=0, &block) 14 | block.call() 15 | rescue 16 | message = "[#{Time.now}] #{$!.class}: #{$!.message}\n" 17 | $!.backtrace.each do|bt| 18 | message << " #{bt}\n" 19 | end 20 | print message 21 | File.open("twitter-log.txt", "a") do|file| 22 | file.print message 23 | end 24 | sleep(sleep_length) 25 | end 26 | 27 | def process_tweet(target) 28 | target.text.start_with?('@' + $self_screen_name) or return 29 | crush_error(90) do 30 | p ["processing", target.id] 31 | tid = target.id 32 | prop = target.text.dup 33 | prop.sub!('@' + $self_screen_name, "") 34 | prop.gsub!(/^\s+/m,"") 35 | prop.gsub!("<","<") 36 | prop.gsub!(">",">") 37 | prop.gsub!("&","&") 38 | 39 | File.open("workdir/#{tid}-prop.txt", "w") do|t| 40 | t.write prop 41 | end 42 | 43 | command = ["bash", "./twitter-make-image.sh", "#{tid}"] 44 | 45 | result = nil 46 | media = nil 47 | if system(command.join(" ")) 48 | result = File.read("workdir/#{tid}.out").strip 49 | if result == "" 50 | result = "An error occured." 51 | end 52 | if File.exists?("workdir/#{tid}1.png") 53 | media = "workdir/#{tid}1.png" 54 | end 55 | else 56 | result = "An error occured" 57 | end 58 | result = ".@#{target.user.screen_name} #{result} (#{rand(36**5).to_s(36)})" 59 | tw_option = { 60 | :in_reply_to_status_id => target.id 61 | } 62 | if media 63 | $twitter_client.update_with_media(result, File.new(media), tw_option) 64 | else 65 | $twitter_client.update(result, tw_option) 66 | end 67 | p ["done",target.id] 68 | end 69 | end 70 | 71 | def process_tweets(tweets) 72 | success = false 73 | crush_error do 74 | $dblock.synchronize do 75 | $db.transaction do 76 | target = nil 77 | $db["read"] ||= {} 78 | target = tweets.sort_by {|tw| 79 | tw.created_at 80 | }.find {|tw| 81 | !$db["read"][tw.id] 82 | } 83 | if target 84 | $db["read"][target.id] = {} 85 | process_tweet(target) 86 | sleep 10 87 | success = true 88 | end 89 | end 90 | end 91 | end 92 | return success 93 | end 94 | 95 | $twitter_client = Twitter::REST::Client.new($twitter_config) 96 | 97 | $self_userid = $twitter_client.user.id 98 | $self_screen_name = $twitter_client.user.screen_name 99 | 100 | loop do 101 | crush_error do 102 | p ["polling mentions"] 103 | mt = $twitter_client.mentions_timeline 104 | while process_tweets(mt) do 105 | end 106 | end 107 | sleep 60 108 | end 109 | 110 | -------------------------------------------------------------------------------- /kripke.ml: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | type kripke_env = { 4 | n : int; 5 | accessibility : int array array 6 | } 7 | 8 | let new_kripke_env sat_env n = 9 | let accessibility = Array.init n (fun _ -> 10 | Array.init n (fun _ -> Sat.fresh_var sat_env)) in 11 | (* reflexivity *) 12 | for i = 0 to (n-1) do 13 | Sat.add_clause sat_env [| accessibility.(i).(i) |] 14 | done; 15 | (* transitivity *) 16 | for i = 0 to (n-1) do 17 | for j = 0 to (n-1) do 18 | for k = 0 to (n-1) do 19 | Sat.add_clause sat_env [| 20 | accessibility.(i).(k); 21 | -accessibility.(i).(j); 22 | -accessibility.(j).(k) 23 | |] 24 | done 25 | done 26 | done; 27 | (* Wi |=> Wj implies i <= j *) 28 | for i = 0 to (n-1) do 29 | for j = 0 to (n-1) do 30 | if i > j then 31 | Sat.add_clause sat_env [| -accessibility.(i).(j) |] 32 | done 33 | done; 34 | { 35 | n = n; 36 | accessibility = accessibility 37 | } 38 | 39 | let rec make_clauses sat_env kripke_env term_memo t = 40 | try 41 | Hashtbl.find term_memo t 42 | with Not_found -> 43 | let varids = Array.init kripke_env.n (fun _ -> Sat.fresh_var sat_env) in 44 | Hashtbl.add term_memo t varids; 45 | begin match t with 46 | | PVar _ -> 47 | (* herediety *) 48 | for i = 0 to (kripke_env.n-1) do 49 | for j = 0 to (kripke_env.n-1) do 50 | Sat.add_clause sat_env [| 51 | -varids.(i); varids.(j); -kripke_env.accessibility.(i).(j) |]; 52 | done 53 | done 54 | | PArrow (t0, t1) -> 55 | let varids0 = make_clauses sat_env kripke_env term_memo t0 in 56 | let varids1 = make_clauses sat_env kripke_env term_memo t1 in 57 | let varids2 = 58 | Array.init kripke_env.n (fun _ -> Sat.fresh_var sat_env) in 59 | (* varids2 = not varids0 or varids1 *) 60 | for i = 0 to (kripke_env.n-1) do 61 | Sat.add_clause sat_env [| varids2.(i); varids0.(i) |]; 62 | Sat.add_clause sat_env [| varids2.(i); -varids1.(i) |]; 63 | Sat.add_clause sat_env [| -varids2.(i); -varids0.(i); varids1.(i) |] 64 | done; 65 | (* varids = square varids2 *) 66 | for i = 0 to (kripke_env.n-1) do 67 | let varids3 = 68 | Array.init kripke_env.n (fun _ -> Sat.fresh_var sat_env) in 69 | for j = 0 to (kripke_env.n-1) do 70 | Sat.add_clause sat_env [| varids3.(j); -varids2.(j) |]; 71 | Sat.add_clause sat_env [| 72 | varids3.(j); kripke_env.accessibility.(i).(j) |]; 73 | Sat.add_clause sat_env [| 74 | -varids3.(j); varids2.(j); -kripke_env.accessibility.(i).(j) |]; 75 | done; 76 | Sat.add_clause sat_env (Array.init (kripke_env.n + 1) (fun j -> 77 | if j == kripke_env.n then 78 | varids.(i) 79 | else 80 | -varids3.(j) 81 | )); 82 | for j = 0 to (kripke_env.n-1) do 83 | Sat.add_clause sat_env [| -varids.(i); varids3.(j) |]; 84 | done 85 | done 86 | | POr (t0, t1) -> 87 | let varids0 = make_clauses sat_env kripke_env term_memo t0 in 88 | let varids1 = make_clauses sat_env kripke_env term_memo t1 in 89 | for i = 0 to (kripke_env.n-1) do 90 | Sat.add_clause sat_env [| varids.(i); -varids0.(i) |]; 91 | Sat.add_clause sat_env [| varids.(i); -varids1.(i) |]; 92 | Sat.add_clause sat_env [| -varids.(i); varids0.(i); varids1.(i) |] 93 | done 94 | | PAnd (t0, t1) -> 95 | let varids0 = make_clauses sat_env kripke_env term_memo t0 in 96 | let varids1 = make_clauses sat_env kripke_env term_memo t1 in 97 | for i = 0 to (kripke_env.n-1) do 98 | Sat.add_clause sat_env [| -varids.(i); varids0.(i) |]; 99 | Sat.add_clause sat_env [| -varids.(i); varids1.(i) |]; 100 | Sat.add_clause sat_env [| varids.(i); -varids0.(i); -varids1.(i) |] 101 | done 102 | | PTop -> 103 | for i = 0 to (kripke_env.n-1) do 104 | Sat.add_clause sat_env [| varids.(i) |] 105 | done 106 | | PBot -> 107 | for i = 0 to (kripke_env.n-1) do 108 | Sat.add_clause sat_env [| -varids.(i) |] 109 | done 110 | end; 111 | varids 112 | 113 | type kripke_result = 114 | Refutable of int * bool array array * (pterm, bool array) Hashtbl.t 115 | | Irrefutable 116 | | NotDetermined 117 | 118 | let solve_n penv n t = 119 | let sat_env = Sat.new_environment () in 120 | let kripke_env = new_kripke_env sat_env n in 121 | let term_memo = Hashtbl.create 13 in 122 | let varids = make_clauses sat_env kripke_env term_memo t in 123 | Sat.add_clause sat_env [| -varids.(0) |]; 124 | let minisat_result = Sat.invoke_minisat sat_env in 125 | begin match minisat_result with 126 | | Sat.Satisfiable asgn -> 127 | (* Format.eprintf "Satisfiable@."; *) 128 | (* for x = 1 to sat_env.maxvar do 129 | if asgn.(x) then 130 | Format.eprintf "%d@." x 131 | else 132 | Format.eprintf "%d@." (-x) 133 | done; *) 134 | (* Hashtbl.iter (fun t0 varids0 -> 135 | Format.eprintf "%a = @." (pp_print_pterm penv 5) t0; 136 | Format.eprintf " ["; 137 | Array.iter (fun x -> 138 | Format.eprintf "%d, " (if asgn.(x) then 1 else 0) 139 | ) varids0; 140 | Format.eprintf "]@." 141 | ) term_memo; *) 142 | let accessibility = Array.map (fun row -> 143 | Array.map (fun v -> asgn.(v)) row 144 | ) kripke_env.accessibility in 145 | let term_asgn = Hashtbl.create 47 in 146 | Hashtbl.iter (fun t0 varids0 -> 147 | Hashtbl.add term_asgn t0 (Array.map (fun x -> asgn.(x)) varids0) 148 | ) term_memo; 149 | Refutable (n, accessibility, term_asgn) 150 | | Sat.Unsatisfiable -> 151 | (* Format.eprintf "Unsatisfiable@."; *) 152 | Irrefutable 153 | | Sat.NotDetermined -> 154 | (* Format.eprintf "Not determined@."; *) 155 | NotDetermined 156 | end 157 | 158 | let solve penv t = 159 | let ret = ref Irrefutable in 160 | for n = 2 to 4 do 161 | if !ret = Irrefutable then 162 | ret := solve_n penv n t 163 | done; 164 | !ret 165 | -------------------------------------------------------------------------------- /term.ml: -------------------------------------------------------------------------------- 1 | type pnterm = 2 | | PNVarName of string 3 | | PNArrow of pnterm * pnterm 4 | | PNOr of pnterm * pnterm 5 | | PNAnd of pnterm * pnterm 6 | | PNTop 7 | | PNBot 8 | 9 | let rec pp_print_pnterm_pr pr ppf = function 10 | | PNVarName s -> 11 | Format.fprintf ppf "%s" s 12 | | PNArrow (t,PNBot) -> 13 | Format.fprintf ppf "@[~%a@]" 14 | (pp_print_pnterm_pr 1) t 15 | | PNArrow (t1,t2) -> 16 | Format.fprintf ppf "@["; 17 | if pr < 4 then Format.fprintf ppf "("; 18 | Format.fprintf ppf "%a@ ->@ %a" 19 | (pp_print_pnterm_pr 3) t1 20 | (pp_print_pnterm_pr 4) t2; 21 | if pr < 4 then Format.fprintf ppf ")"; 22 | Format.fprintf ppf "@]" 23 | | PNAnd (PNArrow (t1,t2),PNArrow (t2t,t1t)) 24 | when t1=t1t && t2=t2t -> 25 | Format.fprintf ppf "@["; 26 | if pr < 5 then Format.fprintf ppf "("; 27 | Format.fprintf ppf "%a@ <->@ %a" 28 | (pp_print_pnterm_pr 4) t1 29 | (pp_print_pnterm_pr 4) t2; 30 | if pr < 5 then Format.fprintf ppf ")"; 31 | Format.fprintf ppf "@]" 32 | | PNAnd (t1,t2) -> 33 | Format.fprintf ppf "@["; 34 | if pr < 2 then Format.fprintf ppf "("; 35 | Format.fprintf ppf "%a@ /\\@ %a" 36 | (pp_print_pnterm_pr 1) t1 37 | (pp_print_pnterm_pr 2) t2; 38 | if pr < 2 then Format.fprintf ppf ")"; 39 | Format.fprintf ppf "@]" 40 | | PNOr (t1,t2) -> 41 | Format.fprintf ppf "@["; 42 | if pr < 3 then Format.fprintf ppf "("; 43 | Format.fprintf ppf "%a@ \\/@ %a" 44 | (pp_print_pnterm_pr 2) t1 45 | (pp_print_pnterm_pr 3) t2; 46 | if pr < 3 then Format.fprintf ppf ")"; 47 | Format.fprintf ppf "@]" 48 | | PNTop -> 49 | Format.fprintf ppf "True" 50 | | PNBot -> 51 | Format.fprintf ppf "False" 52 | 53 | let pp_print_pnterm = pp_print_pnterm_pr 5 54 | 55 | type pterm = 56 | | PVar of int 57 | | PArrow of pterm * pterm 58 | | POr of pterm * pterm 59 | | PAnd of pterm * pterm 60 | | PTop 61 | | PBot 62 | 63 | type name_env = { 64 | mutable maxvar : int; 65 | dict : (string,int) Hashtbl.t; 66 | reverse_dict : (int,string) Hashtbl.t 67 | } 68 | 69 | let new_name_env () = { 70 | maxvar = 0; 71 | dict = Hashtbl.create 10; 72 | reverse_dict = Hashtbl.create 100 73 | } 74 | let empty_env = new_name_env () 75 | 76 | let rec convert_name_impl env = function 77 | | PNVarName s -> 78 | begin try 79 | PVar (Hashtbl.find env.dict s) 80 | with Not_found -> 81 | let t = PVar env.maxvar in 82 | Hashtbl.add env.dict s env.maxvar; 83 | Hashtbl.add env.reverse_dict env.maxvar s; 84 | env.maxvar <- env.maxvar + 1; 85 | t 86 | end 87 | | PNArrow (t1,t2) -> 88 | PArrow (convert_name_impl env t1, 89 | convert_name_impl env t2) 90 | | PNAnd (PNArrow (t1,t2),PNArrow(t2t,t1t)) 91 | when t1=t1t && t2=t2t -> 92 | let ct1 = convert_name_impl env t1 in 93 | let ct2 = convert_name_impl env t2 in 94 | PAnd (PArrow (ct1,ct2),PArrow(ct2,ct1)) 95 | | PNAnd (t1,t2) -> 96 | PAnd (convert_name_impl env t1, 97 | convert_name_impl env t2) 98 | | PNOr (t1,t2) -> 99 | POr (convert_name_impl env t1, 100 | convert_name_impl env t2) 101 | | PNTop -> PTop 102 | | PNBot -> PBot 103 | 104 | let convert_name tn = 105 | let env = new_name_env () in 106 | let t = convert_name_impl env tn in 107 | t, env 108 | 109 | let rec pp_print_pterm_pr env pr ppf = function 110 | | PVar n -> 111 | begin try 112 | Format.fprintf ppf "%s" (Hashtbl.find env.reverse_dict n) 113 | with Not_found -> 114 | Format.fprintf ppf "?%d" n 115 | end 116 | | PArrow (t,PBot) -> 117 | Format.fprintf ppf "@[~%a@]" 118 | (pp_print_pterm_pr env 1) t 119 | | PArrow (t1,t2) -> 120 | Format.fprintf ppf "@["; 121 | if pr < 4 then Format.fprintf ppf "("; 122 | Format.fprintf ppf "%a@ ->@ %a" 123 | (pp_print_pterm_pr env 3) t1 124 | (pp_print_pterm_pr env 4) t2; 125 | if pr < 4 then Format.fprintf ppf ")"; 126 | Format.fprintf ppf "@]" 127 | | PAnd (PArrow (t1,t2),PArrow (t2t,t1t)) 128 | when t1=t1t && t2=t2t -> 129 | Format.fprintf ppf "@["; 130 | if pr < 5 then Format.fprintf ppf "("; 131 | Format.fprintf ppf "%a@ <->@ %a" 132 | (pp_print_pterm_pr env 4) t1 133 | (pp_print_pterm_pr env 4) t2; 134 | if pr < 5 then Format.fprintf ppf ")"; 135 | Format.fprintf ppf "@]" 136 | | PAnd (t1,t2) -> 137 | Format.fprintf ppf "@["; 138 | if pr < 2 then Format.fprintf ppf "("; 139 | Format.fprintf ppf "%a@ /\\@ %a" 140 | (pp_print_pterm_pr env 1) t1 141 | (pp_print_pterm_pr env 2) t2; 142 | if pr < 2 then Format.fprintf ppf ")"; 143 | Format.fprintf ppf "@]" 144 | | POr (t1,t2) -> 145 | Format.fprintf ppf "@["; 146 | if pr < 3 then Format.fprintf ppf "("; 147 | Format.fprintf ppf "%a@ \\/@ %a" 148 | (pp_print_pterm_pr env 2) t1 149 | (pp_print_pterm_pr env 3) t2; 150 | if pr < 3 then Format.fprintf ppf ")"; 151 | Format.fprintf ppf "@]" 152 | | PTop -> 153 | Format.fprintf ppf "True" 154 | | PBot -> 155 | Format.fprintf ppf "False" 156 | 157 | let pp_print_pterm env = pp_print_pterm_pr env 5 158 | 159 | let rec pp_print_pterm_latex_internal env pr ppf = function 160 | | PVar n -> 161 | begin try 162 | Format.fprintf ppf "%s" (Hashtbl.find env.reverse_dict n) 163 | with Not_found -> 164 | Format.fprintf ppf "?%d" n 165 | end 166 | | PArrow (t,PBot) -> 167 | Format.fprintf ppf "@[\\lnot@ %a@]" 168 | (pp_print_pterm_latex_internal env 1) t 169 | | PArrow (t1,t2) -> 170 | Format.fprintf ppf "@["; 171 | if pr < 4 then Format.fprintf ppf "("; 172 | Format.fprintf ppf "%a@ \\to@ %a" 173 | (pp_print_pterm_latex_internal env 3) t1 174 | (pp_print_pterm_latex_internal env 4) t2; 175 | if pr < 4 then Format.fprintf ppf ")"; 176 | Format.fprintf ppf "@]" 177 | | PAnd (PArrow (t1,t2),PArrow (t2t,t1t)) 178 | when t1=t1t && t2=t2t -> 179 | Format.fprintf ppf "@["; 180 | if pr < 5 then Format.fprintf ppf "("; 181 | Format.fprintf ppf "%a@ \\leftrightarrow@ %a" 182 | (pp_print_pterm_latex_internal env 4) t1 183 | (pp_print_pterm_latex_internal env 4) t2; 184 | if pr < 5 then Format.fprintf ppf ")"; 185 | Format.fprintf ppf "@]" 186 | | PAnd (t1,t2) -> 187 | Format.fprintf ppf "@["; 188 | if pr < 2 then Format.fprintf ppf "("; 189 | Format.fprintf ppf "%a@ \\land@ %a" 190 | (pp_print_pterm_latex_internal env 1) t1 191 | (pp_print_pterm_latex_internal env 2) t2; 192 | if pr < 2 then Format.fprintf ppf ")"; 193 | Format.fprintf ppf "@]" 194 | | POr (t1,t2) -> 195 | Format.fprintf ppf "@["; 196 | if pr < 3 then Format.fprintf ppf "("; 197 | Format.fprintf ppf "%a@ \\lor@ %a" 198 | (pp_print_pterm_latex_internal env 2) t1 199 | (pp_print_pterm_latex_internal env 3) t2; 200 | if pr < 3 then Format.fprintf ppf ")"; 201 | Format.fprintf ppf "@]" 202 | | PTop -> 203 | Format.fprintf ppf "\\top" 204 | | PBot -> 205 | Format.fprintf ppf "\\bot" 206 | 207 | let pp_print_pterm_latex env pr ppf t = 208 | Format.fprintf ppf "@[$"; 209 | pp_print_pterm_latex_internal env pr ppf t; 210 | Format.fprintf ppf "$@]" 211 | -------------------------------------------------------------------------------- /main.ml: -------------------------------------------------------------------------------- 1 | open Term 2 | open Format 3 | 4 | let verbose = ref false 5 | let latex_output = ref None 6 | 7 | let usage_msg = 8 | "ipc_solver is a solver for intuitionistic propositional formulas.\n" ^ 9 | "\n" ^ 10 | "usage:" 11 | 12 | let speclist = [ 13 | ("--latex", Arg.String (fun path -> latex_output := Some path), 14 | "Sets a path for latex output"); 15 | ("--no-latex", Arg.Unit (fun _ -> latex_output := None), 16 | "Cancels latex output"); 17 | ("--verbose", Arg.Set verbose, "Enables verbose output"); 18 | ("-v", Arg.Set verbose, "Enables verbose output") 19 | ] 20 | 21 | let () = 22 | Arg.parse speclist (fun _ -> ()) usage_msg; 23 | let lexbuf = Lexing.from_channel stdin in 24 | begin try 25 | let tn = Parser.main Lexer.token lexbuf in 26 | if !verbose then eprintf "Term is %a@." pp_print_pnterm tn; 27 | let (t,env) = convert_name tn in 28 | if !verbose then eprintf "Term is %a@." (pp_print_pterm env) t; 29 | let solver_result = Solver.solve env.maxvar t in 30 | let classical_result = begin match solver_result with 31 | | Some _ -> Kripke.Irrefutable 32 | | None -> Kripke.solve_n env 1 t end in 33 | let kripke_result = begin match solver_result, classical_result with 34 | | Some _, _ -> Kripke.Irrefutable 35 | | _, Kripke.Irrefutable -> Kripke.solve env t 36 | | _, r -> r end in 37 | let message = 38 | begin match solver_result, classical_result with 39 | | Some _, _ -> "Provable." 40 | | _, Kripke.Refutable _ -> "Not provable in intuitionistic logic; not provable in classical logic neither." 41 | | _, Kripke.Irrefutable -> "Not provable in intuitionistic logic; provable in classical logic however." 42 | | _, _ -> "Not provable in intuitionistic logic." 43 | end in 44 | Format.printf "%s@." message; 45 | begin match !latex_output with 46 | | Some latex_path -> 47 | let f = open_out latex_path in 48 | let ff = formatter_of_out_channel f in 49 | fprintf ff "%s@." "\\documentclass[preview,varwidth=10000px,12pt]{standalone}"; 50 | fprintf ff "%s@." "\\usepackage{bussproofs}"; 51 | fprintf ff "%s@." "\\usepackage{color}"; 52 | fprintf ff "%s@." "\\usepackage{latexsym}"; 53 | fprintf ff "%s@." "\\usepackage{listings}"; 54 | fprintf ff "%s@." "\\begin{document}"; 55 | fprintf ff "%a:@.@." (pp_print_pterm_latex env 5) t; 56 | fprintf ff "%s@.@." message; 57 | begin match Solver.solve env.maxvar t with 58 | | Some pr -> 59 | if !verbose then eprintf "proof(LF, plain): %a@." 60 | Lf_proof.pp_print_proofitem pr; 61 | if !verbose then eprintf "proof(LF):@,%a@." 62 | (Lf_proof.pp_print_proof env env.maxvar t) pr; 63 | let npr = Nj_proof.convert_lf t pr in 64 | if !verbose then eprintf "proof(NJ):@,%a@." 65 | (Nj_proof.pp_print_lambda env) npr; 66 | ignore (Nj_proof.nj_check_type [] npr); 67 | let npr = Nj_proof.postproc_proof npr in 68 | ignore (Nj_proof.nj_check_type [] npr); 69 | if !verbose then eprintf "proof(NJ):@,%a@." 70 | (Nj_proof.pp_print_lambda env) npr; 71 | 72 | fprintf ff "%s@.@." "Proof tree (intuitionistic):"; 73 | fprintf ff "%a@." (Nj_proof.print_nj_latex env) npr 74 | | None -> () 75 | end; 76 | begin match kripke_result with 77 | | Kripke.Refutable (n, accessibility, term_asgn) -> 78 | if n == 1 then begin 79 | fprintf ff "%s" "Counterexample: "; 80 | for i = 0 to (env.maxvar-1) do 81 | if i <> 0 then fprintf ff ", "; 82 | fprintf ff "$%a = %d$" 83 | (pp_print_pterm_latex_internal env 5) (PVar i) 84 | (if (Hashtbl.find term_asgn (PVar i)).(0) then 1 else 0) 85 | done; 86 | fprintf ff "@.@." 87 | end else begin 88 | fprintf ff "%s" "Kripke counterexample: "; 89 | fprintf ff "$\\mathcal{W} = \\{"; 90 | for j = 0 to (n-1) do 91 | if j <> 0 then fprintf ff ", "; 92 | fprintf ff "W_{%d}" j 93 | done; 94 | fprintf ff "\\}$, "; 95 | for i = 0 to (n-1) do 96 | for j = i+1 to (n-1) do 97 | if accessibility.(i).(j) then begin 98 | let ok = ref true in 99 | for k = i+1 to (j-1) do 100 | if accessibility.(i).(j) && accessibility.(j).(k) then 101 | ok := false 102 | done; 103 | if !ok then fprintf ff "$(W_{%d} \\leadsto W_{%d})$, " i j 104 | end 105 | done 106 | done; 107 | for i = 0 to (env.maxvar-1) do 108 | if i <> 0 then fprintf ff ", "; 109 | fprintf ff "$%a = \\{" 110 | (pp_print_pterm_latex_internal env 5) (PVar i); 111 | let comma = ref false in 112 | for j = 0 to (n-1) do 113 | if (Hashtbl.find term_asgn (PVar i)).(j) then begin 114 | if !comma then fprintf ff ", "; 115 | fprintf ff "W_{%d}" j; 116 | comma := true 117 | end 118 | done; 119 | fprintf ff "\\}$" 120 | done; 121 | fprintf ff "@.@." 122 | end; 123 | fprintf ff "\\begin{tabular}{|r|l|}@."; 124 | let visited = Hashtbl.create 771 in 125 | let rec visit t = 126 | if not (Hashtbl.mem visited t) then begin 127 | Hashtbl.add visited t (); 128 | begin match t with 129 | | PVar _ -> () 130 | | PArrow (t0, t1) -> visit t0; visit t1 131 | | POr (t0, t1) -> visit t0; visit t1 132 | | PAnd (t0, t1) -> visit t0; visit t1 133 | | PTop -> () 134 | | PBot -> () 135 | end; 136 | fprintf ff "%a & " (pp_print_pterm_latex env 5) t; 137 | if n == 1 then begin 138 | fprintf ff "$%d$" 139 | (if (Hashtbl.find term_asgn t).(0) then 1 else 0) 140 | end else begin 141 | fprintf ff "$\\{"; 142 | let comma = ref false in 143 | for j = 0 to (n-1) do 144 | if (Hashtbl.find term_asgn t).(j) then begin 145 | if !comma then fprintf ff ", "; 146 | fprintf ff "W_{%d}" j; 147 | comma := true 148 | end 149 | done; 150 | fprintf ff "\\}$" 151 | end; 152 | fprintf ff " \\\\" 153 | end 154 | in 155 | for i = 0 to (env.maxvar-1) do 156 | visit (PVar i) 157 | done; 158 | visit t; 159 | fprintf ff "\\end{tabular}@."; 160 | fprintf ff "@.@." 161 | | _ -> () 162 | end; 163 | fprintf ff "%s@." "\\end{document}"; 164 | close_out f 165 | | None -> () 166 | end 167 | with 168 | | Parsing.Parse_error -> 169 | Format.printf "Parse Error@."; 170 | begin match !latex_output with 171 | | Some latex_path -> 172 | let f = open_out latex_path in 173 | let ff = formatter_of_out_channel f in 174 | fprintf ff "%s@." "%parse_error"; 175 | fprintf ff "%s@." "\\documentclass[preview,varwidth=4000px]{standalone}"; 176 | fprintf ff "%s@." "\\begin{document}"; 177 | fprintf ff "%s@." "Parse Error"; 178 | fprintf ff "%s@." "\\end{document}"; 179 | close_out f 180 | | None -> () 181 | end 182 | end 183 | 184 | -------------------------------------------------------------------------------- /mastodon.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/ruby 2 | # -*- coding: utf-8 -*- 3 | 4 | require "fileutils" 5 | require "json" 6 | require "time" 7 | require "thread" 8 | require "uri" 9 | 10 | require "faraday" 11 | require "faraday/multipart" 12 | require "websocket-client-simple" 13 | require "tomlrb" 14 | require "nokogiri" 15 | require "sqlite3" 16 | 17 | module IPCSolver 18 | class MastodonClient 19 | STATE_INITIAL = 0 20 | STATE_COMPLETED = 1 21 | POLL_PERIOD = 3 * 60 22 | 23 | attr_reader :poll_queue 24 | 25 | def start 26 | @myself = get_myself 27 | @poll_queue = Thread::Queue.new 28 | periodic_poller = nil 29 | watcher = nil 30 | FileUtils.mkdir_p("workdir_mastodon") 31 | SQLite3::Database.new("mastodon.sqlite3") do |db| 32 | setup_database(db) 33 | periodic_poller = Thread.start do 34 | run_periodic_poller 35 | end 36 | watcher = create_watcher 37 | $stderr.puts "Start polling..." 38 | while event = @poll_queue.pop 39 | $stderr.puts "Checking mentions (cause: #{event[:type]})" 40 | poll_mentions(db) 41 | poll_requests(db) 42 | end 43 | end 44 | ensure 45 | watcher&.close 46 | periodic_poller&.raise Interrupt 47 | periodic_poller&.join 48 | end 49 | 50 | def run_periodic_poller 51 | loop do 52 | @poll_queue.push({ type: :periodic }) 53 | sleep POLL_PERIOD 54 | end 55 | rescue Interrupt 56 | # OK 57 | end 58 | 59 | def create_watcher 60 | query = URI.encode_www_form({ 61 | access_token: access_token, 62 | stream: "user:notification" 63 | }) 64 | this = self 65 | ws = WebSocket::Client::Simple.connect("wss://#{domain}/api/v1/streaming?#{query}") do |ws| 66 | ws.on :message do |msg| 67 | case msg.type 68 | when :ping 69 | ws.send("", type: :pong) 70 | when :text 71 | this.poll_queue&.push({ type: :streaming }) 72 | end 73 | end 74 | ws.on :error do |e| 75 | $stderr.puts "WebSocket error: #{e.inspect} / #{e.backtrace}" 76 | end 77 | end 78 | ws 79 | end 80 | 81 | def poll_mentions(db) 82 | last_read = get_last_read(db) 83 | new_last_read = last_read 84 | mentions_after = Time.now - 24 * 60 * 60 85 | mention_stream.each do |m| 86 | time = Time.iso8601(m["created_at"]) 87 | new_last_read = [new_last_read, time].compact.max 88 | break if last_read && time < last_read 89 | 90 | process_mention(db, m) 91 | end 92 | set_last_read(db, new_last_read) if new_last_read 93 | end 94 | 95 | def process_mention(db, m) 96 | html = m["status"]["content"] 97 | status_id = m["status"]["id"] 98 | requester = m["account"]["acct"] 99 | return if m["account"]["bot"] 100 | 101 | text = Nokogiri::HTML::DocumentFragment.parse(html).text 102 | create_request(db, status_id: status_id, text: text, requester: requester) 103 | end 104 | 105 | def poll_requests(db) 106 | pending = get_pending_requests(db) 107 | pending.each do |req| 108 | has_reply = get_status_context(req.status_id)["descendants"].any? do |child| 109 | child["account"]["id"] == @myself["id"] 110 | end 111 | process_request(req) unless has_reply 112 | req.state_cd = STATE_COMPLETED 113 | update_request_state(db, req) 114 | end 115 | end 116 | 117 | def process_request(req) 118 | $stderr.puts "Responding to #{req.status_id}..." 119 | tid = req.status_id 120 | prop = req.text.dup 121 | prop.sub!(/\A@\w+(@[\-\w.]+)?/, "") 122 | prop.gsub!(/\A\s+/m, "") 123 | 124 | File.open("workdir_mastodon/#{tid}-prop.txt", "w") do|t| 125 | t.write prop 126 | end 127 | 128 | command = ["bash", "./mastodon-make-image.sh", "#{tid}"] 129 | 130 | result = nil 131 | media = nil 132 | if system(command.join(" ")) 133 | result = File.read("workdir_mastodon/#{tid}.out").strip 134 | if result == "" 135 | result = "An error occured." 136 | end 137 | if File.exist?("workdir_mastodon/#{tid}1.png") 138 | media = "workdir_mastodon/#{tid}1.png" 139 | end 140 | else 141 | result = "An error occured" 142 | end 143 | result = "@#{req.requester} #{result}" 144 | if media 145 | media_obj = create_media( 146 | Faraday::Multipart::FilePart.new( 147 | media, 148 | 'image/png' 149 | ) 150 | ) 151 | end 152 | create_status( 153 | result, 154 | media: media_obj ? [media_obj] : nil, 155 | idempotency_key: "result-#{tid}", 156 | in_reply_to_id: req.status_id 157 | ) 158 | end 159 | 160 | def config 161 | @config ||= Tomlrb.load_file("mastodon-config.toml") 162 | end 163 | 164 | def create_media(file) 165 | client.post("/api/v2/media", { file: file }).body 166 | end 167 | 168 | def create_status(text, media:, idempotency_key:, in_reply_to_id:) 169 | params = { 170 | status: text, 171 | media_ids: (media || []).map { |m| m["id"] }, 172 | in_reply_to_id: in_reply_to_id 173 | } 174 | client.post("/api/v1/statuses", **params) do |req| 175 | req.headers["Idempotency-Key"] = idempotency_key 176 | end.body 177 | end 178 | 179 | def mention_stream 180 | enum_for(:each_mentions) 181 | end 182 | 183 | def each_mentions 184 | opts = { types: ["mention"] } 185 | loop do 186 | notifications = client.get("/api/v1/notifications", opts).body 187 | break if notifications.empty? 188 | 189 | notifications.each do |notification| 190 | yield notification 191 | end 192 | opts[:max_id] = notifications.last["id"] 193 | end 194 | end 195 | 196 | def get_myself 197 | client.get("/api/v1/accounts/verify_credentials").body 198 | end 199 | 200 | def get_status_context(id) 201 | client.get("/api/v1/statuses/#{id}/context").body 202 | end 203 | 204 | def client 205 | base_url = "https://#{domain}" 206 | token = access_token 207 | @client ||= Faraday.new(base_url) do |conn| 208 | conn.request :authorization, 'Bearer', access_token 209 | conn.request :multipart 210 | conn.request :url_encoded 211 | conn.response :json 212 | conn.response :raise_error 213 | end 214 | end 215 | 216 | def domain 217 | config["app"]["domain"] || (raise "No domain configured") 218 | end 219 | 220 | def client_key 221 | config["app"]["client_key"] || (raise "No client_key configured") 222 | end 223 | 224 | def client_secret 225 | config["app"]["client_secret"] || (raise "No client_secret configured") 226 | end 227 | 228 | def access_token 229 | config["user"]["access_token"] || (raise "No access_token configured") 230 | end 231 | 232 | def setup_database(db) 233 | db.execute_batch <<~SQL 234 | CREATE TABLE IF NOT EXISTS requests ( 235 | id INTEGER PRIMARY KEY AUTOINCREMENT, 236 | status_id TEXT NOT NULL UNIQUE, 237 | state_cd INTEGER NOT NULL DEFAULT 0, 238 | text TEXT, 239 | requester TEXT 240 | ); 241 | 242 | CREATE INDEX IF NOT EXISTS index_pending_requests 243 | ON requests (id) 244 | WHERE state_cd = 0; 245 | 246 | CREATE TABLE IF NOT EXISTS last_reads ( 247 | id INTEGER PRIMARY KEY AUTOINCREMENT, 248 | name TEXT NOT NULL UNIQUE, 249 | last_read TEXT NOT NULL 250 | ); 251 | SQL 252 | end 253 | 254 | def create_request(db, status_id:, text:, requester:) 255 | db.execute(<<~SQL, [status_id, text, requester]) 256 | INSERT INTO requests (status_id, text, requester) 257 | VALUES (?, ?, ?) 258 | ON CONFLICT (status_id) DO NOTHING; 259 | SQL 260 | end 261 | 262 | Request = Struct.new(:id, :status_id, :state_cd, :text, :requester) 263 | 264 | def get_pending_requests(db) 265 | requests = [] 266 | db.execute(<<~SQL) do |row| 267 | SELECT id, status_id, state_cd, text, requester FROM requests 268 | WHERE state_cd = 0; 269 | SQL 270 | requests << Request.new(*row) 271 | end 272 | requests 273 | end 274 | 275 | def update_request_state(db, req) 276 | db.execute(<<~SQL, [req.state_cd, req.id]) 277 | UPDATE requests 278 | SET state_cd = ? 279 | WHERE id = ?; 280 | SQL 281 | end 282 | 283 | def get_last_read(db) 284 | db.execute <<~SQL do |row| 285 | SELECT last_read FROM last_reads 286 | WHERE name = 'mentions'; 287 | SQL 288 | return Time.iso8601(row[0]) 289 | end 290 | nil 291 | end 292 | 293 | def set_last_read(db, last_read) 294 | db.execute(<<~SQL, [last_read.iso8601, last_read.iso8601]) 295 | INSERT INTO last_reads (name, last_read) 296 | VALUES ('mentions', ?) 297 | ON CONFLICT (name) DO 298 | UPDATE 299 | SET last_read = ? 300 | WHERE name = 'mentions'; 301 | SQL 302 | end 303 | end 304 | end 305 | 306 | IPCSolver::MastodonClient.new.start 307 | -------------------------------------------------------------------------------- /solver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * This solver is based on: 3 | * JÖRG HUDELMAIER, 4 | * An O(n log n)-Space Decision Procedure 5 | * for Intuitionistic Propositional Logic. 6 | * J Logic Computation (1993) 3 (1): 63-75. 7 | * DOI: http://dx.doi.org/10.1093/logcom/3.1.63 8 | *) 9 | (* author: Masaki Hara *) 10 | 11 | open Term 12 | open Lf_proof 13 | 14 | (* 15 | * general rules: 16 | * Antecedent: 17 | * list of pair (Term,Number). 18 | * Number is counted using ``anum''. 19 | * Succedent: 20 | * pair of Term. 21 | * 1. sucR is usual succedent. 22 | * 2. sucL is special succedent for ->->L rules. 23 | * Atomic Proposition: 24 | * fresh atomic proposition comes from ``pnum''. 25 | *) 26 | 27 | let do_debug_sequent = false 28 | 29 | let debug_sequent name ant1 ant2 sucL sucR = 30 | if do_debug_sequent then begin 31 | Format.eprintf "%s: " name; 32 | List.iter (fun (x,_) -> Format.eprintf "%a, " 33 | (Term.pp_print_pterm empty_env) x) (List.rev ant2); 34 | Format.eprintf ";; "; 35 | List.iter (fun (x,_) -> Format.eprintf "%a, " 36 | (Term.pp_print_pterm empty_env) x) ant1; 37 | begin match sucL with 38 | | None -> 39 | Format.eprintf "|- %a@." 40 | (Term.pp_print_pterm empty_env) sucR 41 | | Some sucLS -> 42 | Format.eprintf " [%a -> %a], |- %a@." 43 | (Term.pp_print_pterm empty_env) sucR 44 | (Term.pp_print_pterm empty_env) sucLS 45 | (Term.pp_print_pterm empty_env) sucR 46 | end 47 | end else () 48 | 49 | let make_proof (f:lf_proof -> lf_proof) (t:lf_proof option) = 50 | begin match t with 51 | | None -> None 52 | | Some ts -> Some (f ts) 53 | end 54 | 55 | let make_proof_and (f:lf_proof -> lf_proof -> lf_proof) 56 | (t1: unit -> lf_proof option) 57 | (t2: unit -> lf_proof option) = 58 | begin match t1 () with 59 | | None -> None 60 | | Some pr1 -> 61 | begin match t2 () with 62 | | None -> None 63 | | Some pr2 -> Some (f pr1 pr2) 64 | end 65 | end 66 | 67 | let make_proof_or 68 | (f1: lf_proof -> lf_proof) 69 | (f2: lf_proof -> lf_proof) 70 | (t1: unit -> lf_proof option) 71 | (t2: unit -> lf_proof option) = 72 | begin match t1 () with 73 | | Some pr -> Some (f1 pr) 74 | | None -> 75 | begin match t2 () with 76 | | Some pr -> Some (f2 pr) 77 | | None -> None 78 | end 79 | end 80 | 81 | (* solve1: only use reversible rules *) 82 | 83 | (* 84 | * solves [ant |- (sucR -> sucL) -> sucR ] 85 | * handles: 86 | * 1. |- (A -> B) 87 | * 2. |- (A /\ B) 88 | * 3. |- True 89 | *) 90 | let rec solve1_internal_s anum pnum ant sucL sucR = 91 | debug_sequent "1S" ant [] sucL sucR; 92 | begin match sucR with 93 | | PArrow (t1,t2) -> 94 | make_proof (fun pr -> LF_RI pr) 95 | (solve1_internal_s (anum+1) pnum ((t1,anum)::ant) sucL t2) 96 | | PAnd (t1,t2) -> 97 | make_proof_and (fun pr1 pr2 -> LF_RC (pr1,pr2)) 98 | (fun _ -> solve1_internal_s anum pnum ant sucL t1) 99 | (fun _ -> solve1_internal_s anum pnum ant sucL t2) 100 | | PTop -> Some LF_RT 101 | | _ -> solve1_internal_a1 anum pnum ant [] sucL sucR 102 | end 103 | 104 | (* 105 | * solves [ant2 @ ant1 |- (sucR -> sucL) -> sucR ] 106 | * handles: 107 | * 1. (A <-> B) |- 108 | * 2. (A /\ B) |- 109 | * 3. (A \/ B) |- 110 | * 4. True |- 111 | * 5. False |- 112 | * 6. p |- p 113 | * 7. (True -> A) |- 114 | * 8. (False -> A) |- 115 | * 9. (A /\ B -> C) |- 116 | * 10. ((A <-> B) -> C) |- 117 | * 11. (A \/ B -> C) |- 118 | * note: only solve1_internal_{s,a1,a2} can call it. 119 | * note: ``ant2'' must not have propositions which can be handled in 120 | * solve1_internal_a1. 121 | *) 122 | and solve1_internal_a1 anum pnum ant1 ant2 sucL sucR = 123 | debug_sequent "1A1" ant1 ant2 sucL sucR; 124 | begin match ant1 with 125 | | [] -> solve1_internal_a2 anum pnum ant2 [] sucL sucR 126 | | (PAnd (t1,t2),ti) :: ant1t -> 127 | make_proof (fun pr -> LF_LC (ti,pr)) 128 | (solve1_internal_a1 (anum+2) pnum 129 | ((t1,anum)::(t2,anum+1)::ant1t) ant2 sucL sucR) 130 | | (POr (t1,t2),ti) :: ant1t -> 131 | make_proof_and (fun pr1 pr2 -> LF_LD (ti,pr1,pr2)) 132 | (fun _ -> 133 | solve1_internal_a1 (anum+1) pnum 134 | ((t1,anum)::ant1t) ant2 sucL sucR) 135 | (fun _ -> 136 | solve1_internal_a1 (anum+1) pnum 137 | ((t2,anum)::ant1t) ant2 sucL sucR) 138 | | (PTop,ti) :: ant1t -> 139 | make_proof (fun pr -> LF_LT (ti,pr)) 140 | (solve1_internal_a1 anum pnum ant1t ant2 sucL sucR) 141 | | (PBot,ti) :: ant1t -> Some (LF_LB ti) 142 | | (PVar p,ti) :: ant1t when sucR = PVar p -> Some (LF_ax ti) 143 | | (PArrow (PTop,t3),ti) :: ant1t -> 144 | make_proof (fun pr -> LF_LIT (ti,pr)) 145 | (solve1_internal_a1 (anum+1) pnum 146 | ((t3,anum)::ant1t) ant2 sucL sucR) 147 | | (PArrow (PBot,t3),ti) :: ant1t -> 148 | make_proof (fun pr -> LF_LIB (ti,pr)) 149 | (solve1_internal_a1 anum pnum ant1t ant2 sucL sucR) 150 | | (PArrow (PAnd (t1,t2),t3),ti) :: ant1t -> 151 | make_proof (fun pr -> LF_LIC (ti,pr)) 152 | (solve1_internal_a1 (anum+1) pnum 153 | ((PArrow (t1,PArrow (t2,t3)),anum)::ant1t) ant2 sucL sucR) 154 | | (PArrow (POr (t1,t2),t3),ti) :: ant1t -> 155 | let p = PVar pnum in 156 | make_proof (fun pr -> LF_LID (ti,pr)) 157 | (solve1_internal_a1 (anum+3) (pnum+1) ( 158 | (PArrow (t1,p),anum):: 159 | (PArrow (t2,p),anum+1):: 160 | (PArrow (p,t3),anum+2)::ant1t) 161 | ant2 sucL sucR) 162 | | ant1h :: ant1t -> 163 | solve1_internal_a1 anum pnum ant1t (ant1h::ant2) sucL sucR 164 | end 165 | 166 | (* 167 | * solves [ant2 @ ant1 |- (sucR -> sucL) -> sucR ] 168 | * handles: 169 | * 1. (p -> C) |- [ only handles when p is in (ant2 @ ant1). ] 170 | * note: only solve1_internal_{a1,a2} can call it. 171 | * note: ``ant2'' must not have propositions which can be handled in 172 | * solve1_internal_a1 and solve1_internal_a2. 173 | *) 174 | and solve1_internal_a2 anum pnum ant1 ant2 sucL sucR = 175 | debug_sequent "1A2" ant1 ant2 sucL sucR; 176 | begin match ant1 with 177 | | [] -> solve2_internal_s anum pnum ant2 sucL sucR 178 | | (PArrow (PVar p,t3),ti) :: ant1t 179 | when List.exists (fun (x,_) -> x = PVar p) ant1 -> 180 | let tj = snd (List.find (fun (x,_) -> x = PVar p) ant1) in 181 | make_proof (fun pr -> LF_LIP (ti,tj,pr)) 182 | (solve1_internal_a1 (anum+1) pnum [(t3,anum)] (ant2@ant1t) sucL sucR) 183 | | (PArrow (PVar p,t3),ti) :: ant1t 184 | when List.exists (fun (x,_) -> x = PVar p) ant2 -> 185 | let tj = snd (List.find (fun (x,_) -> x = PVar p) ant2) in 186 | make_proof (fun pr -> LF_LIP (ti,tj,pr)) 187 | (solve1_internal_a1 (anum+1) pnum [(t3,anum)] (ant2@ant1t) sucL sucR) 188 | | ant1h :: ant1t -> 189 | solve1_internal_a2 anum pnum ant1t (ant1h::ant2) sucL sucR 190 | end 191 | 192 | (* 193 | * solves [ant |- (sucR -> sucL) -> sucR ] 194 | * handles: 195 | * 1. |- (A \/ B) 196 | *) 197 | and solve2_internal_s anum pnum ant sucL sucR = 198 | debug_sequent "2S" ant [] sucL sucR; 199 | let or_result = begin match sucR with 200 | | POr (t1,t2) -> 201 | begin match sucL with 202 | | None -> 203 | make_proof_or (fun pr -> LF_RDL pr) (fun pr -> LF_RDR pr) 204 | (fun _ -> solve1_internal_s anum pnum ant sucL t1) 205 | (fun _ -> solve1_internal_s anum pnum ant sucL t2) 206 | | Some sucLS -> 207 | let p = PVar pnum in 208 | let sp = Some p in 209 | make_proof_or (fun pr -> LF_RDL pr) (fun pr -> LF_RDR pr) 210 | (fun _ -> 211 | solve1_internal_s (anum+2) (pnum+1) 212 | ((PArrow (t2,p),anum)::(PArrow (p,sucLS),anum+1)::ant) sp t1) 213 | (fun _ -> 214 | solve1_internal_s (anum+2) (pnum+1) 215 | ((PArrow (t1,p),anum)::(PArrow (p,sucLS),anum+1)::ant) sp t2) 216 | end 217 | | _ -> None 218 | end in 219 | begin match or_result with 220 | | Some pr -> or_result 221 | | None -> solve2_internal_a anum pnum ant [] sucL sucR 222 | end 223 | 224 | (* 225 | * solves [ant2 @ ant1 |- (sucR -> sucL) -> sucR ] 226 | * handles: 227 | * 1. ((A -> B) -> C) |- 228 | * note: ``ant2'' must not have propositions which can be handled in 229 | * solve2_internal_a. 230 | *) 231 | and solve2_internal_a anum pnum ant1 ant2 sucL sucR = 232 | debug_sequent "2A" ant1 ant2 sucL sucR; 233 | begin match ant1 with 234 | | [] -> None 235 | | ant1h :: ant1t -> 236 | make_proof_or (fun pr -> pr) (fun pr -> pr) 237 | (fun _ -> 238 | begin match ant1h with 239 | | PArrow (PArrow (t1,t2),t3),ti -> 240 | make_proof_and (fun pr1 pr2 -> LF_LII (ti,pr1,pr2)) 241 | (fun _ -> 242 | begin match sucL with 243 | | None -> 244 | solve1_internal_s (anum+1) pnum 245 | ((t1,anum)::ant1t@ant2) (Some t3) t2 246 | | Some sucLS -> 247 | solve1_internal_s (anum+2) pnum 248 | ((PArrow (sucR,sucLS),anum)::(t1,anum+1)::ant1t@ant2) 249 | (Some t3) t2 250 | end) 251 | (fun _ -> 252 | solve1_internal_s (anum+1) pnum 253 | ((t3,anum)::ant1t@ant2) sucL sucR) 254 | | _ -> None 255 | end) 256 | (fun _ -> 257 | solve2_internal_a anum pnum ant1t (ant1h::ant2) sucL sucR) 258 | end 259 | 260 | let solve pnum p = 261 | solve1_internal_s 0 pnum [] None p 262 | -------------------------------------------------------------------------------- /lf_proof.ml: -------------------------------------------------------------------------------- 1 | open Term 2 | 3 | (* 4 | * R = succedent 5 | * L = antecedent 6 | * T = top 7 | * B = bottom 8 | * C = conjunction 9 | * D = disjunction 10 | * I = implication 11 | * P = atomic proposition 12 | *) 13 | type lf_proof = 14 | | LF_ax of int 15 | | LF_RT 16 | | LF_RC of lf_proof * lf_proof 17 | | LF_RDL of lf_proof 18 | | LF_RDR of lf_proof 19 | | LF_RI of lf_proof 20 | | LF_LT of int * lf_proof 21 | | LF_LB of int 22 | | LF_LC of int * lf_proof 23 | | LF_LD of int * lf_proof * lf_proof 24 | | LF_LIT of int * lf_proof 25 | | LF_LIB of int * lf_proof 26 | | LF_LIP of int * int * lf_proof 27 | | LF_LIC of int * lf_proof 28 | | LF_LID of int * lf_proof 29 | | LF_LII of int * lf_proof * lf_proof 30 | 31 | let rec pp_print_proofitem ppf = function 32 | | LF_ax x -> 33 | Format.fprintf ppf "@[<1>(ax@ %d)@]" x 34 | | LF_RT -> 35 | Format.fprintf ppf "@[<1>(TR)@]" 36 | | LF_RC (pr1,pr2) -> 37 | Format.fprintf ppf "@[<1>(/\\R@ %a@ %a)@]" 38 | pp_print_proofitem pr1 39 | pp_print_proofitem pr2 40 | | LF_RDL pr -> 41 | Format.fprintf ppf "@[<1>(\\/R1L@ %a)@]" 42 | pp_print_proofitem pr 43 | | LF_RDR pr -> 44 | Format.fprintf ppf "@[<1>(\\/R1R@ %a)@]" 45 | pp_print_proofitem pr 46 | | LF_RI pr -> 47 | Format.fprintf ppf "@[<1>(->R@ %a)@]" 48 | pp_print_proofitem pr 49 | | LF_LT (x,pr) -> 50 | Format.fprintf ppf "@[<1>(TL@ %d@ %a)@]" x 51 | pp_print_proofitem pr 52 | | LF_LB x -> 53 | Format.fprintf ppf "@[<1>(LB@ %d)@]" x 54 | | LF_LC (x,pr) -> 55 | Format.fprintf ppf "@[<1>(/\\L@ %d@ %a)@]" x 56 | pp_print_proofitem pr 57 | | LF_LD (x,pr1,pr2) -> 58 | Format.fprintf ppf "@[<1>(\\/L@ %d@ %a@ %a)@]" x 59 | pp_print_proofitem pr1 60 | pp_print_proofitem pr2 61 | | LF_LIT (x,pr) -> 62 | Format.fprintf ppf "@[<1>(->TL@ %d@ %a)@]" x 63 | pp_print_proofitem pr 64 | | LF_LIB (x,pr) -> 65 | Format.fprintf ppf "@[<1>(->BL@ %d@ %a)@]" x 66 | pp_print_proofitem pr 67 | | LF_LIP (x,y,pr) -> 68 | Format.fprintf ppf "@[<1>(->pL@ %d@ %d@ %a)@]" x y 69 | pp_print_proofitem pr 70 | | LF_LIC (x,pr) -> 71 | Format.fprintf ppf "@[<1>(->/\\L@ %d@ %a)@]" x 72 | pp_print_proofitem pr 73 | | LF_LID (x,pr) -> 74 | Format.fprintf ppf "@[<1>(->\\/L@ %d@ %a)@]" x 75 | pp_print_proofitem pr 76 | | LF_LII (x,pr1,pr2) -> 77 | Format.fprintf ppf "@[<1>(->->L@ %d@ %a@ %a)@]" x 78 | pp_print_proofitem pr1 79 | pp_print_proofitem pr2 80 | 81 | let rec cutAnt ant id = 82 | begin match ant with 83 | | [] -> raise (Invalid_argument "cannot find desired proposition in antecedent") 84 | | (t,ti)::antt when ti = id -> 85 | ([],t,antt) 86 | | anth::antt -> 87 | let (c0,c1,c2) = cutAnt antt id in 88 | (anth::c0,c1,c2) 89 | end 90 | 91 | let rec pp_print_proof_internal env anum pnum ant sucL sucR ppf pr = 92 | Format.fprintf ppf "@[<1>{"; 93 | List.iter (fun (x,_) -> 94 | Format.fprintf ppf "%a,@ " 95 | (pp_print_pterm env) x 96 | ) ant; 97 | begin match sucL with 98 | | None -> 99 | Format.fprintf ppf "|-@ %a@ " 100 | (pp_print_pterm env) sucR 101 | | Some sucLS -> 102 | Format.fprintf ppf "[%a -> %a],@ |-@ %a@ " 103 | (pp_print_pterm env) sucR 104 | (pp_print_pterm env) sucLS 105 | (pp_print_pterm env) sucR 106 | end; 107 | begin match pr with 108 | | LF_ax x -> 109 | Format.fprintf ppf "[ax:%d]@," x 110 | | LF_RT -> 111 | Format.fprintf ppf "[TR]@," 112 | | LF_RC (pr1,pr2) -> 113 | begin match sucR with 114 | | PAnd (t1,t2) -> 115 | Format.fprintf ppf "[/\\R]:@,%a@,%a@," 116 | (pp_print_proof_internal env anum pnum ant sucL t1) pr1 117 | (pp_print_proof_internal env anum pnum ant sucL t2) pr2 118 | | _ -> raise (Invalid_argument "LF_RC given, but not PAnd") 119 | end 120 | | LF_RDL pr -> 121 | begin match sucR with 122 | | POr (t1,t2) -> 123 | begin match sucL with 124 | | None -> 125 | Format.fprintf ppf "[\\/R1L]:@,%a@," 126 | (pp_print_proof_internal env anum pnum ant sucL t1) pr 127 | | Some sucLS -> 128 | let p = PVar pnum in 129 | Format.fprintf ppf "[\\/R2L]:@,%a@," 130 | (pp_print_proof_internal env (anum+2) (pnum+1) 131 | ((PArrow (t2,p),anum)::(PArrow (p,sucLS),anum+1)::ant) 132 | (Some p) t1) pr 133 | end 134 | | _ -> raise (Invalid_argument "LF_RDL given, but not POr") 135 | end 136 | | LF_RDR pr -> 137 | begin match sucR with 138 | | POr (t1,t2) -> 139 | begin match sucL with 140 | | None -> 141 | Format.fprintf ppf "[\\/R1R]:@,%a@," 142 | (pp_print_proof_internal env anum pnum ant sucL t2) pr 143 | | Some sucLS -> 144 | let p = PVar pnum in 145 | Format.fprintf ppf "[\\/R2R]:@,%a@," 146 | (pp_print_proof_internal env (anum+2) (pnum+1) 147 | ((PArrow (t1,p),anum)::(PArrow (p,sucLS),anum+1)::ant) 148 | (Some p) t2) pr 149 | end 150 | | _ -> raise (Invalid_argument "LF_RDR given, but not POr") 151 | end 152 | | LF_RI pr -> 153 | begin match sucR with 154 | | PArrow (t1,t2) -> 155 | Format.fprintf ppf "[->R]:@,%a@," 156 | (pp_print_proof_internal env (anum+1) pnum (ant@[(t1,anum)]) 157 | sucL t2) pr 158 | | _ -> raise (Invalid_argument "LF_RI given, but not PArrow") 159 | end 160 | | LF_LT (x,pr) -> 161 | let (ant0,t,ant1) = cutAnt ant x in 162 | Format.fprintf ppf "[TL]:@,%a@," 163 | (pp_print_proof_internal env anum pnum (ant0@ant1) sucL sucR) pr 164 | | LF_LB x -> 165 | Format.fprintf ppf "[BL]@," 166 | | LF_LC (x,pr) -> 167 | let (ant0,t,ant1) = cutAnt ant x in 168 | begin match t with 169 | | PAnd (t1,t2) -> 170 | Format.fprintf ppf "[/\\L]:@,%a@," 171 | (pp_print_proof_internal env (anum+2) pnum 172 | (ant0@(t1,anum)::(t2,anum+1)::ant1) sucL sucR) pr 173 | | _ -> raise (Invalid_argument "LF_LC given, but not PAnd") 174 | end 175 | | LF_LD (x,pr1,pr2) -> 176 | let (ant0,t,ant1) = cutAnt ant x in 177 | begin match t with 178 | | POr (t1,t2) -> 179 | Format.fprintf ppf "[\\/L]:@,%a@,%a@," 180 | (pp_print_proof_internal env (anum+1) pnum 181 | (ant0@(t1,anum)::ant1) sucL sucR) pr1 182 | (pp_print_proof_internal env (anum+1) pnum 183 | (ant0@(t2,anum)::ant1) sucL sucR) pr2 184 | | _ -> raise (Invalid_argument "LF_LD given, but not POr") 185 | end 186 | | LF_LIT (x,pr) -> 187 | let (ant0,t,ant1) = cutAnt ant x in 188 | begin match t with 189 | | PArrow (_,t2) -> 190 | Format.fprintf ppf "[->TL]:@,%a@," 191 | (pp_print_proof_internal env (anum+1) pnum 192 | (ant0@(t2,anum)::ant1) sucL sucR) pr 193 | | _ -> raise (Invalid_argument "LF_LIT given, but not PArrow") 194 | end 195 | | LF_LIB (x,pr) -> 196 | let (ant0,t,ant1) = cutAnt ant x in 197 | Format.fprintf ppf "[->BL]:@,%a@," 198 | (pp_print_proof_internal env anum pnum 199 | (ant0@ant1) sucL sucR) pr 200 | | LF_LIP (x,y,pr) -> 201 | let (ant0,t,ant1) = cutAnt ant x in 202 | begin match t with 203 | | PArrow (_,t2) -> 204 | Format.fprintf ppf "[->pL]:@,%a@," 205 | (pp_print_proof_internal env (anum+1) pnum 206 | (ant0@(t2,anum)::ant1) sucL sucR) pr 207 | | _ -> raise (Invalid_argument "LF_LIP given, but not PArrow") 208 | end 209 | | LF_LIC (x,pr) -> 210 | let (ant0,t,ant1) = cutAnt ant x in 211 | begin match t with 212 | | PArrow (PAnd (t1,t2),t3) -> 213 | Format.fprintf ppf "[->/\\L]:@,%a@," 214 | (pp_print_proof_internal env (anum+1) pnum 215 | (ant0@(PArrow (t1,PArrow (t2,t3)),anum)::ant1) sucL sucR) pr 216 | | _ -> raise (Invalid_argument "LF_LIC given, but not PAnd") 217 | end 218 | | LF_LID (x,pr) -> 219 | let (ant0,t,ant1) = cutAnt ant x in 220 | let p = PVar pnum in 221 | begin match t with 222 | | PArrow (POr (t1,t2),t3) -> 223 | Format.fprintf ppf "[->\\/L]:@,%a@," 224 | (pp_print_proof_internal env (anum+3) (pnum+1) (ant0@ 225 | (PArrow (t1,p),anum):: 226 | (PArrow (t2,p),anum+1):: 227 | (PArrow (p,t3),anum+2):: 228 | ant1) sucL sucR) pr 229 | | _ -> raise (Invalid_argument "LF_LID given, but not PArrow-POr") 230 | end 231 | | LF_LII (x,pr1,pr2) -> 232 | let (ant0,t,ant1) = cutAnt ant x in 233 | let p = PVar pnum in 234 | begin match t with 235 | | PArrow (PArrow (t1,t2),t3) -> 236 | Format.fprintf ppf "[->->L]:@,%a@,%a@," 237 | begin match sucL with 238 | | None -> 239 | pp_print_proof_internal env (anum+1) pnum 240 | (ant0@(t1,anum)::ant1) (Some t3) t2 241 | | Some sucLS -> 242 | pp_print_proof_internal env (anum+2) pnum 243 | (ant0@(PArrow (sucR,sucLS),anum)::(t1,anum+1)::ant1) 244 | (Some t3) t2 245 | end pr1 246 | (pp_print_proof_internal env (anum+1) pnum 247 | (ant0@(t3,anum)::ant1) sucL sucR) pr2 248 | | _ -> raise (Invalid_argument "LF_LII given, but not PArrow-PArrow") 249 | end 250 | end; 251 | Format.fprintf ppf "@,}@]@," 252 | 253 | let pp_print_proof env pnum suc ppf pr = 254 | pp_print_proof_internal env 0 pnum [] None suc ppf pr 255 | -------------------------------------------------------------------------------- /nj_proof.ml: -------------------------------------------------------------------------------- 1 | open Term 2 | open Lf_proof 3 | 4 | type nj_proof = 5 | | NJ_var of pterm * int 6 | | NJ_app of pterm * nj_proof * nj_proof 7 | | NJ_abs of pterm * pterm * nj_proof 8 | | NJ_tt (* True *) 9 | | NJ_ab of pterm * nj_proof (* False -> A *) 10 | | NJ_conj of pterm * nj_proof * nj_proof (* A -> B -> A /\ B *) 11 | | NJ_fst of pterm * nj_proof (* A /\ B -> A *) 12 | | NJ_snd of pterm * nj_proof(* A /\ B -> B *) 13 | | NJ_left of pterm * nj_proof (* A -> A \/ B *) 14 | | NJ_right of pterm * nj_proof (* B -> A \/ B *) 15 | | NJ_disj of pterm * nj_proof * nj_proof * nj_proof (* A \/B -> (A -> C) -> (B -> C) -> C *) 16 | 17 | let nj_type = function 18 | | NJ_var (p,_) -> p 19 | | NJ_app (p,_,_) -> p 20 | | NJ_abs (p,_,_) -> p 21 | | NJ_tt -> PTop 22 | | NJ_ab (p,_) -> p 23 | | NJ_conj (p,_,_) -> p 24 | | NJ_fst (p,_) -> p 25 | | NJ_snd (p,_) -> p 26 | | NJ_left (p,_) -> p 27 | | NJ_right (p,_) -> p 28 | | NJ_disj (p,_,_,_) -> p 29 | 30 | let abs_over p t = NJ_abs (PArrow (p,nj_type t),p,t) 31 | 32 | let rec pp_print_lambda env ppf = function 33 | | NJ_var (p,x) -> 34 | Format.fprintf ppf "@[<1>(%d@ :@ %a)@]@," x 35 | (pp_print_pterm env) p 36 | | NJ_app (p,t1,t2) -> 37 | Format.fprintf ppf "@[<1>(%a@ %a@ :@ %a)@]@," 38 | (pp_print_lambda env) t1 39 | (pp_print_lambda env) t2 40 | (pp_print_pterm env) p 41 | | NJ_abs (p,pa,ta) -> 42 | Format.fprintf ppf "@[<1>(\\:%a.@ %a@ :@ %a)@]@," 43 | (pp_print_pterm env) pa 44 | (pp_print_lambda env) ta 45 | (pp_print_pterm env) p 46 | | NJ_tt -> Format.fprintf ppf "@[<1>tt@]@," 47 | | NJ_ab (p,t1) -> 48 | Format.fprintf ppf "@[<1>([ab]@ %a@ :@ %a)@]@," 49 | (pp_print_lambda env) t1 50 | (pp_print_pterm env) p 51 | | NJ_conj (p,t1,t2) -> 52 | Format.fprintf ppf "@[<1>([conj]@ %a %a@ :@ %a)@]@," 53 | (pp_print_lambda env) t1 54 | (pp_print_lambda env) t2 55 | (pp_print_pterm env) p 56 | | NJ_fst (p,t1) -> 57 | Format.fprintf ppf "@[<1>([fst]@ %a@ :@ %a)@]@," 58 | (pp_print_lambda env) t1 59 | (pp_print_pterm env) p 60 | | NJ_snd (p,t1) -> 61 | Format.fprintf ppf "@[<1>([snd]@ %a@ :@ %a)@]@," 62 | (pp_print_lambda env) t1 63 | (pp_print_pterm env) p 64 | | NJ_left (p,t1) -> 65 | Format.fprintf ppf "@[<1>([left]@ %a@ :@ %a)@]@," 66 | (pp_print_lambda env) t1 67 | (pp_print_pterm env) p 68 | | NJ_right (p,t1) -> 69 | Format.fprintf ppf "@[<1>([right]@ %a@ :@ %a)@]@," 70 | (pp_print_lambda env) t1 71 | (pp_print_pterm env) p 72 | | NJ_disj (p,t1,t2,t3) -> 73 | Format.fprintf ppf "@[<1>([disj]@ %a@ %a@ %a@ :@ %a)@]@," 74 | (pp_print_lambda env) t1 75 | (pp_print_lambda env) t2 76 | (pp_print_lambda env) t3 77 | (pp_print_pterm env) p 78 | 79 | let rec shift i j t = 80 | begin match t with 81 | | NJ_var (p,x) when x >= i -> NJ_var (p,x+j) 82 | | NJ_var (_,_) -> t 83 | | NJ_app (p,t1,t2) -> NJ_app (p,shift i j t1,shift i j t2) 84 | | NJ_abs (p,pa,ta) -> NJ_abs (p,pa,shift (i+1) j ta) 85 | | NJ_tt -> NJ_tt 86 | | NJ_ab (p,t1) -> NJ_ab (p,shift i j t1) 87 | | NJ_conj (p,t1,t2) -> NJ_conj (p,shift i j t1,shift i j t2) 88 | | NJ_fst (p,t1) -> NJ_fst (p,shift i j t1) 89 | | NJ_snd (p,t1) -> NJ_snd (p,shift i j t1) 90 | | NJ_left (p,t1) -> NJ_left (p,shift i j t1) 91 | | NJ_right (p,t1) -> NJ_right (p,shift i j t1) 92 | | NJ_disj (p,t1,t2,t3) -> NJ_disj (p,shift i j t1,shift i j t2,shift i j t3) 93 | end 94 | 95 | let rec subst d t s = 96 | begin match t with 97 | | NJ_var (_,x) when x = d -> shift 0 d s 98 | | NJ_var (p,x) when x > d -> NJ_var (p,x-1) 99 | | NJ_var (_,_) -> t 100 | | NJ_app (p,t1,t2) -> NJ_app (p,subst d t1 s,subst d t2 s) 101 | | NJ_abs (p,pa,ta) -> NJ_abs (p,pa,subst (d+1) ta s) 102 | | NJ_tt -> NJ_tt 103 | | NJ_ab (p,t1) -> NJ_ab (p,subst d t1 s) 104 | | NJ_conj (p,t1,t2) -> NJ_conj (p,subst d t1 s,subst d t2 s) 105 | | NJ_fst (p,t1) -> NJ_fst (p,subst d t1 s) 106 | | NJ_snd (p,t1) -> NJ_snd (p,subst d t1 s) 107 | | NJ_left (p,t1) -> NJ_left (p,subst d t1 s) 108 | | NJ_right (p,t1) -> NJ_right (p,subst d t1 s) 109 | | NJ_disj (p,t1,t2,t3) -> NJ_disj (p,subst d t1 s,subst d t2 s,subst d t3 s) 110 | end 111 | 112 | let rec count_fv v t = 113 | begin match t with 114 | | NJ_var (_,x) when x = v -> 1 115 | | NJ_var (_,_) -> 0 116 | | NJ_app (_,t1,t2) -> count_fv v t1 + count_fv v t2 117 | | NJ_abs (_,_,ta) -> count_fv (v+1) ta 118 | | NJ_tt -> 0 119 | | NJ_ab (_,t1) -> count_fv v t1 120 | | NJ_conj (_,t1,t2) -> count_fv v t1 + count_fv v t2 121 | | NJ_fst (_,t1) -> count_fv v t1 122 | | NJ_snd (_,t1) -> count_fv v t1 123 | | NJ_left (_,t1) -> count_fv v t1 124 | | NJ_right (_,t1) -> count_fv v t1 125 | | NJ_disj (_,t1,t2,t3) -> count_fv v t1 + count_fv v t2 + count_fv v t3 126 | end 127 | 128 | let rec reduce t = 129 | begin match t with 130 | | NJ_var (p,x) -> reduce2 t 131 | | NJ_app (p,t1,t2) -> 132 | let rt2 = reduce t2 in 133 | begin match reduce t1 with 134 | | NJ_abs (_,_,ta) -> reduce (subst 0 ta rt2) 135 | | rt1 -> reduce2 (NJ_app (p,rt1,rt2)) 136 | end 137 | | NJ_abs (p,pa,ta) -> reduce2 (NJ_abs (p,pa,reduce ta)) 138 | | NJ_tt -> NJ_tt 139 | | NJ_ab (p,t1) -> reduce2 (NJ_ab (p,reduce t1)) 140 | | NJ_conj (p,t1,t2) -> reduce2 (NJ_conj (p,reduce t1,reduce t2)) 141 | | NJ_fst (p,t1) -> reduce2 (NJ_fst (p,reduce t1)) 142 | | NJ_snd (p,t1) -> reduce2 (NJ_snd (p,reduce t1)) 143 | | NJ_left (p,t1) -> reduce2 (NJ_left (p,reduce t1)) 144 | | NJ_right (p,t1) -> reduce2 (NJ_right (p,reduce t1)) 145 | | NJ_disj (p,t1,t2,t3) -> reduce2 (NJ_disj (p,reduce t1,reduce t2,reduce t3)) 146 | end 147 | and reduce2 t = 148 | begin match t with 149 | | NJ_abs (_,_,NJ_app (_,t1,NJ_var (_,0))) 150 | when count_fv 0 t1 = 0 -> shift 0 (-1) t1 151 | | NJ_fst (_,NJ_conj (_,t1,_)) -> t1 152 | | NJ_snd (_,NJ_conj (_,_,t2)) -> t2 153 | | NJ_disj (p,NJ_left (_,t1),t2,_) -> reduce (NJ_app (p,t2,t1)) 154 | | NJ_disj (p,NJ_right (_,t1),_,t3) -> reduce (NJ_app (p,t3,t1)) 155 | | NJ_disj (p,t1,NJ_abs (_,_,t2),_) when count_fv 0 t2 = 0 -> shift 0 (-1) t2 156 | | NJ_disj (p,t1,_,NJ_abs (_,_,t3)) when count_fv 0 t3 = 0 -> shift 0 (-1) t3 157 | | NJ_disj (p,t1,NJ_abs (_,pa2,t2),NJ_abs (_,pa3,t3)) -> 158 | begin match t2,t3 with 159 | | NJ_ab (p2,t2x),NJ_ab (p3,t3x) -> 160 | NJ_ab (p,NJ_disj (PBot,t1,NJ_abs (PArrow (pa2,PBot),pa2,t2x),NJ_abs 161 | (PArrow (pa3,PBot),pa3,t3x))) 162 | | _,_ -> t 163 | end 164 | | NJ_conj (p,NJ_fst (_,t1),NJ_snd (_,t2)) when t1 = t2 -> t1 165 | | _ -> t 166 | end 167 | 168 | let rec cutAnt ant id = 169 | begin match ant with 170 | | [] -> raise (Invalid_argument "cannot find desired proposition in antecedent") 171 | | (t,ti)::antt when ti = id -> 172 | ([],t,antt) 173 | | anth::antt -> 174 | let (c0,c1,c2) = cutAnt antt id in 175 | (anth::c0,c1,c2) 176 | end 177 | 178 | let rec nj_check_type e t = 179 | begin match t with 180 | | NJ_var (p,x) -> assert (List.nth e x = p); p 181 | | NJ_app (p,t1,t2) -> 182 | assert (nj_check_type e t1 = PArrow (nj_check_type e t2, p)); p 183 | | NJ_abs (p,pa,ta) -> 184 | assert (p = PArrow (pa, nj_check_type (pa::e) ta)); p 185 | | NJ_tt -> PTop 186 | | NJ_ab (p,t1) -> assert (nj_check_type e t1 = PBot); p 187 | | NJ_conj (p,t1,t2) -> 188 | assert (p = PAnd (nj_check_type e t1, nj_check_type e t2)); p 189 | | NJ_fst (p,t1) -> 190 | begin match nj_check_type e t1 with 191 | | PAnd (t1f,_) -> assert (t1f = p) 192 | | _ -> assert false 193 | end; p 194 | | NJ_snd (p,t1) -> 195 | begin match nj_check_type e t1 with 196 | | PAnd (_,t1s) -> assert (t1s = p) 197 | | _ -> assert false 198 | end; p 199 | | NJ_left (p,t1) -> 200 | begin match p with 201 | | POr (t1l,_) -> assert (t1l = nj_check_type e t1) 202 | | _ -> assert false 203 | end; p 204 | | NJ_right (p,t1) -> 205 | begin match p with 206 | | POr (_,t1r) -> assert (t1r = nj_check_type e t1) 207 | | _ -> assert false 208 | end; p 209 | | NJ_disj (p,t1,t2,t3) -> 210 | begin match nj_check_type e t1,nj_check_type e t2,nj_check_type e t3 with 211 | | POr (t1l,t1r), PArrow (t2a,t2b), PArrow (t3a,t3b) -> 212 | assert (t1l = t2a); 213 | assert (t1r = t3a); 214 | assert (t2b = p); 215 | assert (t3b = p); 216 | | _ -> assert false 217 | end; p 218 | end 219 | 220 | let rec convert_lf_internal anum ant sucL sucR pr = 221 | let debug_data = (* debug *) 222 | let suc = 223 | begin match sucL with 224 | | None -> sucR 225 | | Some sucLS -> PArrow (PArrow (sucR,sucLS),sucR) 226 | end in 227 | begin match pr with 228 | | LF_ax x -> 229 | begin match sucL with 230 | | None -> NJ_var (sucR,anum-1-x) 231 | | Some sucLS -> 232 | let sucRL = PArrow (sucR,sucLS) in 233 | NJ_abs (PArrow (sucRL,sucR),sucRL,NJ_var (sucR,anum-1-x+1)) 234 | end 235 | | LF_RT -> NJ_tt 236 | | LF_RC (pr1,pr2) -> 237 | begin match sucR with 238 | | PAnd (t1,t2) -> 239 | let lt1 = convert_lf_internal anum ant sucL t1 pr1 in 240 | let lt2 = convert_lf_internal anum ant sucL t2 pr2 in 241 | begin match sucL with 242 | | None -> NJ_conj (sucR,lt1,lt2) 243 | | Some sucLS -> 244 | let sucRL = PArrow (sucR,sucLS) in 245 | NJ_abs (PArrow (sucRL,sucR),sucRL, (* f : sucR -> sucLS *) 246 | NJ_conj (sucR, 247 | NJ_app (t1, 248 | shift 0 1 lt1, 249 | NJ_abs (PArrow (t1,sucLS),t1, (* x : t1 *) 250 | NJ_app (sucLS, 251 | NJ_var (sucRL,1), (* f *) 252 | NJ_conj (sucR, 253 | NJ_var (t1,0), (* x *) 254 | NJ_app (t2, 255 | shift 0 2 lt2, 256 | NJ_abs (PArrow (t2,sucLS),t2, (* y : t2 *) 257 | NJ_app (sucLS, 258 | NJ_var (sucRL,2), (* f *) 259 | NJ_conj (sucR, 260 | NJ_var (t1,1), (* x *) 261 | NJ_var (t2,0) (* y *) 262 | ) 263 | ) 264 | ) 265 | ) 266 | ) 267 | ) 268 | ) 269 | ), 270 | NJ_app (t2, 271 | shift 0 1 lt2, 272 | NJ_abs (PArrow (t2,sucLS),t2, (* y : t2 *) 273 | NJ_app (sucLS, 274 | NJ_var (sucRL,1), (* f *) 275 | NJ_conj (sucR, 276 | NJ_app (t1, 277 | shift 0 2 lt1, 278 | NJ_abs (PArrow (t1,sucLS),t1, (* x : t1 *) 279 | NJ_app (sucLS, 280 | NJ_var (sucRL,2), (* f *) 281 | NJ_conj (sucR, 282 | NJ_var (t1,0), (* x *) 283 | NJ_var (t2,1) (* y *) 284 | ) 285 | ) 286 | ) 287 | ), 288 | NJ_var (t2,0) (* y *) 289 | ) 290 | ) 291 | ) 292 | ) 293 | ) 294 | ) 295 | end 296 | | _ -> raise (Invalid_argument "LF_RC given, but not PAnd") 297 | end 298 | | LF_RDL pr -> 299 | begin match sucR with 300 | | POr (t1,t2) -> 301 | begin match sucL with 302 | | None -> 303 | let lt = convert_lf_internal anum ant sucL t1 pr in 304 | NJ_left (sucR,lt) 305 | | Some sucLS -> 306 | let sucRL = PArrow (sucR,sucLS) in 307 | let paramT1 = PArrow (t2,sucR) in 308 | let ltt = PArrow (PArrow (t1,sucR),t1) in 309 | let lt = convert_lf_internal (anum+2) 310 | ((paramT1,anum)::(sucRL,anum+1)::ant) (Some sucR) t1 pr in 311 | let lt = abs_over paramT1 (abs_over sucRL lt) in 312 | NJ_abs (PArrow(sucRL,sucR),sucRL, (* f : sucR -> sucLS *) 313 | NJ_left (sucR, 314 | NJ_app (t1, 315 | NJ_app (ltt, 316 | NJ_app (PArrow (sucRL,ltt), 317 | shift 0 1 lt, 318 | NJ_abs (PArrow (t2,sucR),t2, (* y : t2 *) 319 | NJ_right (sucR, 320 | NJ_var (t2,0) (* y *) 321 | ) 322 | ) 323 | ), 324 | NJ_var (sucRL,0) (* f *) 325 | ), 326 | NJ_abs (PArrow(t1,sucR),t1, (* x : t1 *) 327 | NJ_left (sucR, 328 | NJ_var (t1,0) (* x *) 329 | ) 330 | ) 331 | ) 332 | ) 333 | ) 334 | end 335 | | _ -> raise (Invalid_argument "LF_RDL given, but not POr") 336 | end 337 | | LF_RDR pr -> 338 | begin match sucR with 339 | | POr (t1,t2) -> 340 | begin match sucL with 341 | | None -> 342 | let lt = convert_lf_internal anum ant sucL t2 pr in 343 | NJ_right (sucR,lt) 344 | | Some sucLS -> 345 | let sucRL = PArrow (sucR,sucLS) in 346 | let paramT1 = PArrow (t1,sucR) in 347 | let ltt = PArrow (PArrow (t2,sucR),t2) in 348 | let lt = convert_lf_internal (anum+2) 349 | ((paramT1,anum)::(sucRL,anum+1)::ant) (Some sucR) t2 pr in 350 | let lt = abs_over paramT1 (abs_over sucRL lt) in 351 | NJ_abs (PArrow(sucRL,sucR),sucRL, (* f : sucR -> sucLS *) 352 | NJ_right (sucR, 353 | NJ_app (t2, 354 | NJ_app (ltt, 355 | NJ_app (PArrow (sucRL,ltt), 356 | shift 0 1 lt, 357 | NJ_abs (PArrow (t1,sucR),t1, (* x : t1 *) 358 | NJ_right (sucR, 359 | NJ_var (t1,0) (* x *) 360 | ) 361 | ) 362 | ), 363 | NJ_var (sucRL,0) (* f *) 364 | ), 365 | NJ_abs (PArrow(t2,sucR),t2, (* y : t2 *) 366 | NJ_left (sucR, 367 | NJ_var (t2,0) (* y *) 368 | ) 369 | ) 370 | ) 371 | ) 372 | ) 373 | end 374 | | _ -> raise (Invalid_argument "LF_RDR given, but not POr") 375 | end 376 | | LF_RI pr -> 377 | begin match sucR with 378 | | PArrow (t1,t2) -> 379 | let lt = 380 | convert_lf_internal (anum+1) ((t1,anum)::ant) sucL t2 pr in 381 | let lt = abs_over t1 lt in 382 | begin match sucL with 383 | | None -> lt 384 | | Some sucLS -> 385 | let sucRL = PArrow (sucR,sucLS) in 386 | NJ_abs (PArrow (sucRL,sucR),sucRL, (* f : sucR -> sucLS *) 387 | NJ_abs (sucR,t1, (* g : t1 *) 388 | NJ_app (t2, 389 | NJ_app (PArrow(PArrow (t2,sucLS),t2), 390 | shift 0 2 lt, 391 | NJ_var (t1,0) (* g *) 392 | ), 393 | NJ_abs (PArrow (t2,sucLS),t2, (* y : t2 *) 394 | NJ_app (sucLS, 395 | NJ_var (sucRL,2), (* f *) 396 | NJ_abs (sucR,t1, (* _ : t1 *) 397 | NJ_var (t2,1) (* y *) 398 | ) 399 | ) 400 | ) 401 | ) 402 | ) 403 | ) 404 | end 405 | | _ -> raise (Invalid_argument "LF_RI given, but not PArrow") 406 | end 407 | | LF_LT (x,pr) -> 408 | let (ant0,t,ant1) = cutAnt ant x in 409 | convert_lf_internal anum (ant0@ant1) sucL sucR pr 410 | | LF_LB x -> 411 | NJ_ab (suc,NJ_var (PBot,anum-1-x)) 412 | | LF_LC (x,pr) -> 413 | let (ant0,t,ant1) = cutAnt ant x in 414 | begin match t with 415 | | PAnd (t1,t2) -> 416 | let lt = convert_lf_internal (anum+2) 417 | (ant0@(t1,anum)::(t2,anum+1)::ant1) sucL sucR pr in 418 | let lt = abs_over t1 (abs_over t2 lt) in 419 | let var = NJ_var (t,anum-1-x) in 420 | NJ_app (suc, 421 | NJ_app (PArrow (t2,suc), 422 | lt, 423 | NJ_fst (t1,var) 424 | ), 425 | NJ_snd (t2,var) 426 | ) 427 | | _ -> raise (Invalid_argument "LF_LC given, but not PAnd") 428 | end 429 | | LF_LD (x,pr1,pr2) -> 430 | let (ant0,t,ant1) = cutAnt ant x in 431 | begin match t with 432 | | POr (t1,t2) -> 433 | let lt1 = convert_lf_internal (anum+1) 434 | (ant0@(t1,anum)::ant1) sucL sucR pr1 in 435 | let lt2 = convert_lf_internal (anum+1) 436 | (ant0@(t2,anum)::ant1) sucL sucR pr2 in 437 | let lt1 = abs_over t1 lt1 in 438 | let lt2 = abs_over t2 lt2 in 439 | NJ_disj (suc, 440 | NJ_var (t,anum-1-x), 441 | lt1, 442 | lt2 443 | ) 444 | | _ -> raise (Invalid_argument "LF_LD given, but not POr") 445 | end 446 | | LF_LIT (x,pr) -> 447 | let (ant0,t,ant1) = cutAnt ant x in 448 | begin match t with 449 | | PArrow (_,t2) -> 450 | let lt = convert_lf_internal (anum+1) 451 | (ant0@(t2,anum)::ant1) sucL sucR pr in 452 | let lt = abs_over t2 lt in 453 | let var = NJ_var (t,anum-1-x) in 454 | NJ_app (suc, 455 | lt, 456 | NJ_app (t2,var,NJ_tt) 457 | ) 458 | | _ -> raise (Invalid_argument "LF_LIT given, but not PArrow") 459 | end 460 | | LF_LIB (x,pr) -> 461 | let (ant0,t,ant1) = cutAnt ant x in 462 | convert_lf_internal anum (ant0@ant1) sucL sucR pr 463 | | LF_LIP (x,y,pr) -> 464 | let (ant0,t,ant1) = cutAnt ant x in 465 | begin match t with 466 | | PArrow (t1,t2) -> 467 | let lt = convert_lf_internal (anum+1) 468 | (ant0@(t2,anum)::ant1) sucL sucR pr in 469 | let lt = abs_over t2 lt in 470 | let var1 = NJ_var (t,anum-1-x) in 471 | let var2 = NJ_var (t1,anum-1-y) in 472 | NJ_app (suc, 473 | lt, 474 | NJ_app (t2,var1,var2) 475 | ) 476 | | _ -> raise (Invalid_argument "LF_LIP given, but not PArrow") 477 | end 478 | | LF_LIC (x,pr) -> 479 | let (ant0,t,ant1) = cutAnt ant x in 480 | begin match t with 481 | | PArrow (PAnd (t1,t2),t3) -> 482 | let atype = PArrow (t1,PArrow (t2,t3)) in 483 | let lt = convert_lf_internal (anum+1) 484 | (ant0@(atype,anum)::ant1) 485 | sucL sucR pr in 486 | let lt = abs_over atype lt in 487 | NJ_app (suc, 488 | lt, 489 | NJ_abs (atype,t1, (* x : t1 *) 490 | NJ_abs (PArrow (t2,t3),t2, (* y : t2 *) 491 | NJ_app (t3, 492 | NJ_var (t,anum-1-x+2), 493 | NJ_conj (PAnd (t1,t2), 494 | NJ_var (t1,1), (* x *) 495 | NJ_var (t2,0) (* y *) 496 | ) 497 | ) 498 | ) 499 | ) 500 | ) 501 | | _ -> raise (Invalid_argument "LF_LIC given, but not PAnd") 502 | end 503 | | LF_LID (x,pr) -> 504 | let (ant0,t,ant1) = cutAnt ant x in 505 | begin match t with 506 | | PArrow (POr (t1,t2) as t12,t3) -> 507 | let paramT1 = PArrow (t1,t12) in 508 | let paramT2 = PArrow (t2,t12) in 509 | let lt = convert_lf_internal (anum+3) (ant0@ 510 | (paramT1,anum):: 511 | (paramT2,anum+1):: 512 | (t,anum+2):: 513 | ant1) sucL sucR pr in 514 | let lt = abs_over paramT1 (abs_over paramT2 (abs_over t lt)) in 515 | NJ_app (suc, 516 | NJ_app (PArrow (t,suc), 517 | NJ_app (PArrow (paramT2,PArrow (t,suc)), 518 | lt, 519 | NJ_abs (paramT1,t1, 520 | NJ_left (t12,NJ_var (t1,0)) 521 | ) 522 | ), 523 | NJ_abs (paramT2,t2, 524 | NJ_right (t12,NJ_var (t2,0)) 525 | ) 526 | ), 527 | NJ_var (t,anum-1-x) 528 | ) 529 | | _ -> raise (Invalid_argument "LF_LID given, but not PArrow-POr") 530 | end 531 | | LF_LII (x,pr1,pr2) -> 532 | let (ant0,t,ant1) = cutAnt ant x in 533 | begin match t with 534 | | PArrow (PArrow (t1,t2) as t12,t3) -> 535 | begin match sucL with 536 | | None -> 537 | let lt1 = convert_lf_internal (anum+1) 538 | (ant0@(t1,anum)::ant1) (Some t3) t2 pr1 in 539 | let lt2 = (convert_lf_internal (anum+1) 540 | (ant0@(t3,anum)::ant1) sucL sucR) pr2 in 541 | let lt1 = abs_over t1 lt1 in 542 | let lt2 = abs_over t3 lt2 in 543 | NJ_app (sucR, 544 | lt2, 545 | NJ_app (t3, 546 | NJ_var (t,anum-1-x), 547 | NJ_abs (t12,t1, (* x : t1 *) 548 | NJ_app (t2, 549 | NJ_app (PArrow (PArrow (t2,t3),t2), 550 | shift 0 1 lt1, 551 | NJ_var (t1,0) (* x *) 552 | ), 553 | NJ_abs (PArrow (t2,t3),t2, (* y : t2 *) 554 | NJ_app (t3, 555 | NJ_var (t,anum-1-x+2), 556 | NJ_abs (t12,t1, (* _ : t1 *) 557 | NJ_var (t2,1) (* y *) 558 | ) 559 | ) 560 | ) 561 | ) 562 | ) 563 | ) 564 | ) 565 | | Some sucLS -> 566 | let atype = PArrow (sucR,sucLS) in 567 | let lt1 = convert_lf_internal (anum+2) 568 | (ant0@(atype,anum)::(t1,anum+1)::ant1) 569 | (Some t3) t2 pr1 in 570 | let lt2 = (convert_lf_internal (anum+1) 571 | (ant0@(t3,anum)::ant1) sucL sucR) pr2 in 572 | let lt1 = abs_over atype (abs_over t1 lt1) in 573 | let lt2 = abs_over t3 lt2 in 574 | NJ_abs (suc,atype, (* f : sucR -> sucLS *) 575 | NJ_app (sucR, 576 | NJ_app (suc, 577 | shift 0 1 lt2, 578 | NJ_app (t3, 579 | NJ_var (t,anum-1-x+1), 580 | NJ_abs (t12,t1, (* x : t1 *) 581 | NJ_app (t2, 582 | NJ_app (PArrow (PArrow (t2,t3),t2), 583 | NJ_app (PArrow (t1,PArrow (PArrow (t2,t3),t2)), 584 | shift 0 2 lt1, 585 | NJ_var (atype,1) (* f *) 586 | ), 587 | NJ_var (t1,0) (* x *) 588 | ), 589 | NJ_abs (PArrow (t2,t3),t2, (* y : t2 *) 590 | NJ_app (t3, 591 | NJ_var (t,anum-1-x+3), 592 | NJ_abs (t12,t1, (* _ : t1 *) 593 | NJ_var (t2,1) (* y *) 594 | ) 595 | ) 596 | ) 597 | ) 598 | ) 599 | ) 600 | ), 601 | NJ_var (atype,0) (* f *) 602 | ) 603 | ) 604 | end 605 | | _ -> raise (Invalid_argument "LF_LII given, but not PArrow-PArrow") 606 | end 607 | end 608 | (* debug *) 609 | in 610 | (* 611 | eprintf "debug: "; 612 | List.iter (fun (x,y) -> 613 | eprintf "%a[%d,%d],@ " 614 | (pp_print_pterm empty_env) x 615 | y (anum-1-y) 616 | ) ant; 617 | begin match sucL with 618 | | None -> 619 | eprintf "@ /@ %d@ |-@ %a@," anum 620 | (pp_print_pterm empty_env) sucR 621 | | Some sucLS -> 622 | eprintf "@ /@ %d@ [%a -> %a],@ |-@ %a@," anum 623 | (pp_print_pterm empty_env) sucR 624 | (pp_print_pterm empty_env) sucLS 625 | (pp_print_pterm empty_env) sucR 626 | end; 627 | eprintf "proof = %a@," (pp_print_proof_internal empty_env anum 100 ant sucL 628 | sucR) pr; 629 | eprintf "output : %a@." (pp_print_lambda empty_env) debug_data; 630 | *) 631 | debug_data 632 | 633 | let convert_lf sucR pr = 634 | convert_lf_internal 0 [] None sucR pr 635 | 636 | let rec compress_proof_internal1 p t = 637 | let result = 638 | begin match t with 639 | | NJ_var (_,_) -> None 640 | | NJ_app (_,t1,t2) -> 641 | begin match compress_proof_internal1 p t1 with 642 | | Some k -> Some k 643 | | None -> compress_proof_internal1 p t2 644 | end 645 | | NJ_abs (_,_,ta) -> None 646 | | NJ_tt -> None 647 | | NJ_ab (_,t1) -> 648 | compress_proof_internal1 p t1 649 | | NJ_conj (_,t1,t2) -> 650 | begin match compress_proof_internal1 p t1 with 651 | | Some k -> Some k 652 | | None -> compress_proof_internal1 p t2 653 | end 654 | | NJ_fst (_,t1) -> 655 | compress_proof_internal1 p t1 656 | | NJ_snd (_,t1) -> 657 | compress_proof_internal1 p t1 658 | | NJ_left (_,t1) -> 659 | compress_proof_internal1 p t1 660 | | NJ_right (_,t1) -> 661 | compress_proof_internal1 p t1 662 | | NJ_disj (_,t1,t2,t3) -> 663 | begin match compress_proof_internal1 p t1 with 664 | | Some k -> Some k 665 | | None -> 666 | begin match compress_proof_internal1 p t2 with 667 | | Some k -> Some k 668 | | None -> compress_proof_internal1 p t3 669 | end 670 | end 671 | end in 672 | begin match result with 673 | | Some k -> Some k 674 | | None -> 675 | if nj_type t = p then 676 | Some t 677 | else if nj_type t = PBot then 678 | Some (NJ_ab (p,t)) 679 | else 680 | None 681 | end 682 | 683 | let rec findstack p = function 684 | | [] -> raise Not_found 685 | | pp::t when pp = p -> 0 686 | | h::t -> 1 + findstack p t 687 | 688 | let rec compress_proof_internal2 stack t = 689 | try 690 | NJ_var (nj_type t,findstack (nj_type t) stack) 691 | with Not_found -> 692 | let t = 693 | begin match compress_proof_internal1 (nj_type t) t with 694 | | Some t -> t 695 | | None -> t 696 | end in 697 | begin match t with 698 | | NJ_var (_,_) -> t 699 | | NJ_app (p,t1,t2) -> 700 | NJ_app (p, 701 | compress_proof_internal2 stack t1, 702 | compress_proof_internal2 stack t2) 703 | | NJ_abs (p,pa,ta) -> 704 | NJ_abs (p,pa,compress_proof_internal2 (pa::stack) ta) 705 | | NJ_tt -> t 706 | | NJ_ab (p,t1) -> 707 | NJ_ab (p,compress_proof_internal2 stack t1) 708 | | NJ_conj (p,t1,t2) -> 709 | NJ_conj (p, 710 | compress_proof_internal2 stack t1, 711 | compress_proof_internal2 stack t2) 712 | | NJ_fst (p,t1) -> 713 | NJ_fst (p,compress_proof_internal2 stack t1) 714 | | NJ_snd (p,t1) -> 715 | NJ_snd (p,compress_proof_internal2 stack t1) 716 | | NJ_left (p,t1) -> 717 | NJ_left (p,compress_proof_internal2 stack t1) 718 | | NJ_right (p,t1) -> 719 | NJ_right (p,compress_proof_internal2 stack t1) 720 | | NJ_disj (p,t1,t2,t3) -> 721 | NJ_disj (p, 722 | compress_proof_internal2 stack t1, 723 | compress_proof_internal2 stack t2, 724 | compress_proof_internal2 stack t3) 725 | end 726 | 727 | let postproc_proof t = 728 | let t = reduce t in 729 | let t = compress_proof_internal2 [] t in 730 | t 731 | 732 | type proof_tree = 733 | | PTassumption of string 734 | | PTaxiom of string * string 735 | | PTunary of string * string * proof_tree 736 | | PTbinary of string * string * proof_tree * proof_tree 737 | | PTtrinary of string * string * proof_tree * proof_tree * proof_tree 738 | 739 | let pt_append s = function 740 | | PTassumption p -> PTassumption (p^s) 741 | | PTaxiom (p,r) -> PTaxiom (p^s,r) 742 | | PTunary (p,r,t1) -> PTunary (p^s,r,t1) 743 | | PTbinary (p,r,t1,t2) -> PTbinary (p^s,r,t1,t2) 744 | | PTtrinary (p,r,t1,t2,t3) -> PTtrinary (p^s,r,t1,t2,t3) 745 | 746 | let pt_prop = function 747 | | PTassumption p -> p 748 | | PTaxiom (p,r) -> p 749 | | PTunary (p,r,t1) -> p 750 | | PTbinary (p,r,t1,t2) -> p 751 | | PTtrinary (p,r,t1,t2,t3) -> p 752 | 753 | let rec print_proof_tree ppf pt = 754 | begin match pt with 755 | | PTassumption p -> 756 | Format.fprintf ppf "\\AxiomC{%s}@," p 757 | | PTaxiom (p,r) -> 758 | Format.fprintf ppf "\\AxiomC{}@,"; 759 | Format.fprintf ppf "\\RightLabel{\\scriptsize%s}@," r; 760 | Format.fprintf ppf "\\UnaryInfC{%s}@," p 761 | | PTunary (p,r,t1) -> 762 | print_proof_tree ppf t1; 763 | Format.fprintf ppf "\\RightLabel{\\scriptsize%s}@," r; 764 | Format.fprintf ppf "\\UnaryInfC{%s}@," p 765 | | PTbinary (p,r,t1,t2) -> 766 | print_proof_tree ppf t1; 767 | print_proof_tree ppf t2; 768 | Format.fprintf ppf "\\RightLabel{\\scriptsize%s}@," r; 769 | Format.fprintf ppf "\\BinaryInfC{%s}@," p 770 | | PTtrinary (p,r,t1,t2,t3) -> 771 | print_proof_tree ppf t1; 772 | print_proof_tree ppf t2; 773 | print_proof_tree ppf t3; 774 | Format.fprintf ppf "\\RightLabel{\\scriptsize%s}@," r; 775 | Format.fprintf ppf "\\TrinaryInfC{%s}@," p 776 | end 777 | 778 | let nj_remove_abstraction t = 779 | begin match t with 780 | | NJ_abs (p,pa,ta) -> ta 781 | | _ -> 782 | let (p1,p2) = 783 | begin match nj_type t with 784 | | PArrow (p1,p2) -> (p1,p2) 785 | | _ -> assert false 786 | end in 787 | NJ_app (p2,shift 0 1 t,NJ_var (p1,0)) 788 | end 789 | 790 | let rec nj_make_tree env stack_e stack_n t = 791 | begin match t with 792 | | NJ_var (p,x) -> 793 | PTassumption ( 794 | Format.asprintf "[%a]$_{%d}$" 795 | (pp_print_pterm_latex env 5) p 796 | (List.nth stack_e x) 797 | ) 798 | | NJ_app (p,t1,t2) -> 799 | PTbinary ( 800 | Format.asprintf "%a" 801 | (pp_print_pterm_latex env 5) p, 802 | "$\\to E$", 803 | nj_make_tree env stack_e stack_n t1, 804 | nj_make_tree env stack_e stack_n t2 805 | ) 806 | | NJ_abs (p,pa,ta) -> 807 | let assump_num = 1 + !stack_n in 808 | stack_n := assump_num; 809 | let stack_e = assump_num :: stack_e in 810 | PTunary ( 811 | Format.asprintf "%a" 812 | (pp_print_pterm_latex env 5) p, 813 | Format.asprintf "$\\to I(%d)$" assump_num, 814 | nj_make_tree env stack_e stack_n ta 815 | ) 816 | | NJ_tt -> 817 | PTaxiom ( 818 | Format.asprintf "%a" 819 | (pp_print_pterm_latex env 5) PTop, 820 | "$\\top I$" 821 | ) 822 | | NJ_ab (p,t1) -> 823 | PTunary ( 824 | Format.asprintf "%a" 825 | (pp_print_pterm_latex env 5) p, 826 | "$\\bot E$", 827 | nj_make_tree env stack_e stack_n t1 828 | ) 829 | | NJ_conj (p,t1,t2) -> 830 | PTbinary ( 831 | Format.asprintf "%a" 832 | (pp_print_pterm_latex env 5) p, 833 | "$\\land I$", 834 | nj_make_tree env stack_e stack_n t1, 835 | nj_make_tree env stack_e stack_n t2 836 | ) 837 | | NJ_fst (p,t1) -> 838 | PTunary ( 839 | Format.asprintf "%a" 840 | (pp_print_pterm_latex env 5) p, 841 | "$\\land E_1$", 842 | nj_make_tree env stack_e stack_n t1 843 | ) 844 | | NJ_snd (p,t1) -> 845 | PTunary ( 846 | Format.asprintf "%a" 847 | (pp_print_pterm_latex env 5) p, 848 | "$\\land E_2$", 849 | nj_make_tree env stack_e stack_n t1 850 | ) 851 | | NJ_left (p,t1) -> 852 | PTunary ( 853 | Format.asprintf "%a" 854 | (pp_print_pterm_latex env 5) p, 855 | "$\\lor I_1$", 856 | nj_make_tree env stack_e stack_n t1 857 | ) 858 | | NJ_right (p,t1) -> 859 | PTunary ( 860 | Format.asprintf "%a" 861 | (pp_print_pterm_latex env 5) p, 862 | "$\\lor I_2$", 863 | nj_make_tree env stack_e stack_n t1 864 | ) 865 | | NJ_disj (p,t1,t2,t3) -> 866 | let assump_num = 1 + !stack_n in 867 | stack_n := assump_num; 868 | let stack_e2 = assump_num :: stack_e in 869 | PTtrinary ( 870 | Format.asprintf "%a" 871 | (pp_print_pterm_latex env 5) p, 872 | Format.asprintf "$\\lor E(%d)$" assump_num, 873 | nj_make_tree env stack_e stack_n t1, 874 | nj_make_tree env stack_e2 stack_n (nj_remove_abstraction t2), 875 | nj_make_tree env stack_e2 stack_n (nj_remove_abstraction t3) 876 | ) 877 | end 878 | 879 | let proof_tree_threshold = 40 880 | 881 | let numberstr number = "\\ \\textcolor{red}{("^string_of_int number^")}" 882 | let rec split_proof_tree trees number pt = 883 | begin match pt with 884 | | PTassumption p -> (pt,1,trees,number) 885 | | PTaxiom (p,r) -> (pt,1,trees,number) 886 | | PTunary (p,r,t1) -> 887 | let (t1s,t1n,trees,number) = split_proof_tree2 trees number t1 in 888 | (PTunary (p,r,t1s),t1n+1,trees,number) 889 | | PTbinary (p,r,t1,t2) -> 890 | let (t1s,t1n,trees,number) = split_proof_tree2 trees number t1 in 891 | let (t2s,t2n,trees,number) = split_proof_tree2 trees number t2 in 892 | (PTbinary (p,r,t1s,t2s),t1n+t2n+1,trees,number) 893 | | PTtrinary (p,r,t1,t2,t3) -> 894 | let (t1s,t1n,trees,number) = split_proof_tree2 trees number t1 in 895 | let (t2s,t2n,trees,number) = split_proof_tree2 trees number t2 in 896 | let (t3s,t3n,trees,number) = split_proof_tree2 trees number t3 in 897 | (PTtrinary (p,r,t1s,t2s,t3s),t1n+t2n+t3n+1,trees,number) 898 | end 899 | and split_proof_tree2 trees number pt = 900 | let (pts,ptn,trees,number) = split_proof_tree trees number pt in 901 | if ptn > proof_tree_threshold then 902 | (PTassumption (pt_prop pts ^ (numberstr number)), 903 | 1,pt_append (numberstr number) pts::trees,number+1) 904 | else 905 | (pts,ptn,trees,number) 906 | 907 | let print_nj_latex env ppf d = 908 | let pt = nj_make_tree env [] (ref 0) d in 909 | let (pts,_,trees,_) = split_proof_tree [] 1 pt in 910 | let trees = pts::trees in 911 | List.iter (fun x -> 912 | Format.fprintf ppf "%s@." "\\begin{prooftree}"; 913 | Format.fprintf ppf "%a@." print_proof_tree x; 914 | Format.fprintf ppf "%s@.@." "\\end{prooftree}" 915 | ) (List.rev trees); 916 | -------------------------------------------------------------------------------- /OCamlMakefile: -------------------------------------------------------------------------------- 1 | ########################################################################### 2 | # OCamlMakefile 3 | # Copyright (C) 1999- Markus Mottl 4 | # 5 | # For updates see: 6 | # http://www.ocaml.info/home/ocaml_sources.html 7 | # 8 | ########################################################################### 9 | 10 | # Modified by damien for .glade.ml compilation 11 | 12 | # Set these variables to the names of the sources to be processed and 13 | # the result variable. Order matters during linkage! 14 | 15 | ifndef SOURCES 16 | SOURCES := foo.ml 17 | endif 18 | export SOURCES 19 | 20 | ifndef RES_CLIB_SUF 21 | RES_CLIB_SUF := _stubs 22 | endif 23 | export RES_CLIB_SUF 24 | 25 | ifndef RESULT 26 | RESULT := foo 27 | endif 28 | export RESULT := $(strip $(RESULT)) 29 | 30 | export LIB_PACK_NAME 31 | 32 | ifndef DOC_FILES 33 | DOC_FILES := $(filter %.mli, $(SOURCES)) 34 | endif 35 | export DOC_FILES 36 | FIRST_DOC_FILE := $(firstword $(DOC_FILES)) 37 | 38 | export BCSUFFIX 39 | export NCSUFFIX 40 | 41 | ifndef TOPSUFFIX 42 | TOPSUFFIX := .top 43 | endif 44 | export TOPSUFFIX 45 | 46 | # Eventually set include- and library-paths, libraries to link, 47 | # additional compilation-, link- and ocamlyacc-flags 48 | # Path- and library information needs not be written with "-I" and such... 49 | # Define THREADS if you need it, otherwise leave it unset (same for 50 | # USE_CAMLP4)! 51 | 52 | export THREADS 53 | export VMTHREADS 54 | export ANNOTATE 55 | export USE_CAMLP4 56 | 57 | export INCDIRS 58 | export LIBDIRS 59 | export EXTLIBDIRS 60 | export RESULTDEPS 61 | export OCAML_DEFAULT_DIRS 62 | 63 | export LIBS 64 | export CLIBS 65 | export CFRAMEWORKS 66 | 67 | export OCAMLFLAGS 68 | export OCAMLNCFLAGS 69 | export OCAMLBCFLAGS 70 | 71 | export OCAMLLDFLAGS 72 | export OCAMLNLDFLAGS 73 | export OCAMLBLDFLAGS 74 | 75 | export OCAMLMKLIB_FLAGS 76 | 77 | ifndef OCAMLCPFLAGS 78 | OCAMLCPFLAGS := a 79 | endif 80 | export OCAMLCPFLAGS 81 | 82 | ifndef DOC_DIR 83 | DOC_DIR := doc 84 | endif 85 | export DOC_DIR 86 | 87 | export PPFLAGS 88 | 89 | export LFLAGS 90 | export YFLAGS 91 | export IDLFLAGS 92 | 93 | export OCAMLDOCFLAGS 94 | 95 | export OCAMLFIND_INSTFLAGS 96 | 97 | export DVIPSFLAGS 98 | 99 | export STATIC 100 | 101 | # Add a list of optional trash files that should be deleted by "make clean" 102 | export TRASH 103 | 104 | ECHO := echo 105 | 106 | ifdef REALLY_QUIET 107 | export REALLY_QUIET 108 | ECHO := true 109 | LFLAGS := $(LFLAGS) -q 110 | YFLAGS := $(YFLAGS) -q 111 | endif 112 | 113 | #################### variables depending on your OCaml-installation 114 | 115 | SYSTEM := $(shell ocamlc -config 2>/dev/null | grep system | sed 's/system: //') 116 | # This may be 117 | # - mingw 118 | # - mingw64 119 | # - win32 120 | # - cygwin 121 | # - some other string means Unix 122 | # - empty means ocamlc does not support -config 123 | 124 | ifeq ($(SYSTEM),$(filter $(SYSTEM),mingw mingw64)) 125 | MINGW=1 126 | endif 127 | ifeq ($(SYSTEM),win32) 128 | MSVC=1 129 | endif 130 | 131 | ifdef MINGW 132 | export MINGW 133 | WIN32 := 1 134 | # The default value 'cc' makes 'ocamlc -cc "cc"' raises the error 'The 135 | # NTVDM CPU has encountered an illegal instruction'. 136 | ifndef CC 137 | MNO_CYGWIN := $(shell gcc -Wextra -v --help 2>/dev/null | grep -q '\-mno-cygwin'; echo $$?) 138 | CC := gcc 139 | else 140 | MNO_CYGWIN := $(shell $$CC -Wextra -v --help 2>/dev/null | grep -q '\-mno-cygwin'; echo $$?) 141 | endif 142 | # We are compiling with cygwin tools: 143 | ifeq ($(MNO_CYGWIN),0) 144 | CFLAGS_WIN32 := -mno-cygwin 145 | endif 146 | # The OCaml C header files use this flag: 147 | CFLAGS += -D__MINGW32__ 148 | endif 149 | ifdef MSVC 150 | export MSVC 151 | WIN32 := 1 152 | ifndef STATIC 153 | CPPFLAGS_WIN32 := -DCAML_DLL 154 | endif 155 | CFLAGS_WIN32 += -nologo 156 | EXT_OBJ := obj 157 | EXT_LIB := lib 158 | ifeq ($(CC),gcc) 159 | # work around GNU Make default value 160 | ifdef THREADS 161 | CC := cl -MT 162 | else 163 | CC := cl 164 | endif 165 | endif 166 | ifeq ($(CXX),g++) 167 | # work around GNU Make default value 168 | CXX := $(CC) 169 | endif 170 | CFLAG_O := -Fo 171 | endif 172 | ifdef WIN32 173 | EXT_CXX := cpp 174 | EXE := .exe 175 | endif 176 | 177 | ifndef EXT_OBJ 178 | EXT_OBJ := o 179 | endif 180 | ifndef EXT_LIB 181 | EXT_LIB := a 182 | endif 183 | ifndef EXT_CXX 184 | EXT_CXX := cc 185 | endif 186 | ifndef EXE 187 | EXE := # empty 188 | endif 189 | ifndef CFLAG_O 190 | CFLAG_O := -o # do not delete this comment (preserves trailing whitespace)! 191 | endif 192 | 193 | export CC 194 | export CXX 195 | export CFLAGS 196 | export CXXFLAGS 197 | export LDFLAGS 198 | export CPPFLAGS 199 | 200 | ifndef RPATH_FLAG 201 | ifdef ELF_RPATH_FLAG 202 | RPATH_FLAG := $(ELF_RPATH_FLAG) 203 | else 204 | RPATH_FLAG := -R 205 | endif 206 | endif 207 | export RPATH_FLAG 208 | 209 | ifndef MSVC 210 | ifndef PIC_CFLAGS 211 | PIC_CFLAGS := -fPIC 212 | endif 213 | ifndef PIC_CPPFLAGS 214 | PIC_CPPFLAGS := -DPIC 215 | endif 216 | endif 217 | 218 | export PIC_CFLAGS 219 | export PIC_CPPFLAGS 220 | 221 | BCRESULT := $(addsuffix $(BCSUFFIX), $(RESULT)) 222 | NCRESULT := $(addsuffix $(NCSUFFIX), $(RESULT)) 223 | TOPRESULT := $(addsuffix $(TOPSUFFIX), $(RESULT)) 224 | 225 | ifndef OCAMLFIND 226 | OCAMLFIND := ocamlfind 227 | endif 228 | export OCAMLFIND 229 | 230 | ifndef OCAML 231 | OCAML := ocaml 232 | endif 233 | export OCAML 234 | 235 | ifndef OCAMLC 236 | OCAMLC := ocamlc 237 | endif 238 | export OCAMLC 239 | 240 | ifndef OCAMLOPT 241 | OCAMLOPT := ocamlopt 242 | endif 243 | export OCAMLOPT 244 | 245 | ifndef OCAMLMKTOP 246 | OCAMLMKTOP := ocamlmktop 247 | endif 248 | export OCAMLMKTOP 249 | 250 | ifndef OCAMLCP 251 | OCAMLCP := ocamlcp 252 | endif 253 | export OCAMLCP 254 | 255 | ifndef OCAMLDEP 256 | OCAMLDEP := ocamldep 257 | endif 258 | export OCAMLDEP 259 | 260 | ifndef OCAMLLEX 261 | OCAMLLEX := ocamllex 262 | endif 263 | export OCAMLLEX 264 | 265 | ifndef OCAMLYACC 266 | OCAMLYACC := ocamlyacc 267 | endif 268 | export OCAMLYACC 269 | 270 | ifndef OCAMLMKLIB 271 | OCAMLMKLIB := ocamlmklib 272 | endif 273 | export OCAMLMKLIB 274 | 275 | ifndef OCAML_GLADECC 276 | OCAML_GLADECC := lablgladecc2 277 | endif 278 | export OCAML_GLADECC 279 | 280 | ifndef OCAML_GLADECC_FLAGS 281 | OCAML_GLADECC_FLAGS := 282 | endif 283 | export OCAML_GLADECC_FLAGS 284 | 285 | ifndef CAMELEON_REPORT 286 | CAMELEON_REPORT := report 287 | endif 288 | export CAMELEON_REPORT 289 | 290 | ifndef CAMELEON_REPORT_FLAGS 291 | CAMELEON_REPORT_FLAGS := 292 | endif 293 | export CAMELEON_REPORT_FLAGS 294 | 295 | ifndef CAMELEON_ZOGGY 296 | CAMELEON_ZOGGY := camlp4o pa_zog.cma pr_o.cmo 297 | endif 298 | export CAMELEON_ZOGGY 299 | 300 | ifndef CAMELEON_ZOGGY_FLAGS 301 | CAMELEON_ZOGGY_FLAGS := 302 | endif 303 | export CAMELEON_ZOGGY_FLAGS 304 | 305 | ifndef OXRIDL 306 | OXRIDL := oxridl 307 | endif 308 | export OXRIDL 309 | 310 | ifndef CAMLIDL 311 | CAMLIDL := camlidl 312 | endif 313 | export CAMLIDL 314 | 315 | ifndef CAMLIDLDLL 316 | CAMLIDLDLL := camlidldll 317 | endif 318 | export CAMLIDLDLL 319 | 320 | ifndef NOIDLHEADER 321 | MAYBE_IDL_HEADER := -header 322 | endif 323 | export NOIDLHEADER 324 | 325 | export NO_CUSTOM 326 | 327 | ifndef CAMLP4 328 | CAMLP4 := camlp4 329 | endif 330 | export CAMLP4 331 | 332 | ifndef REAL_OCAMLFIND 333 | ifdef PACKS 334 | ifndef CREATE_LIB 335 | ifdef THREADS 336 | PACKS += threads 337 | endif 338 | endif 339 | empty := 340 | space := $(empty) $(empty) 341 | comma := , 342 | ifdef PREDS 343 | PRE_OCAML_FIND_PREDICATES := $(subst $(space),$(comma),$(PREDS)) 344 | PRE_OCAML_FIND_PACKAGES := $(subst $(space),$(comma),$(PACKS)) 345 | OCAML_FIND_PREDICATES := -predicates $(PRE_OCAML_FIND_PREDICATES) 346 | # OCAML_DEP_PREDICATES := -syntax $(PRE_OCAML_FIND_PREDICATES) 347 | OCAML_FIND_PACKAGES := $(OCAML_FIND_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) 348 | OCAML_DEP_PACKAGES := $(OCAML_DEP_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) 349 | else 350 | OCAML_FIND_PACKAGES := -package $(subst $(space),$(comma),$(PACKS)) 351 | OCAML_DEP_PACKAGES := 352 | endif 353 | OCAML_FIND_LINKPKG := -linkpkg 354 | REAL_OCAMLFIND := $(OCAMLFIND) 355 | endif 356 | endif 357 | 358 | export OCAML_FIND_PACKAGES 359 | export OCAML_DEP_PACKAGES 360 | export OCAML_FIND_LINKPKG 361 | export REAL_OCAMLFIND 362 | 363 | ifndef OCAMLDOC 364 | OCAMLDOC := ocamldoc 365 | endif 366 | export OCAMLDOC 367 | 368 | ifndef LATEX 369 | LATEX := latex 370 | endif 371 | export LATEX 372 | 373 | ifndef DVIPS 374 | DVIPS := dvips 375 | endif 376 | export DVIPS 377 | 378 | ifndef PS2PDF 379 | PS2PDF := ps2pdf 380 | endif 381 | export PS2PDF 382 | 383 | ifndef OCAMLMAKEFILE 384 | OCAMLMAKEFILE := OCamlMakefile 385 | endif 386 | export OCAMLMAKEFILE 387 | 388 | ifndef OCAMLLIBPATH 389 | OCAMLLIBPATH := \ 390 | $(shell $(OCAMLC) 2>/dev/null -where || echo /usr/local/lib/ocaml) 391 | endif 392 | export OCAMLLIBPATH 393 | 394 | ifndef OCAML_LIB_INSTALL 395 | OCAML_LIB_INSTALL := $(OCAMLLIBPATH)/contrib 396 | endif 397 | export OCAML_LIB_INSTALL 398 | 399 | ########################################################################### 400 | 401 | #################### change following sections only if 402 | #################### you know what you are doing! 403 | 404 | # delete target files when a build command fails 405 | .PHONY: .DELETE_ON_ERROR 406 | .DELETE_ON_ERROR: 407 | 408 | # for pedants using "--warn-undefined-variables" 409 | export MAYBE_IDL 410 | export REAL_RESULT 411 | export CAMLIDLFLAGS 412 | export THREAD_FLAG 413 | export RES_CLIB 414 | export MAKEDLL 415 | export ANNOT_FLAG 416 | export C_OXRIDL 417 | export SUBPROJS 418 | export CFLAGS_WIN32 419 | export CPPFLAGS_WIN32 420 | 421 | INCFLAGS := 422 | 423 | SHELL := /bin/sh 424 | 425 | MLDEPDIR := ._d 426 | BCDIDIR := ._bcdi 427 | NCDIDIR := ._ncdi 428 | 429 | FILTER_EXTNS := %.mli %.ml %.mll %.mly %.idl %.oxridl %.c %.m %.$(EXT_CXX) %.rep %.zog %.glade 430 | 431 | FILTERED := $(filter $(FILTER_EXTNS), $(SOURCES)) 432 | SOURCE_DIRS := $(filter-out ./, $(sort $(dir $(FILTERED)))) 433 | 434 | FILTERED_REP := $(filter %.rep, $(FILTERED)) 435 | DEP_REP := $(FILTERED_REP:%.rep=$(MLDEPDIR)/%.d) 436 | AUTO_REP := $(FILTERED_REP:.rep=.ml) 437 | 438 | FILTERED_ZOG := $(filter %.zog, $(FILTERED)) 439 | DEP_ZOG := $(FILTERED_ZOG:%.zog=$(MLDEPDIR)/%.d) 440 | AUTO_ZOG := $(FILTERED_ZOG:.zog=.ml) 441 | 442 | FILTERED_GLADE := $(filter %.glade, $(FILTERED)) 443 | DEP_GLADE := $(FILTERED_GLADE:%.glade=$(MLDEPDIR)/%.d) 444 | AUTO_GLADE := $(FILTERED_GLADE:.glade=.ml) 445 | 446 | FILTERED_ML := $(filter %.ml, $(FILTERED)) 447 | DEP_ML := $(FILTERED_ML:%.ml=$(MLDEPDIR)/%.d) 448 | 449 | FILTERED_MLI := $(filter %.mli, $(FILTERED)) 450 | DEP_MLI := $(FILTERED_MLI:.mli=.di) 451 | 452 | FILTERED_MLL := $(filter %.mll, $(FILTERED)) 453 | DEP_MLL := $(FILTERED_MLL:%.mll=$(MLDEPDIR)/%.d) 454 | AUTO_MLL := $(FILTERED_MLL:.mll=.ml) 455 | 456 | FILTERED_MLY := $(filter %.mly, $(FILTERED)) 457 | DEP_MLY := $(FILTERED_MLY:%.mly=$(MLDEPDIR)/%.d) $(FILTERED_MLY:.mly=.di) 458 | AUTO_MLY := $(FILTERED_MLY:.mly=.mli) $(FILTERED_MLY:.mly=.ml) 459 | 460 | FILTERED_IDL := $(filter %.idl, $(FILTERED)) 461 | DEP_IDL := $(FILTERED_IDL:%.idl=$(MLDEPDIR)/%.d) $(FILTERED_IDL:.idl=.di) 462 | C_IDL := $(FILTERED_IDL:%.idl=%_stubs.c) 463 | ifndef NOIDLHEADER 464 | C_IDL += $(FILTERED_IDL:.idl=.h) 465 | endif 466 | OBJ_C_IDL := $(FILTERED_IDL:%.idl=%_stubs.$(EXT_OBJ)) 467 | AUTO_IDL := $(FILTERED_IDL:.idl=.mli) $(FILTERED_IDL:.idl=.ml) $(C_IDL) 468 | 469 | FILTERED_OXRIDL := $(filter %.oxridl, $(FILTERED)) 470 | DEP_OXRIDL := $(FILTERED_OXRIDL:%.oxridl=$(MLDEPDIR)/%.d) $(FILTERED_OXRIDL:.oxridl=.di) 471 | AUTO_OXRIDL := $(FILTERED_OXRIDL:.oxridl=.mli) $(FILTERED_OXRIDL:.oxridl=.ml) $(C_OXRIDL) 472 | 473 | FILTERED_C_CXX := $(filter %.c %.m %.$(EXT_CXX), $(FILTERED)) 474 | OBJ_C_CXX := $(FILTERED_C_CXX:.c=.$(EXT_OBJ)) 475 | OBJ_C_CXX := $(OBJ_C_CXX:.m=.$(EXT_OBJ)) 476 | OBJ_C_CXX := $(OBJ_C_CXX:.$(EXT_CXX)=.$(EXT_OBJ)) 477 | 478 | PRE_TARGETS += $(AUTO_MLL) $(AUTO_MLY) $(AUTO_IDL) $(AUTO_OXRIDL) $(AUTO_ZOG) $(AUTO_REP) $(AUTO_GLADE) 479 | 480 | ALL_DEPS := $(DEP_ML) $(DEP_MLI) $(DEP_MLL) $(DEP_MLY) $(DEP_IDL) $(DEP_OXRIDL) $(DEP_ZOG) $(DEP_REP) $(DEP_GLADE) 481 | 482 | MLDEPS := $(filter %.d, $(ALL_DEPS)) 483 | MLIDEPS := $(filter %.di, $(ALL_DEPS)) 484 | BCDEPIS := $(MLIDEPS:%.di=$(BCDIDIR)/%.di) 485 | NCDEPIS := $(MLIDEPS:%.di=$(NCDIDIR)/%.di) 486 | 487 | ALLML := $(filter %.mli %.ml %.mll %.mly %.idl %.oxridl %.rep %.zog %.glade, $(FILTERED)) 488 | 489 | IMPLO_INTF := $(ALLML:%.mli=%.mli.__) 490 | IMPLO_INTF := $(foreach file, $(IMPLO_INTF), \ 491 | $(basename $(file)).cmi $(basename $(file)).cmo) 492 | IMPLO_INTF := $(filter-out %.mli.cmo, $(IMPLO_INTF)) 493 | IMPLO_INTF := $(IMPLO_INTF:%.mli.cmi=%.cmi) 494 | 495 | IMPLX_INTF := $(IMPLO_INTF:.cmo=.cmx) 496 | 497 | INTF := $(filter %.cmi, $(IMPLO_INTF)) 498 | IMPL_CMO := $(filter %.cmo, $(IMPLO_INTF)) 499 | IMPL_CMX := $(IMPL_CMO:.cmo=.cmx) 500 | IMPL_ASM := $(IMPL_CMO:.cmo=.asm) 501 | IMPL_S := $(IMPL_CMO:.cmo=.s) 502 | 503 | OBJ_LINK := $(OBJ_C_IDL) $(OBJ_C_CXX) 504 | OBJ_FILES := $(IMPL_CMO:.cmo=.$(EXT_OBJ)) $(OBJ_LINK) 505 | 506 | EXECS := $(addsuffix $(EXE), \ 507 | $(sort $(TOPRESULT) $(BCRESULT) $(NCRESULT))) 508 | ifdef WIN32 509 | EXECS += $(BCRESULT).dll $(NCRESULT).dll 510 | endif 511 | 512 | CLIB_BASE := $(RESULT)$(RES_CLIB_SUF) 513 | ifneq ($(strip $(OBJ_LINK)),) 514 | RES_CLIB := lib$(CLIB_BASE).$(EXT_LIB) 515 | endif 516 | 517 | ifdef WIN32 518 | DLLSONAME := dll$(CLIB_BASE).dll 519 | else 520 | DLLSONAME := dll$(CLIB_BASE).so 521 | endif 522 | 523 | NONEXECS := $(INTF) $(IMPL_CMO) $(IMPL_CMX) $(IMPL_ASM) $(IMPL_S) \ 524 | $(OBJ_FILES) $(PRE_TARGETS) $(BCRESULT).cma $(NCRESULT).cmxa \ 525 | $(NCRESULT).$(EXT_LIB) $(BCRESULT).cmi $(BCRESULT).cmo \ 526 | $(NCRESULT).cmi $(NCRESULT).cmx $(NCRESULT).$(EXT_OBJ) \ 527 | $(RES_CLIB) $(IMPL_CMO:.cmo=.annot) \ 528 | $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(LIB_PACK_NAME).cmx \ 529 | $(LIB_PACK_NAME).$(EXT_OBJ) 530 | 531 | ifndef STATIC 532 | NONEXECS += $(DLLSONAME) 533 | endif 534 | 535 | ifndef LIBINSTALL_FILES 536 | LIBINSTALL_FILES := $(RESULT).mli $(RESULT).cmi $(RESULT).cma \ 537 | $(RESULT).cmxa $(RESULT).$(EXT_LIB) $(RES_CLIB) 538 | ifndef STATIC 539 | ifneq ($(strip $(OBJ_LINK)),) 540 | LIBINSTALL_FILES += $(DLLSONAME) 541 | endif 542 | endif 543 | endif 544 | 545 | export LIBINSTALL_FILES 546 | 547 | ifdef WIN32 548 | # some extra stuff is created while linking DLLs 549 | NONEXECS += $(BCRESULT).$(EXT_LIB) $(BCRESULT).exp $(NCRESULT).exp $(CLIB_BASE).exp $(CLIB_BASE).lib 550 | endif 551 | 552 | TARGETS := $(EXECS) $(NONEXECS) 553 | 554 | # If there are IDL-files 555 | ifneq ($(strip $(FILTERED_IDL)),) 556 | MAYBE_IDL := -cclib -lcamlidl 557 | endif 558 | 559 | ifdef USE_CAMLP4 560 | CAMLP4PATH := \ 561 | $(shell $(CAMLP4) -where 2>/dev/null || echo /usr/local/lib/camlp4) 562 | INCFLAGS := -I $(CAMLP4PATH) 563 | CINCFLAGS := -I$(CAMLP4PATH) 564 | endif 565 | 566 | INCFLAGS := $(INCFLAGS) $(INCDIRS:%=-I %) $(SOURCE_DIRS:%=-I %) $(OCAML_DEFAULT_DIRS:%=-I %) 567 | CINCFLAGS += $(SOURCE_DIRS:%=-I%) $(INCDIRS:%=-I%) $(OCAML_DEFAULT_DIRS:%=-I%) 568 | 569 | ifndef MSVC 570 | CLIBFLAGS += $(SOURCE_DIRS:%=-L%) $(LIBDIRS:%=-L%) \ 571 | $(EXTLIBDIRS:%=-L%) $(OCAML_DEFAULT_DIRS:%=-L%) 572 | 573 | ifeq ($(ELF_RPATH), yes) 574 | CLIBFLAGS += $(EXTLIBDIRS:%=-Wl,$(RPATH_FLAG)%) 575 | endif 576 | endif 577 | 578 | ifndef PROFILING 579 | INTF_OCAMLC := $(OCAMLC) 580 | else 581 | ifndef THREADS 582 | INTF_OCAMLC := $(OCAMLCP) -p $(OCAMLCPFLAGS) 583 | else 584 | # OCaml does not support profiling byte code 585 | # with threads (yet), therefore we force an error. 586 | ifndef REAL_OCAMLC 587 | $(error Profiling of multithreaded byte code not yet supported by OCaml) 588 | endif 589 | INTF_OCAMLC := $(OCAMLC) 590 | endif 591 | endif 592 | 593 | ifndef MSVC 594 | COMMON_LDFLAGS := $(LDFLAGS:%=-ccopt %) $(SOURCE_DIRS:%=-ccopt -L%) \ 595 | $(LIBDIRS:%=-ccopt -L%) $(EXTLIBDIRS:%=-ccopt -L%) \ 596 | $(EXTLIBDIRS:%=-ccopt -Wl $(OCAML_DEFAULT_DIRS:%=-ccopt -L%)) 597 | 598 | ifeq ($(ELF_RPATH),yes) 599 | COMMON_LDFLAGS += $(EXTLIBDIRS:%=-ccopt -Wl,$(RPATH_FLAG)%) 600 | endif 601 | else 602 | COMMON_LDFLAGS := -ccopt "/link -NODEFAULTLIB:LIBC $(LDFLAGS:%=%) $(SOURCE_DIRS:%=-LIBPATH:%) \ 603 | $(LIBDIRS:%=-LIBPATH:%) $(EXTLIBDIRS:%=-LIBPATH:%) \ 604 | $(OCAML_DEFAULT_DIRS:%=-LIBPATH:%) " 605 | endif 606 | 607 | CLIBS_OPTS := $(CLIBS:%=-cclib -l%) $(CFRAMEWORKS:%=-cclib '-framework %') 608 | ifdef MSVC 609 | ifndef STATIC 610 | # MSVC libraries do not have 'lib' prefix 611 | CLIBS_OPTS := $(CLIBS:%=-cclib %.lib) 612 | endif 613 | endif 614 | 615 | ifneq ($(strip $(OBJ_LINK)),) 616 | ifdef CREATE_LIB 617 | OBJS_LIBS := -cclib -l$(CLIB_BASE) $(CLIBS_OPTS) $(MAYBE_IDL) 618 | else 619 | OBJS_LIBS := $(OBJ_LINK) $(CLIBS_OPTS) $(MAYBE_IDL) 620 | endif 621 | else 622 | OBJS_LIBS := $(CLIBS_OPTS) $(MAYBE_IDL) 623 | endif 624 | 625 | ifdef LIB_PACK_NAME 626 | FOR_PACK_NAME := $(shell echo $(LIB_PACK_NAME) | awk '{print toupper(substr($$0,1,1))substr($$0,2)}') 627 | endif 628 | 629 | # If we have to make byte-code 630 | ifndef REAL_OCAMLC 631 | BYTE_OCAML := y 632 | 633 | # EXTRADEPS is added dependencies we have to insert for all 634 | # executable files we generate. Ideally it should be all of the 635 | # libraries we use, but it's hard to find the ones that get searched on 636 | # the path since I don't know the paths built into the compiler, so 637 | # just include the ones with slashes in their names. 638 | EXTRADEPS := $(addsuffix .cma,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) 639 | 640 | 641 | ifndef LIB_PACK_NAME 642 | SPECIAL_OCAMLFLAGS := $(OCAMLBCFLAGS) 643 | else 644 | SPECIAL_OCAMLFLAGS := -for-pack $(FOR_PACK_NAME) $(OCAMLBCFLAGS) 645 | endif 646 | 647 | REAL_OCAMLC := $(INTF_OCAMLC) 648 | 649 | REAL_IMPL := $(IMPL_CMO) 650 | REAL_IMPL_INTF := $(IMPLO_INTF) 651 | IMPL_SUF := .cmo 652 | 653 | DEPFLAGS := 654 | MAKE_DEPS := $(MLDEPS) $(BCDEPIS) 655 | 656 | ifdef CREATE_LIB 657 | override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) 658 | override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) 659 | ifndef STATIC 660 | ifneq ($(strip $(OBJ_LINK)),) 661 | MAKEDLL := $(DLLSONAME) 662 | ALL_LDFLAGS := -dllib $(DLLSONAME) 663 | endif 664 | endif 665 | endif 666 | 667 | ifndef NO_CUSTOM 668 | ifneq "$(strip $(OBJ_LINK) $(THREADS) $(MAYBE_IDL) $(CLIBS) $(CFRAMEWORKS))" "" 669 | ALL_LDFLAGS += -custom 670 | endif 671 | endif 672 | 673 | ALL_LDFLAGS += $(INCFLAGS) $(OCAMLLDFLAGS) $(OCAMLBLDFLAGS) \ 674 | $(COMMON_LDFLAGS) $(LIBS:%=%.cma) 675 | CAMLIDLDLLFLAGS := 676 | 677 | ifdef THREADS 678 | ifdef VMTHREADS 679 | THREAD_FLAG := -vmthread 680 | else 681 | THREAD_FLAG := -thread 682 | endif 683 | ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) 684 | ifndef CREATE_LIB 685 | ifndef REAL_OCAMLFIND 686 | ALL_LDFLAGS := unix.cma threads.cma $(ALL_LDFLAGS) 687 | endif 688 | endif 689 | endif 690 | 691 | # we have to make native-code 692 | else 693 | EXTRADEPS := $(addsuffix .cmxa,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) 694 | ifndef PROFILING 695 | SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) 696 | PLDFLAGS := 697 | else 698 | SPECIAL_OCAMLFLAGS := -p $(OCAMLNCFLAGS) 699 | PLDFLAGS := -p 700 | endif 701 | 702 | ifndef LIB_PACK_NAME 703 | SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) 704 | else 705 | SPECIAL_OCAMLFLAGS := -for-pack $(FOR_PACK_NAME) $(OCAMLNCFLAGS) 706 | endif 707 | REAL_IMPL := $(IMPL_CMX) 708 | REAL_IMPL_INTF := $(IMPLX_INTF) 709 | IMPL_SUF := .cmx 710 | 711 | override CPPFLAGS := -DNATIVE_CODE $(CPPFLAGS) 712 | 713 | DEPFLAGS := -native 714 | MAKE_DEPS := $(MLDEPS) $(NCDEPIS) 715 | 716 | ALL_LDFLAGS := $(PLDFLAGS) $(INCFLAGS) $(OCAMLLDFLAGS) \ 717 | $(OCAMLNLDFLAGS) $(COMMON_LDFLAGS) 718 | CAMLIDLDLLFLAGS := -opt 719 | 720 | ifndef CREATE_LIB 721 | ALL_LDFLAGS += $(LIBS:%=%.cmxa) 722 | else 723 | override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) 724 | override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) 725 | endif 726 | 727 | ifdef THREADS 728 | THREAD_FLAG := -thread 729 | ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) 730 | ifndef CREATE_LIB 731 | ifndef REAL_OCAMLFIND 732 | ALL_LDFLAGS := unix.cmxa threads.cmxa $(ALL_LDFLAGS) 733 | endif 734 | endif 735 | endif 736 | endif 737 | 738 | export MAKE_DEPS 739 | 740 | ifdef ANNOTATE 741 | ANNOT_FLAG := -annot 742 | else 743 | endif 744 | 745 | ALL_OCAMLCFLAGS := $(THREAD_FLAG) $(ANNOT_FLAG) $(OCAMLFLAGS) \ 746 | $(INCFLAGS) $(SPECIAL_OCAMLFLAGS) 747 | 748 | ifdef make_deps 749 | -include $(MAKE_DEPS) 750 | PRE_TARGETS := 751 | endif 752 | 753 | ########################################################################### 754 | # USER RULES 755 | 756 | # Call "OCamlMakefile QUIET=" to get rid of all of the @'s. 757 | QUIET=@ 758 | 759 | # generates byte-code (default) 760 | byte-code: $(PRE_TARGETS) 761 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 762 | REAL_RESULT="$(BCRESULT)" make_deps=yes 763 | bc: byte-code 764 | 765 | byte-code-nolink: $(PRE_TARGETS) 766 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 767 | REAL_RESULT="$(BCRESULT)" make_deps=yes 768 | bcnl: byte-code-nolink 769 | 770 | top: $(PRE_TARGETS) 771 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(TOPRESULT) \ 772 | REAL_RESULT="$(BCRESULT)" make_deps=yes 773 | 774 | # generates native-code 775 | 776 | native-code: $(PRE_TARGETS) 777 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 778 | REAL_RESULT="$(NCRESULT)" \ 779 | REAL_OCAMLC="$(OCAMLOPT)" \ 780 | make_deps=yes 781 | nc: native-code 782 | 783 | native-code-nolink: $(PRE_TARGETS) 784 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 785 | REAL_RESULT="$(NCRESULT)" \ 786 | REAL_OCAMLC="$(OCAMLOPT)" \ 787 | make_deps=yes 788 | ncnl: native-code-nolink 789 | 790 | # generates byte-code libraries 791 | byte-code-library: $(PRE_TARGETS) 792 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 793 | $(RES_CLIB) $(BCRESULT).cma \ 794 | REAL_RESULT="$(BCRESULT)" \ 795 | CREATE_LIB=yes \ 796 | make_deps=yes 797 | bcl: byte-code-library 798 | 799 | # generates native-code libraries 800 | native-code-library: $(PRE_TARGETS) 801 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 802 | $(RES_CLIB) $(NCRESULT).cmxa \ 803 | REAL_RESULT="$(NCRESULT)" \ 804 | REAL_OCAMLC="$(OCAMLOPT)" \ 805 | CREATE_LIB=yes \ 806 | make_deps=yes 807 | ncl: native-code-library 808 | 809 | ifdef WIN32 810 | # generates byte-code dll 811 | byte-code-dll: $(PRE_TARGETS) 812 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 813 | $(RES_CLIB) $(BCRESULT).dll \ 814 | REAL_RESULT="$(BCRESULT)" \ 815 | make_deps=yes 816 | bcd: byte-code-dll 817 | 818 | # generates native-code dll 819 | native-code-dll: $(PRE_TARGETS) 820 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 821 | $(RES_CLIB) $(NCRESULT).dll \ 822 | REAL_RESULT="$(NCRESULT)" \ 823 | REAL_OCAMLC="$(OCAMLOPT)" \ 824 | make_deps=yes 825 | ncd: native-code-dll 826 | endif 827 | 828 | # generates byte-code with debugging information 829 | debug-code: $(PRE_TARGETS) 830 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 831 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 832 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 833 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 834 | dc: debug-code 835 | 836 | debug-code-nolink: $(PRE_TARGETS) 837 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 838 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 839 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 840 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 841 | dcnl: debug-code-nolink 842 | 843 | # generates byte-code with debugging information (native code) 844 | debug-native-code: $(PRE_TARGETS) 845 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 846 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 847 | REAL_OCAMLC="$(OCAMLOPT)" \ 848 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 849 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 850 | dnc: debug-native-code 851 | 852 | debug-native-code-nolink: $(PRE_TARGETS) 853 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ 854 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 855 | REAL_OCAMLC="$(OCAMLOPT)" \ 856 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 857 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 858 | dncnl: debug-native-code-nolink 859 | 860 | # generates byte-code libraries with debugging information 861 | debug-code-library: $(PRE_TARGETS) 862 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 863 | $(RES_CLIB) $(BCRESULT).cma \ 864 | REAL_RESULT="$(BCRESULT)" make_deps=yes \ 865 | CREATE_LIB=yes \ 866 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 867 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 868 | dcl: debug-code-library 869 | 870 | # generates byte-code libraries with debugging information (native code) 871 | debug-native-code-library: $(PRE_TARGETS) 872 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 873 | $(RES_CLIB) $(NCRESULT).cmxa \ 874 | REAL_RESULT="$(NCRESULT)" make_deps=yes \ 875 | REAL_OCAMLC="$(OCAMLOPT)" \ 876 | CREATE_LIB=yes \ 877 | OCAMLFLAGS="-g $(OCAMLFLAGS)" \ 878 | OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" 879 | dncl: debug-native-code-library 880 | 881 | # generates byte-code for profiling 882 | profiling-byte-code: $(PRE_TARGETS) 883 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ 884 | REAL_RESULT="$(BCRESULT)" PROFILING="y" \ 885 | make_deps=yes 886 | pbc: profiling-byte-code 887 | 888 | # generates native-code 889 | 890 | profiling-native-code: $(PRE_TARGETS) 891 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ 892 | REAL_RESULT="$(NCRESULT)" \ 893 | REAL_OCAMLC="$(OCAMLOPT)" \ 894 | PROFILING="y" \ 895 | make_deps=yes 896 | pnc: profiling-native-code 897 | 898 | # generates byte-code libraries 899 | profiling-byte-code-library: $(PRE_TARGETS) 900 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 901 | $(RES_CLIB) $(BCRESULT).cma \ 902 | REAL_RESULT="$(BCRESULT)" PROFILING="y" \ 903 | CREATE_LIB=yes \ 904 | make_deps=yes 905 | pbcl: profiling-byte-code-library 906 | 907 | # generates native-code libraries 908 | profiling-native-code-library: $(PRE_TARGETS) 909 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 910 | $(RES_CLIB) $(NCRESULT).cmxa \ 911 | REAL_RESULT="$(NCRESULT)" PROFILING="y" \ 912 | REAL_OCAMLC="$(OCAMLOPT)" \ 913 | CREATE_LIB=yes \ 914 | make_deps=yes 915 | pncl: profiling-native-code-library 916 | 917 | # packs byte-code objects 918 | pack-byte-code: $(PRE_TARGETS) 919 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT).cmo \ 920 | REAL_RESULT="$(BCRESULT)" \ 921 | PACK_LIB=yes make_deps=yes 922 | pabc: pack-byte-code 923 | 924 | # packs native-code objects 925 | pack-native-code: $(PRE_TARGETS) 926 | $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ 927 | $(NCRESULT).cmx $(NCRESULT).$(EXT_OBJ) \ 928 | REAL_RESULT="$(NCRESULT)" \ 929 | REAL_OCAMLC="$(OCAMLOPT)" \ 930 | PACK_LIB=yes make_deps=yes 931 | panc: pack-native-code 932 | 933 | # generates HTML-documentation 934 | htdoc: $(DOC_DIR)/$(RESULT)/html/index.html 935 | 936 | # generates Latex-documentation 937 | ladoc: $(DOC_DIR)/$(RESULT)/latex/doc.tex 938 | 939 | # generates PostScript-documentation 940 | psdoc: $(DOC_DIR)/$(RESULT)/latex/doc.ps 941 | 942 | # generates PDF-documentation 943 | pdfdoc: $(DOC_DIR)/$(RESULT)/latex/doc.pdf 944 | 945 | # generates all supported forms of documentation 946 | doc: htdoc ladoc psdoc pdfdoc 947 | 948 | ########################################################################### 949 | # LOW LEVEL RULES 950 | 951 | $(REAL_RESULT): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(RESULTDEPS) 952 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) \ 953 | $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ 954 | $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@$(EXE) \ 955 | $(REAL_IMPL) 956 | 957 | nolink: $(REAL_IMPL_INTF) $(OBJ_LINK) 958 | 959 | ifdef WIN32 960 | $(REAL_RESULT).dll: $(REAL_IMPL_INTF) $(OBJ_LINK) 961 | $(CAMLIDLDLL) $(CAMLIDLDLLFLAGS) $(OBJ_LINK) $(CLIBS) \ 962 | -o $@ $(REAL_IMPL) 963 | endif 964 | 965 | %$(TOPSUFFIX): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) 966 | $(REAL_OCAMLFIND) $(OCAMLMKTOP) \ 967 | $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ 968 | $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@$(EXE) \ 969 | $(REAL_IMPL) 970 | 971 | .SUFFIXES: .mli .ml .cmi .cmo .cmx .cma .cmxa .$(EXT_OBJ) \ 972 | .mly .di .d .$(EXT_LIB) .idl %.oxridl .c .m .$(EXT_CXX) .h .so \ 973 | .rep .zog .glade 974 | 975 | ifndef STATIC 976 | ifdef MINGW 977 | # From OCaml 3.11.0, ocamlmklib is available on windows 978 | OCAMLMLIB_EXISTS = $(shell which $(OCAMLMKLIB)) 979 | ifeq ($(strip $(OCAMLMLIB_EXISTS)),) 980 | $(DLLSONAME): $(OBJ_LINK) 981 | $(CC) $(CFLAGS) $(CFLAGS_WIN32) $(OBJ_LINK) -shared -o $@ \ 982 | $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/lib%.a))) \ 983 | '$(OCAMLLIBPATH)/ocamlrun.a' \ 984 | -Wl,--whole-archive \ 985 | -Wl,--export-all-symbols \ 986 | -Wl,--allow-multiple-definition \ 987 | -Wl,--enable-auto-import 988 | else 989 | $(DLLSONAME): $(OBJ_LINK) 990 | $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ 991 | -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) \ 992 | $(CFRAMEWORKS:%=-framework %) \ 993 | $(OCAMLMKLIB_FLAGS) 994 | endif 995 | else 996 | ifdef MSVC 997 | $(DLLSONAME): $(OBJ_LINK) 998 | link /NOLOGO /DLL /OUT:$@ $(OBJ_LINK) \ 999 | $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/%.lib))) \ 1000 | '$(OCAMLLIBPATH)/ocamlrun.lib' 1001 | 1002 | else 1003 | $(DLLSONAME): $(OBJ_LINK) 1004 | $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ 1005 | -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) $(CFRAMEWORKS:%=-framework %) \ 1006 | $(OCAMLMKLIB_FLAGS) 1007 | endif 1008 | endif 1009 | endif 1010 | 1011 | ifndef LIB_PACK_NAME 1012 | $(RESULT).cma: $(REAL_IMPL_INTF) $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) 1013 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(REAL_IMPL) 1014 | 1015 | $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(REAL_IMPL_INTF) $(EXTRADEPS) $(RESULTDEPS) 1016 | $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(REAL_IMPL) 1017 | else 1018 | # Packing a bytecode library 1019 | LIB_PACK_NAME_MLI = $(wildcard $(LIB_PACK_NAME).mli) 1020 | ifeq ($(LIB_PACK_NAME_MLI),) 1021 | LIB_PACK_NAME_CMI = $(LIB_PACK_NAME).cmi 1022 | else 1023 | # $(LIB_PACK_NAME).mli exists, it likely depends on other compiled interfaces 1024 | LIB_PACK_NAME_CMI = 1025 | $(LIB_PACK_NAME).cmi: $(REAL_IMPL_INTF) 1026 | endif 1027 | ifdef BYTE_OCAML 1028 | $(LIB_PACK_NAME_CMI) $(LIB_PACK_NAME).cmo: $(REAL_IMPL_INTF) 1029 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmo $(OCAMLLDFLAGS) $(REAL_IMPL) 1030 | # Packing into a unit which can be transformed into a library 1031 | # Remember the .ml's must have been compiled with -for-pack $(LIB_PACK_NAME) 1032 | else 1033 | $(LIB_PACK_NAME_CMI) $(LIB_PACK_NAME).cmx: $(REAL_IMPL_INTF) 1034 | $(REAL_OCAMLFIND) $(OCAMLOPT) -pack -o $(LIB_PACK_NAME).cmx $(OCAMLLDFLAGS) $(REAL_IMPL) 1035 | endif 1036 | 1037 | $(RESULT).cma: $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) 1038 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(OBJS_LIBS) $(ALL_LDFLAGS) -o $@ $(LIB_PACK_NAME).cmo 1039 | 1040 | $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx $(EXTRADEPS) $(RESULTDEPS) 1041 | $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(OBJS_LIBS) $(filter-out -custom, $(ALL_LDFLAGS)) -o $@ $(LIB_PACK_NAME).cmx 1042 | endif 1043 | 1044 | $(RES_CLIB): $(OBJ_LINK) 1045 | ifndef MSVC 1046 | ifneq ($(strip $(OBJ_LINK)),) 1047 | $(AR) rcs $@ $(OBJ_LINK) 1048 | endif 1049 | else 1050 | ifneq ($(strip $(OBJ_LINK)),) 1051 | lib -nologo -debugtype:cv -out:$(RES_CLIB) $(OBJ_LINK) 1052 | endif 1053 | endif 1054 | 1055 | %.cmi: %.mli $(EXTRADEPS) 1056 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1057 | if [ -z "$$pp" ]; then \ 1058 | $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1059 | -c $(THREAD_FLAG) $(ANNOT_FLAG) \ 1060 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1061 | $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1062 | -c $(THREAD_FLAG) $(ANNOT_FLAG) \ 1063 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1064 | else \ 1065 | $(ECHO) $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1066 | -c -pp \"$$pp $(PPFLAGS)\" $(THREAD_FLAG) $(ANNOT_FLAG) \ 1067 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1068 | $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1069 | -c -pp "$$pp $(PPFLAGS)" $(THREAD_FLAG) $(ANNOT_FLAG) \ 1070 | $(OCAMLFLAGS) $(INCFLAGS) $<; \ 1071 | fi 1072 | 1073 | %.cmi: %$(IMPL_SUF); 1074 | 1075 | %$(IMPL_SUF) %.$(EXT_OBJ): %.ml $(EXTRADEPS) 1076 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1077 | if [ -z "$$pp" ]; then \ 1078 | $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1079 | -c $(ALL_OCAMLCFLAGS) $<; \ 1080 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1081 | -c $(ALL_OCAMLCFLAGS) $<; \ 1082 | else \ 1083 | $(ECHO) $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1084 | -c -pp \"$$pp $(PPFLAGS)\" $(ALL_OCAMLCFLAGS) $<; \ 1085 | $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ 1086 | -c -pp "$$pp $(PPFLAGS)" $(ALL_OCAMLCFLAGS) $<; \ 1087 | fi 1088 | 1089 | .PRECIOUS: %.ml 1090 | %.ml: %.mll 1091 | $(OCAMLLEX) $(LFLAGS) $< 1092 | 1093 | .PRECIOUS: %.ml %.mli 1094 | %.ml %.mli: %.mly 1095 | $(OCAMLYACC) $(YFLAGS) $< 1096 | $(QUIET)pp=`sed -n -e 's/.*(\*pp \([^*]*\) \*).*/\1/p;q' $<`; \ 1097 | if [ ! -z "$$pp" ]; then \ 1098 | mv $*.ml $*.ml.temporary; \ 1099 | echo "(*pp $$pp $(PPFLAGS)*)" > $*.ml; \ 1100 | cat $*.ml.temporary >> $*.ml; \ 1101 | rm $*.ml.temporary; \ 1102 | mv $*.mli $*.mli.temporary; \ 1103 | echo "(*pp $$pp $(PPFLAGS)*)" > $*.mli; \ 1104 | cat $*.mli.temporary >> $*.mli; \ 1105 | rm $*.mli.temporary; \ 1106 | fi 1107 | 1108 | 1109 | .PRECIOUS: %.ml 1110 | %.ml: %.rep 1111 | $(CAMELEON_REPORT) $(CAMELEON_REPORT_FLAGS) -gen $< 1112 | 1113 | .PRECIOUS: %.ml 1114 | %.ml: %.zog 1115 | $(CAMELEON_ZOGGY) $(CAMELEON_ZOGGY_FLAGS) -impl $< > $@ 1116 | 1117 | .PRECIOUS: %.ml 1118 | %.ml: %.glade 1119 | $(OCAML_GLADECC) $(OCAML_GLADECC_FLAGS) $< > $@ 1120 | 1121 | .PRECIOUS: %.ml %.mli 1122 | %.ml %.mli: %.oxridl 1123 | $(OXRIDL) $< 1124 | 1125 | .PRECIOUS: %.ml %.mli %_stubs.c %.h 1126 | %.ml %.mli %_stubs.c %.h: %.idl 1127 | $(CAMLIDL) $(MAYBE_IDL_HEADER) $(IDLFLAGS) \ 1128 | $(CAMLIDLFLAGS) $< 1129 | $(QUIET)if [ $(NOIDLHEADER) ]; then touch $*.h; fi 1130 | 1131 | %.$(EXT_OBJ): %.c 1132 | $(OCAMLC) -c -cc "$(CC)" -ccopt "$(CFLAGS) \ 1133 | $(CPPFLAGS) $(CPPFLAGS_WIN32) \ 1134 | $(CFLAGS_WIN32) $(CINCFLAGS) $(CFLAG_O)$@ " $< 1135 | 1136 | %.$(EXT_OBJ): %.m 1137 | $(CC) -c $(CFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ 1138 | -I'$(OCAMLLIBPATH)' \ 1139 | $< $(CFLAG_O)$@ 1140 | 1141 | %.$(EXT_OBJ): %.$(EXT_CXX) 1142 | $(CXX) -c $(CXXFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ 1143 | -I'$(OCAMLLIBPATH)' \ 1144 | $< $(CFLAG_O)$@ 1145 | 1146 | $(MLDEPDIR)/%.d: %.ml 1147 | $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi 1148 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1149 | if [ -z "$$pp" ]; then \ 1150 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1151 | $(INCFLAGS) $< \> $@; \ 1152 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1153 | $(INCFLAGS) $< > $@; \ 1154 | else \ 1155 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1156 | -pp \"$$pp $(PPFLAGS)\" $(INCFLAGS) $< \> $@; \ 1157 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ 1158 | -pp "$$pp $(PPFLAGS)" $(INCFLAGS) $< > $@; \ 1159 | fi 1160 | 1161 | $(BCDIDIR)/%.di $(NCDIDIR)/%.di: %.mli 1162 | $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi 1163 | $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ 1164 | if [ -z "$$pp" ]; then \ 1165 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< \> $@; \ 1166 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(INCFLAGS) $< > $@; \ 1167 | else \ 1168 | $(ECHO) $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ 1169 | -pp \"$$pp $(PPFLAGS)\" $(INCFLAGS) $< \> $@; \ 1170 | $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ 1171 | -pp "$$pp $(PPFLAGS)" $(INCFLAGS) $< > $@; \ 1172 | fi 1173 | 1174 | $(DOC_DIR)/$(RESULT)/html: 1175 | mkdir -p $@ 1176 | 1177 | $(DOC_DIR)/$(RESULT)/html/index.html: $(DOC_DIR)/$(RESULT)/html $(DOC_FILES) 1178 | rm -rf $