diff --git a/lexer.mll b/lexer.mll index 8308435..9d9cc64 100644 --- a/lexer.mll +++ b/lexer.mll @@ -10,18 +10,30 @@ rule token = parse | ')' { RPAREN } | "->" { RARROW } | '~' { TILDE } + | "/\\" { LAND } + | "\\/" { LOR } + | ',' { COMMA } | "intro" { INTRO } | "assumption" { ASSUMPTION } | "apply" { APPLY } | "elim" { ELIM } | "cut" { CUT } + | "split" { SPLIT } + | "left" { LEFT } + | "right" { RIGHT } + | "False" { FALSE } | "fun" { FUN } | "=>" { MAPS_TO } | ':' { VDOTS } | "exf" { EXF } + | "fst" { FST } + | "snd" { SND } + | "ig" { IG } + | "id" { ID } + | "case" { CASE } | '&' { AMPERSAND } diff --git a/main.ml b/main.ml index a15359d..e2cb8a1 100644 --- a/main.ml +++ b/main.ml @@ -114,6 +114,7 @@ while !subgoals <> [] do explore hyps in + if is_interactive then ( (* Nettoyage du terminal *) let _ = Sys.command("clear -x") in @@ -185,6 +186,18 @@ while !subgoals <> [] do | Elim var -> ( match find_hyp var with | Some TFalse -> fill_holes := fun holes -> f ((LExf (LVar var, ty)) :: holes) + | Some TAnd(tl,tr) -> ( + subgoals := (TImpl(tl,TImpl(tr,ty)),hyps)::!subgoals; + fill_holes := fun holes -> match holes with + | h::r -> f ((LApp(LApp(h,LFst(LVar(var))),LSnd(LVar(var))))::r) + | _ -> fail () + ) + | Some TOr(tl,tr) -> ( + subgoals := (TImpl(tl,ty),hyps)::(TImpl(tr,ty),hyps)::!subgoals; + fill_holes := fun holes -> match holes with + | hl::hr::r -> f (LCase(LVar(var),hl,hr)::r) + | _ -> fail () + ) | None -> failwith ("Hypothesis " ^ var ^ " not found") | _ -> failwith ("Hypothesis " ^ var ^ " unusable") ) @@ -195,6 +208,37 @@ while !subgoals <> [] do | pf :: px :: s -> f ((LApp (pf, px)) :: s) | _ -> fail () ) + + | Split ovar -> ( + match ty with + | TAnd(t1,t2) -> ( + subgoals := (t1, hyps) :: (t2, hyps) :: !subgoals; + fill_holes := fun holes -> match holes with + | h1 :: h2 :: hs -> f (LCouple(h1,h2) :: hs) + | _ -> fail () + ) + | _ -> failwith "Target not a and clause" + ) + | Left -> ( + match ty with + | TOr(tl,tr) -> ( + subgoals := (tl, hyps) :: !subgoals; + fill_holes := fun holes -> match holes with + | hl :: hs -> f (LIg(hl,tr) :: hs) + | _ -> fail () + ) + | _ -> failwith "Target not a or clause" + ) + | Right -> ( + match ty with + | TOr(tl,tr) -> ( + subgoals := (tr, hyps) :: !subgoals; + fill_holes := fun holes -> match holes with + | hr :: hs -> f (LId(hr,tl) :: hs) + | _ -> fail () + ) + | _ -> failwith "Target not a or clause" + ) done; let finalLam = !fill_holes [] in diff --git a/parser.mly b/parser.mly index 34270fa..27b3fb9 100644 --- a/parser.mly +++ b/parser.mly @@ -4,13 +4,13 @@ %} /* Description des lexèmes définis dans lexer.mll */ -%token LPAREN RPAREN RARROW TILDE FALSE +%token LPAREN RPAREN RARROW TILDE LAND LOR COMMA FALSE TRUE %token EOF %token VAR_NAME %token TYPE_NAME -%token DOT INTRO ASSUMPTION APPLY ELIM CUT +%token DOT INTRO ASSUMPTION APPLY ELIM CUT SPLIT LEFT RIGHT FST SND IG ID CASE %token FUN MAPS_TO VDOTS EXF %token AMPERSAND @@ -18,6 +18,8 @@ /* L'ordre de définition définit la priorité */ %right RARROW %nonassoc TILDE +%left LAND +%left LOR %start main_type %type main_type @@ -50,7 +52,10 @@ ty: | ty RARROW ty { TImpl ($1, $3) } | TYPE_NAME { TSimple $1 } | TILDE ty { TImpl ($2, TFalse) } + | ty LAND ty { TAnd($1, $3) } + | ty LOR ty { TOr($1, $3) } | FALSE { TFalse } + | TRUE { TTrue } /* Tactiques */ tactic: @@ -59,7 +64,11 @@ tactic: | APPLY VAR_NAME DOT { Apply $2 } | ELIM VAR_NAME DOT { Elim $2 } | CUT ty DOT { Cut $2 } - + | SPLIT DOT { Split None } + | SPLIT VAR_NAME DOT { Split (Some $2) } + | LEFT DOT { Left } + | RIGHT DOT { Right } + /* Lambda-termes */ lambda_arg: /* Expression pouvant être en argument d'une fonction */ | VAR_NAME { LVar $1 } diff --git a/pieuvre.ml b/pieuvre.ml index ac17afe..d14d7d0 100644 --- a/pieuvre.ml +++ b/pieuvre.ml @@ -5,12 +5,22 @@ open Str exception TODOException;; exception IllegalVarNameException of var +(* Casse un objet option *) +let optionmatch (nonefun: 'b option) (somefun: 'a -> 'b option) (o: 'a option) : 'b option = + match o with + | Some x -> somefun x + | None -> nonefun +;; + (* Affiche un λ-terme avec la même syntaxe qu’en entrée *) let rec string_of_ty (t: ty) : string = match t with | TSimple(tn) -> tn | TImpl(t1,t2) -> "(" ^ (string_of_ty t1) ^ " -> " ^ (string_of_ty t2) ^ ")" - | TFalse -> "⊥" + | TAnd(t1,t2) -> "(" ^ (string_of_ty t1) ^ "/\\" ^ (string_of_ty t2) ^ ")" + | TOr(t1,t2) -> "(" ^ (string_of_ty t1) ^ "\\/" ^ (string_of_ty t2) ^ ")" + | TFalse -> "False" + | TTrue -> "True" ;; (* Affiche un λ-terme avec la même syntaxe qu’en entrée *) @@ -19,6 +29,12 @@ let rec string_of_lam (l: lam) : string = match l with | LApp(l1, l2) -> "("^(string_of_lam l1)^" "^(string_of_lam l2)^")" | LVar(v) -> v | LExf(l',t) -> "exf("^(string_of_lam l')^" : "^(string_of_ty t)^")" + | LCouple(lg,ld) -> "("^(string_of_lam lg)^","^(string_of_lam ld)^")" + | LFst(ll) -> "fst("^(string_of_lam ll)^")" + | LSnd(ll) -> "snd("^(string_of_lam ll)^")" + | LIg(ll,t) -> "ig("^(string_of_lam ll)^","^(string_of_ty t)^")" + | LId(ll,t) -> "id("^(string_of_lam ll)^","^(string_of_ty t)^")" + | LCase(ll,lg,ld) -> "case("^(string_of_lam ll)^","^(string_of_lam lg)^","^(string_of_lam ld)^")" ;; let split, tsplit = @@ -31,7 +47,7 @@ let split, tsplit = else raise (IllegalVarNameException(x)) in (splitter varRegex, splitter tvarRegex);; - + (* Renvoie un nom non utilisé dans la formule l qui commence par x *) let findFreeName (l: lam) (x: var) = let xStr = fst (split x) in @@ -42,11 +58,35 @@ let findFreeName (l: lam) (x: var) = | LVar(v) -> let (vS,vI) = split v in if xStr=vS then maxi := max !maxi vI | LExf(l',t) -> finder l' + | LCouple(l1,l2) -> (finder l1;finder l2) + | LFst(l') -> finder l' + | LSnd(l') -> finder l' + | LIg(l',t) -> finder l' + | LId(l',t) -> finder l' + | LCase(ll,lg,ld) -> (finder ll; finder lg; finder ld) + in finder l; xStr ^ (string_of_int (!maxi+1)) ;; +(* Renvoie un nom non utilisé dans la liste de nom donnée, basée sur le nom x *) +let findHypName (names: var list) (x: var) = + let xStr = fst (split x) in + let maxi = ref 0 in + let rec finder l = match l with + | [] -> () + | v::r -> + begin + let (vS,vI) = split v in + (if xStr=vS then maxi := max !maxi vI); + finder r + end + in + finder names; + xStr ^ (string_of_int (!maxi+1)) +;; + (* Renvoie un nom de type simple non utilisé dans le type t qui commence par x *) let findTFreeName (t: ty) (x: tvar) = let xStr = fst (tsplit x) in @@ -55,6 +95,9 @@ let findTFreeName (t: ty) (x: tvar) = | TImpl(t1, t2) -> (finder t1;finder t2) | TSimple(y) -> let (yS,yI) = split y in if xStr=yS then maxi := max !maxi yI + | TAnd(t1, t2) -> (finder t1;finder t2) + | TOr(t1, t2) -> (finder t1;finder t2) + | TTrue -> () | TFalse -> () (* Le faux ne réserve pas de variables *) in finder t; @@ -72,6 +115,13 @@ let rec replace (l: lam) (x: var) (s: lam) = match l with | LApp(l1, l2) -> LApp(replace l1 x s, replace l2 x s) | LVar(v) -> if v=x then s else LVar(v) | LExf(l',t) -> LExf(replace l' x s, t) + | LCouple(lg,ld) -> LCouple(replace lg x s, replace ld x s) + | LFst(l') -> LFst(replace l' x s) + | LSnd(l') -> LSnd(replace l' x s) + | LIg(l',t) -> LIg(replace l' x s, t) + | LId(l',t) -> LId(replace l' x s, t) + | LCase(l',lg,ld) -> LCase(replace l' x s, replace lg x s, replace ld x s) + ;; (* Teste si les deux λ-termes l1 et l2 sont α-convertibles *) @@ -85,6 +135,12 @@ let rec alpha (l1: lam) (l2: lam) : bool = | (LApp(lf1,lx1),LApp(lf2,lx2)) -> (alpha lf1 lf2) && (alpha lx1 lx2) | (LVar(x1),LVar(x2)) -> x1 = x2 | (LExf(l1', t1),LExf(l2', t2)) -> t1=t2 && (alpha l1' l2') + | (LFst(l1),LFst(l2)) -> alpha l1 l2 + | (LSnd(l1),LSnd(l2)) -> alpha l1 l2 + | (LIg(l1,t1),LIg(l2,t2)) -> t1=t2 && alpha l1 l2 + | (LId(l1,t1),LId(l2,t2)) -> t1=t2 && alpha l1 l2 + | (LCase(l1,lg1,ld1),LCase(l2,lg2,ld2)) -> (alpha l1 l2) && (alpha lg1 lg2) && (alpha ld1 ld2) + | _ -> false (* Les deux formules n'ont pas la même structure *) ;; @@ -105,6 +161,29 @@ let rec betastep (l: lam) : lam option = match l with end | LVar(x) -> None | LExf(l',t) -> Option.bind (betastep l') (fun l' -> Some (LExf(l',t))) + | LCouple(lg,ld) -> optionmatch (Option.bind (betastep ld) (fun lg' -> Some (LCouple(ld,lg')))) (fun lg' -> Some (LCouple(lg',ld))) (betastep lg) + | LFst(ll) -> begin + match (ll,betastep ll) with + | (_,Some ll') -> Some (LFst(ll')) + | (LCouple(lg,ld),None) -> Some lg + | (_,None) -> None + end + | LSnd(ll) -> begin + match (ll,betastep ll) with + | (_,Some ll') -> Some (LFst(ll')) + | (LCouple(lg,ld),None) -> Some ld + | (_,None) -> None + end + | LIg(ll,t) -> Option.bind (betastep ll) (fun l' -> Some (LIg(ll,t))) + | LId(ll,t) -> Option.bind (betastep ll) (fun l' -> Some (LId(ll,t))) + | LCase(ll,lg,ld) -> begin + match (ll,betastep ll) with + | (_,Some ll') -> Some (LFst(ll')) + | (LIg(_,_),None) -> Some lg + | (LId(_,_),None) -> Some ld + | (_,None) -> None + end + ;; (* Affiche les réductions du λ-terme l jusqu’à atteindre une forme normale, ou part en boucle infinie *) @@ -116,7 +195,7 @@ let rec reduce (l:lam) : unit = | None -> () ;; -(* Calcule le type du λ-terme l sous l'environnement env. 7 +(* Calcule le type du λ-terme l sous l'environnement env. Renvoie None si la formule n'est pas typable ou si la formule n'est pas close (sous d'environnement)*) let rec computeType (env: gam) (l: lam) : ty option = match l with @@ -136,10 +215,22 @@ let rec computeType (env: gam) (l: lam) : ty option = else computeType env' l | [] -> None end - | LExf(l',t) -> + | LExf(l',t) -> begin match (computeType env l') with | Some TFalse -> Some t (* On applique le ExFalso *) | _ -> None (* Le ex falso a le mauvais type *) + end + | LCouple(lg,ld) -> Option.bind (computeType env lg) (fun tg -> Option.bind (computeType env ld) (fun td -> Some (TAnd(tg,td)))) + | LFst(l') -> Option.bind (computeType env l') (function TAnd(t1,t2) -> Some t1 | _ -> None) + | LSnd(l') -> Option.bind (computeType env l') (function TAnd(t1,t2) -> Some t2 | _ -> None) + | LIg(l',td) -> Option.bind (computeType env l') (fun tg -> Some (TOr(tg,td))) + | LId(l',tg) -> Option.bind (computeType env l') (fun td -> Some (TOr(tg,td))) + | LCase(l',lg,ld) -> begin + match (computeType env l',computeType env lg,computeType env ld) with + | (Some TOr(t1a,t1b),Some TImpl(t2a,t2c),Some TImpl(t3b,t3c)) when t1a=t2a && t1b=t3b && t2c=t3c -> Some t3c + | _ -> None + end + ;; (* Vérifie que le λ-terme l sous l'environnement env a bien le type t *) diff --git a/structs.ml b/structs.ml index ede5557..676bf18 100644 --- a/structs.ml +++ b/structs.ml @@ -13,14 +13,23 @@ let tvarRegex = Str.regexp "^([A-Z]+)([0-9]*)?$";; type ty = | TSimple of var_type | TImpl of ty * ty - | TFalse;; + | TAnd of ty * ty + | TOr of ty * ty + | TFalse + | TTrue;; (* λ-terme *) type lam = | LFun of var_lambda * ty * lam | LApp of lam * lam | LVar of var_lambda - | LExf of lam * ty;; + | LExf of lam * ty + | LCouple of lam * lam + | LFst of lam + | LSnd of lam + | LIg of lam * ty + | LId of lam * ty + | LCase of lam * lam * lam;; (* Environnement de typage *) type gam = (var_type * ty) list;; diff --git a/tactic.ml b/tactic.ml index a125cba..33e4669 100644 --- a/tactic.ml +++ b/tactic.ml @@ -5,4 +5,7 @@ type tactic = | Assumption | Apply of var_lambda | Elim of var_lambda - | Cut of ty;; + | Cut of ty + | Split of var_lambda option + | Left + | Right;; diff --git a/tests/elim-and.8pus b/tests/elim-and.8pus new file mode 100644 index 0000000..81d1341 --- /dev/null +++ b/tests/elim-and.8pus @@ -0,0 +1,6 @@ +(A /\ B) -> A +intro et. +elim et. +intro a. +intro b. +assumption. diff --git a/tests/elim-or.8pus b/tests/elim-or.8pus new file mode 100644 index 0000000..801b7ec --- /dev/null +++ b/tests/elim-or.8pus @@ -0,0 +1,12 @@ +(A \/ B) -> (~A -> B) +intro ou. +intro aa. +elim ou. +intro a. +cut False. +intro ff. +elim ff. +apply aa. +assumption. +intro b. +assumption. diff --git a/tests/intro-and.8pus b/tests/intro-and.8pus new file mode 100644 index 0000000..67936b0 --- /dev/null +++ b/tests/intro-and.8pus @@ -0,0 +1,15 @@ +(A/\B)->(A->C)->(B->D)->(C/\D) +intro et. +intro i1. +intro i2. +split. +apply i1. +elim et. +intro a. +intro b. +assumption. +apply i2. +elim et. +intro a. +intro b. +assumption. diff --git a/tests/intro-or.8pus b/tests/intro-or.8pus new file mode 100644 index 0000000..a58622a --- /dev/null +++ b/tests/intro-or.8pus @@ -0,0 +1,13 @@ +(A \/ B) -> (A -> C) -> (B -> D) -> (C \/ D) +intro ou. +intro i1. +intro i2. +elim ou. +intro a. +left. +apply i1. +assumption. +intro b. +right. +apply i2. +assumption.