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

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 }
 

main.ml

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

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 <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,6 +64,10 @@ 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 */

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,15 +29,21 @@ 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);;
@@ -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 *)

structs.ml

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

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

tests/elim-and.8pus

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

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.

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.

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.