Mysaa/pieuvre
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' of gitlab.aliens-lyon.fr:savrillo/pieuvre

Browse Source
This commit is contained in:
Adrien Vannson 2022-05-16 23:19:23 +02:00
commit b5cad5149c
No known key found for this signature in database
GPG Key ID: FE2E66FD978C1A55
10 changed files with 229 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
lexer.mll
View File

@ -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 }

44
main.ml
View File

@ -137,6 +137,7 @@ while !subgoals <> [] do
explore hyps
in
if is_interactive then (
(* Nettoyage du terminal *)
let _ = Sys.command("clear -x") in
@ -208,6 +209,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")
)
@ -218,6 +231,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

15
parser.mly
View File

@ -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 <string> VAR_NAME
%token <string> 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 <Structs.ty> 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 }

105
pieuvre.ml
View File

@ -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,19 +29,25 @@ 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 =
let splitter regex x =
if string_match regex x 0
if (string_match regex x 0)
then
let xStr = matched_group 1 x in
let xInt = matched_group 2 x in
(xStr, int_of_string xInt)
(xStr, if xInt="" then 0 else (int_of_string xInt))
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 *)
@ -81,10 +131,16 @@ let rec alpha (l1: lam) (l2: lam) : bool =
(t1 = t2) &&
(* On trouve un nom libre dans les deux sous-termes *)
let v' = findFreeName (LApp(l1', l2')) v1 in
alpha (replace l1 v1 (LVar(v'))) (replace l2 v2 (LVar(v')))
alpha (replace l1' v1 (LVar(v'))) (replace l2' v2 (LVar(v')))
| (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 *)

17
structs.ml
View File

@ -1,26 +1,35 @@
(* Variables des λ-termes *)
type var_lambda = string;;
type var = var_lambda;; (* TODEL *)
let varRegex = Str.regexp "^([a-z]+)([0-9]*)$";;
let varRegex = Str.regexp "^\\([a-z]+\\)\\([0-9]*\\)$";;
(* Variable des types simples *)
type var_type = string;;
type tvar = var_type;; (* TODEL *)
let tvarRegex = Str.regexp "^([A-Z]+)([0-9]*)$";;
let tvarRegex = Str.regexp "^([A-Z]+)([0-9]*)?$";;
(* Type complexe *)
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;;

5
tactic.ml
View File

@ -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;;

6
tests/elim-and.8pus Normal file
View File

@ -0,0 +1,6 @@
(A /\ B) -> A
intro et.
elim et.
intro a.
intro b.
assumption.

12
tests/elim-or.8pus Normal file
View File

@ -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.

15
tests/intro-and.8pus Normal file
View File

@ -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.

13
tests/intro-or.8pus Normal file
View File

@ -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.