Use modules for marked stars and constellations and refactoring

engboris · engboris · commit a2bf7e82aba0 · 2025-07-11T20:12:45.000+02:00
diff --git a/src/expr.ml b/src/expr.ml
@@ -144,19 +144,19 @@ let rec raylist_of_expr (e : expr) : ray list =
     ray_of_expr h :: raylist_of_expr t
   | e -> failwith ("error: unhandled star " ^ to_string e)
 
-let rec star_of_expr : expr -> marked_star = function
+let rec star_of_expr : expr -> Marked.star = function
   | List [ Symbol k; s ] when equal_string k focus_op ->
-    star_of_expr s |> Lsc_ast.remove_mark |> Lsc_ast.mark
+    star_of_expr s |> Marked.remove |> Marked.make_state
   | List [ Symbol k; s; List ps ] when equal_string k params_op ->
-    Unmarked { content = raylist_of_expr s; bans = bans_of_expr ps }
-  | e -> Unmarked { content = raylist_of_expr e; bans = [] }
+    Action { content = raylist_of_expr s; bans = bans_of_expr ps }
+  | e -> Action { content = raylist_of_expr e; bans = [] }
 
-let rec constellation_of_expr : expr -> marked_constellation = function
-  | Symbol s -> [ Unmarked { content = [ var (s, None) ]; bans = [] } ]
-  | Var x -> [ Unmarked { content = [ var (x, None) ]; bans = [] } ]
+let rec constellation_of_expr : expr -> Marked.constellation = function
+  | Symbol s -> [ Action { content = [ var (s, None) ]; bans = [] } ]
+  | Var x -> [ Action { content = [ var (x, None) ]; bans = [] } ]
   | List [ Symbol s; h; t ] when equal_string s cons_op ->
     star_of_expr h :: constellation_of_expr t
-  | List g -> [ Unmarked { content = [ ray_of_expr (List g) ]; bans = [] } ]
+  | List g -> [ Action { content = [ ray_of_expr (List g) ]; bans = [] } ]
 
 (* ---------------------------------------
    Stellogen expr of Expr
@@ -165,10 +165,10 @@ let rec constellation_of_expr : expr -> marked_constellation = function
 let rec sgen_expr_of_expr (e : expr) : sgen_expr =
   match e with
   | Symbol k when equal_string k nil_op ->
-    Raw [ Unmarked { content = []; bans = [] } ]
+    Raw [ Action { content = []; bans = [] } ]
   (* ray *)
   | Var _ | Symbol _ ->
-    Raw [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ]
+    Raw [ Action { content = [ ray_of_expr e ]; bans = [] } ]
   (* star *)
   | List (Symbol s :: _) when equal_string s params_op -> Raw [ star_of_expr e ]
   | List (Symbol s :: _) when equal_string s cons_op -> Raw [ star_of_expr e ]
diff --git a/src/lsc_ast.ml b/src/lsc_ast.ml
@@ -48,13 +48,15 @@ type ban =
   | Incomp of ray * ray
 [@@deriving eq]
 
-type star =
-  { content : ray list
-  ; bans : ban list
-  }
-[@@deriving eq]
-
-type constellation = star list [@@deriving eq]
+module Raw = struct
+  type star =
+    { content : ray list
+    ; bans : ban list
+    }
+  [@@deriving eq]
+
+  type constellation = star list [@@deriving eq]
+end
 
 let to_var x = Var (x, None)
 
@@ -104,25 +106,42 @@ let fresh_var vars =
    Operation on marked stars
    --------------------------------------- *)
 
-type marked_star =
-  | Marked of star
-  | Unmarked of star
-[@@deriving eq]
+module Marked = struct
+  type star =
+    | State of Raw.star
+    | Action of Raw.star
+  [@@deriving eq]
+
+  type constellation = star list [@@deriving eq]
 
-type marked_constellation = marked_star list [@@deriving eq]
+  let map ~f : star -> star = function
+    | State s -> State { content = List.map ~f s.content; bans = s.bans }
+    | Action s -> Action { content = List.map ~f s.content; bans = s.bans }
 
-let map_mstar ~f : marked_star -> marked_star = function
-  | Marked s -> Marked { content = List.map ~f s.content; bans = s.bans }
-  | Unmarked s -> Unmarked { content = List.map ~f s.content; bans = s.bans }
+  let make_action s = Action s
+  let make_state s = State s
 
-let subst_all_vars sub = List.map ~f:(map_mstar ~f:(subst sub))
+  let make_action_all = List.map ~f:make_action
+
+  let make_state_all =  List.map ~f:make_state
+
+  let remove : star -> Raw.star = function
+    | State s -> s
+    | Action s -> s
+
+  let remove_all = List.map ~f:remove
+
+  let normalize_all x = x |> remove_all |> make_action_all
+end
+
+let subst_all_vars sub = List.map ~f:(Marked.map ~f:(subst sub))
 
 let all_vars mcs : StellarSig.idvar list =
-  List.map mcs ~f:(function Marked s | Unmarked s ->
+  List.map mcs ~f:(function Marked.State s | Marked.Action s ->
     List.map s.content ~f:StellarRays.vars |> List.concat )
   |> List.concat
 
-let normalize_vars (mcs : marked_constellation) =
+let normalize_vars (mcs : Marked.constellation) =
   let vars = all_vars mcs in
   let new_x, new_i = fresh_var vars in
   let new_vars =
@@ -131,18 +150,3 @@ let normalize_vars (mcs : marked_constellation) =
   in
   let sub = List.zip_exn vars new_vars in
   subst_all_vars sub mcs
-
-let unmark = function s -> Unmarked s
-
-let mark = function s -> Marked s
-
-let focus = List.map ~f:(fun r -> mark r)
-
-let remove_mark : marked_star -> star = function
-  | Marked s -> s
-  | Unmarked s -> s
-
-let unmark_all = List.map ~f:(fun s -> Unmarked s)
-
-let remove_mark_all : marked_constellation -> constellation =
-  List.map ~f:remove_mark
diff --git a/src/lsc_eval.ml b/src/lsc_eval.ml
@@ -1,16 +1,19 @@
 open Base
 open Lsc_ast
 open Lsc_ast.StellarRays
+open Lsc_ast.Raw
 
 let ( let* ) x f = Result.bind x ~f
 
 type configuration = constellation * constellation
 
-let unpolarized_star s = List.for_all ~f:(Fn.compose not is_polarised) s.content
+let unpolarized_star s =
+  let open Raw in
+  List.for_all ~f:(Fn.compose not is_polarised) s.content
 
-let kill : constellation -> constellation = List.filter ~f:unpolarized_star
+let kill = List.filter ~f:unpolarized_star
 
-let clean : constellation -> constellation =
+let clean =
   List.filter ~f:(fun s -> List.is_empty s.content)
 
 let fmap_ban ~f = function
@@ -53,18 +56,18 @@ let ident_counter = ref 0
 let classify =
   let rec aux (cs, space) = function
     | [] -> (List.rev cs, List.rev space)
-    | Marked s :: t -> aux (cs, s :: space) t
-    | Unmarked s :: t -> aux (s :: cs, space) t
+    | Marked.State s :: t -> aux (cs, s :: space) t
+    | Marked.Action s :: t -> aux (s :: cs, space) t
   in
   aux ([], [])
 
-let extract_intspace (mcs : marked_constellation) =
+let extract_intspace (mcs : Marked.constellation) =
   ident_counter := 0;
   classify mcs
 
 (* interaction between one selected ray and one selected action *)
 let rec interaction ~queue repl1 repl2 (selected_action, other_actions)
-  (selected_ray, other_rays, bans) : star list =
+  (selected_ray, other_rays, bans) : constellation =
   match selected_action.content with
   | [] -> []
   | r' :: s' when not (is_polarised r') ->
diff --git a/src/lsc_pretty.ml b/src/lsc_pretty.ml
@@ -1,6 +1,7 @@
 open Base
 open Lsc_ast
 open Lsc_ast.StellarRays
+open Lsc_ast.Raw
 
 let string_of_polarity = function Pos -> "+" | Neg -> "-" | Null -> ""
 
diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml
@@ -8,7 +8,7 @@ type idvar = string * int option
 type idfunc = polarity * string
 
 type sgen_expr =
-  | Raw of marked_constellation
+  | Raw of Marked.constellation
   | Id of ident
   | Exec of bool * sgen_expr
   | Group of sgen_expr list
@@ -19,7 +19,7 @@ type sgen_expr =
   | Eval of sgen_expr
 
 type err =
-  | ExpectError of marked_constellation * marked_constellation * ident
+  | ExpectError of Marked.constellation * Marked.constellation * ident
   | UnknownID of string
 
 type env = { objs : (ident * sgen_expr) list }
diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml
@@ -58,8 +58,8 @@ let pp_err e : (string, err) Result.t =
   match e with
   | ExpectError (x, e, Func ((Null, f), [])) when equal_string f "default" ->
     sprintf "%s:\n* expected: %s\n* got: %s\n" (red "Expect Error")
-      (e |> remove_mark_all |> string_of_constellation)
-      (x |> remove_mark_all |> string_of_constellation)
+      (e |> Marked.remove_all |> string_of_constellation)
+      (x |> Marked.remove_all |> string_of_constellation)
     |> Result.return
   | ExpectError (_x, _e, Func ((Null, f), [ t ])) when equal_string f "error" ->
     sprintf "%s: %s\n" (red "Expect Error") (string_of_ray t) |> Result.return
@@ -70,7 +70,7 @@ let pp_err e : (string, err) Result.t =
     |> Result.return
 
 let rec eval_sgen_expr (env : env) :
-  sgen_expr -> (marked_constellation, err) Result.t = function
+  sgen_expr -> (Marked.constellation, err) Result.t = function
   | Raw mcs -> Ok mcs
   | Id x -> begin
     match get_obj env x with
@@ -88,43 +88,43 @@ let rec eval_sgen_expr (env : env) :
     Ok (List.concat mcs)
   | Exec (b, e) ->
     let* eval_e = eval_sgen_expr env e in
-    Ok (exec ~linear:b eval_e |> unmark_all)
+    Ok (exec ~linear:b eval_e |> Marked.make_action_all)
   | Focus e ->
     let* eval_e = eval_sgen_expr env e in
-    eval_e |> remove_mark_all |> focus |> Result.return
+    eval_e |> Marked.remove_all |> Marked.make_state_all |> Result.return
   | Kill e ->
     let* eval_e = eval_sgen_expr env e in
-    eval_e |> remove_mark_all |> kill |> focus |> Result.return
+    eval_e |> Marked.remove_all |> kill |> Marked.make_state_all |> Result.return
   | Clean e ->
     let* eval_e = eval_sgen_expr env e in
-    eval_e |> remove_mark_all |> clean |> focus |> Result.return
+    eval_e |> Marked.remove_all |> clean |> Marked.make_state_all |> Result.return
   | Process [] -> Ok []
   | Process (h :: t) ->
     let* eval_e = eval_sgen_expr env h in
-    let init = eval_e |> remove_mark_all |> focus in
+    let init = eval_e |> Marked.remove_all |> Marked.make_state_all in
     let* res =
       List.fold_left t ~init:(Ok init) ~f:(fun acc x ->
         let* acc = acc in
         match x with
         | Id (Func ((Null, "&kill"), [])) ->
-          acc |> remove_mark_all |> kill |> focus |> Result.return
+          acc |> Marked.remove_all |> kill |> Marked.make_state_all |> Result.return
         | Id (Func ((Null, "&clean"), [])) ->
-          acc |> remove_mark_all |> clean |> focus |> Result.return
+          acc |> Marked.remove_all |> clean |> Marked.make_state_all |> Result.return
         | _ ->
-          let origin = acc |> remove_mark_all |> focus in
+          let origin = acc |> Marked.remove_all |> Marked.make_state_all in
           eval_sgen_expr env (Focus (Exec (false, Group [ x; Raw origin ]))) )
     in
     res |> Result.return
   | Eval e -> (
     let* eval_e = eval_sgen_expr env e in
     match eval_e with
-    | [ Marked { content = [ r ]; bans = _ } ]
-    | [ Unmarked { content = [ r ]; bans = _ } ] ->
+    | [ State { content = [ r ]; bans = _ } ]
+    | [ Action { content = [ r ]; bans = _ } ] ->
       r |> expr_of_ray |> Expr.sgen_expr_of_expr |> eval_sgen_expr env
     | e ->
       failwith
         ( "eval error: "
-        ^ string_of_constellation (remove_mark_all e)
+        ^ string_of_constellation (Marked.remove_all e)
         ^ " is not a ray." ) )
 
 and expr_of_ray = function
@@ -139,13 +139,13 @@ let rec eval_decl env : declaration -> (env, err) Result.t = function
     let env = { objs = add_obj env x e } in
     Ok env
   | Show (Raw mcs) ->
-    mcs |> remove_mark_all |> string_of_constellation |> Stdlib.print_string;
+    mcs |> Marked.remove_all |> string_of_constellation |> Stdlib.print_string;
     Stdlib.print_newline ();
     Stdlib.flush Stdlib.stdout;
     Ok env
   | Show e ->
     let* eval_e = eval_sgen_expr env e in
-    List.map eval_e ~f:remove_mark
+    List.map eval_e ~f:Marked.remove
     |> string_of_constellation |> Stdlib.print_string;
     Stdlib.print_newline ();
     Ok env
@@ -155,8 +155,7 @@ let rec eval_decl env : declaration -> (env, err) Result.t = function
   | Expect (e1, e2, message) ->
     let* eval_e1 = eval_sgen_expr env e1 in
     let* eval_e2 = eval_sgen_expr env e2 in
-    let normalize x = x |> remove_mark_all |> unmark_all in
-    if not @@ equal_marked_constellation (normalize eval_e1) (normalize eval_e2)
+    if not @@ Marked.equal_constellation (Marked.normalize_all eval_e1) (Marked.normalize_all eval_e2)
     then Error (ExpectError (eval_e1, eval_e2, message))
     else Ok env
   | Use path ->
