Merge branch 'master' into primdoc

CHANGELOG.md

@@ -19,12 +19,14 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/),
 - Add primitive `register-document-information` for furnishing document information dictionaries with PDF files ([PR\#268](https://github.com/gfngfn/SATySFi/pull/268) by `puripuri2100`).
 - Develop `doc/doc-primitives.saty` ([PR\#281](https://github.com/gfngfn/SATySFi/pull/281) by `puripuri2100`).
 - Add Web colors to the `color` packge ([PR\#282](https://github.com/gfngfn/SATySFi/pull/282) by `yasuo-ozu`).
+- Add primitive `clip-graphics-by-path` ([PR\#280](https://github.com/gfngfn/SATySFi/pull/280) by `yasuo-ozu`).
 
 ### Changed
 - Remove the build dependency on Ruby and migrate some build scripts from `Makefile` to `dune` ([PR\#142](https://github.com/gfngfn/SATySFi/pull/142) by `leque`, and [PR\#226](https://github.com/gfngfn/SATySFi/pull/226) by `na4zagin3`).
 - Remove the build dependency on `depext` ([PR\#289](https://github.com/gfngfn/SATySFi/pull/289) by `na4zagin3`).
 - Build `src/*` as a private library ([PR\#173](https://github.com/gfngfn/SATySFi/pull/173) by `leque`).
 - Improve the parser implementation ([PR\#175](https://github.com/gfngfn/SATySFi/pull/175) by `leque`).
+- Support negation on float/length literals such as `-1.0`, `- 3.14`, `- 2.71828cm`, etc. ([PR\#295](https://github.com/gfngfn/SATySFi/pull/295) by `leque`).
 
 ## [0.0.6] - 2021-02-06
 ### Fixed

doc/doc-primitives.saty

@@ -689,6 +689,9 @@ document (|
       +command (`unite-path`) (tPATH --> (tPATH --> tPATH)) {
         2つのパスを統合して1つにする．これはドーナツ形など中空のパスをつくるのに必須である．
       }
+      +command (`clip-graphics-by-path`) (tPATH --> (tGR --> tGR)) {
+        \code{clip-graphics-by-path pat gr}でグラフィクス\code{gr}をパス\code{pat}で切り抜く。
+      }
       +command (`fill`) (tCLR --> (tPATH --> tGR)) {
         \code{fill ${color} ${path}}でパス\code{${path}}の内側を色\code{${color}}で塗ったグラフィックスを返す．
         パスのどこが内側であるかは偶奇則によって決められる．

src/backend/graphicBase.ml

@@ -182,3 +182,4 @@ let get_path_list_bbox pathlst =
     let (ptmin1, ptmax1) = get_path_bbox path in
       (update_min ptmin0 ptmin1, update_max ptmax0 ptmax1)
   ) bboxinit
+

src/backend/graphicD.ml

@@ -116,6 +116,7 @@ type 'a element =
   | DashedStroke of length * dash * color * path list
   | HorzText     of point * 'a
   | LinearTrans  of point * (float * float * float * float) * 'a element
+  | Clip         of path list * 'a element
 
 
 type 'a t = ('a element) Alist.t
@@ -137,15 +138,17 @@ let rec shift_element v grelem =
   | DashedStroke(thkns, dash, color, pathlst) -> DashedStroke(thkns, dash, color, pathlst |> List.map (shift_path v))
   | HorzText(pt, textvalue)                   -> HorzText(pt +@% v, textvalue)
   | LinearTrans(pt, mat, subelem)             -> LinearTrans(pt +@% v, mat, (shift_element v subelem))
+  | Clip(pathlst, subelem)                    -> Clip(List.map (shift_path v) pathlst, shift_element v subelem)
 
 
 let rec get_element_bbox textbboxf grelem =
   match grelem with
   | Fill(_, pathlst)
   | Stroke(_, _, pathlst)
   | DashedStroke(_, _, _, pathlst)
+  | Clip(pathlst, _)
       -> get_path_list_bbox pathlst
-           (* -- currently ignores the thickness of the stroke -- *)
+        (* -- currently ignores the thickness of the stroke -- *)
   | HorzText(pt, textvalue) -> textbboxf pt textvalue
   | LinearTrans(pt, mat, subelem) ->
       let ((xmin, ymin), (xmax, ymax)) = get_element_bbox textbboxf subelem in
@@ -294,6 +297,7 @@ let rec to_pdfops (gr : 'a t) (f : point -> 'a -> Pdfops.t list) : Pdfops.t list
       | DashedStroke(thk, dash, color, pathlst) -> pdfops_of_dashed_stroke thk dash color pathlst
       | HorzText(pt, textvalue)                 -> f pt textvalue
       | LinearTrans(pt, mat, subelem)           -> pdfops_of_lineartrans pt mat subelem f
+      | Clip(pathlst, subelem)                   -> pdfops_of_clip pathlst subelem f
     ) |> List.concat
 
 and pdfops_of_lineartrans pt mat subelem f =
@@ -308,6 +312,20 @@ and pdfops_of_lineartrans pt mat subelem f =
     ];
   ]
 
+and pdfops_of_clip pathlst subelem f =
+  List.concat [
+    [
+      op_q;
+      op_cm_translate (Length.zero, Length.zero);
+    ];
+    pdfops_of_path_list pathlst;
+    [
+      Pdfops.Op_W';
+      Pdfops.Op_n;
+    ];
+    (to_pdfops (Alist.of_list [subelem]) f);
+    [ op_Q ];
+  ]
 
 
 (* -- 'pdfops_test_box': output bounding box of vertical elements for debugging -- *)
@@ -460,3 +478,5 @@ let pdfops_test_scale color (xpos, ypos) len =
       op_Q;
     ];
   ]
+
+let clip_graphics (grelem : 'a element) (pathlst : path list) : 'a element = Clip(pathlst, grelem)

src/backend/graphicD.mli

@@ -46,3 +46,5 @@ val pdfops_test_skip_margins : color -> point -> length -> (bool * length) optio
 val pdfops_test_scale : color -> point -> length -> Pdfops.t list
 
 val to_pdfops : 'a t -> (point -> 'a -> Pdfops.t list) -> Pdfops.t list
+
+val clip_graphics : 'a element -> path list -> 'a element

src/frontend/parser.mly

@@ -166,6 +166,23 @@
     let rng = make_range (Ranged utastL) (Ranged utastR) in
       (rng, UTApply((Range.dummy "binary_operator", UTApply((rngop, UTContentOf([], opnm)), utastL)), utastR))
 
+  let make_uminus op = function
+    | (_, UTFloatConstant(_)) as arg ->
+        binary_operator
+          (Range.dummy "zero-of-unary-minus", UTFloatConstant(0.0))
+          (op, "-.")
+          arg
+    | (_, UTLengthDescription (_, unit)) as arg ->
+        binary_operator
+          (Range.dummy "zero-of-unary-minus", UTLengthDescription(0.0, unit))
+          (op, "-'")
+          arg
+    | arg ->
+        binary_operator
+          (Range.dummy "zero-of-unary-minus", UTIntegerConstant(0))
+          (op, "-")
+          arg
+
 
   let make_standard sttknd endknd main =
     let rng = make_range sttknd endknd in (rng, main)
@@ -748,10 +765,7 @@ nxop:
     { binary_operator utastL (rng, "mod") utastR }
   | tok=EXACT_MINUS; utast2=nxapp
     {
-      binary_operator
-       (Range.dummy "zero-of-unary-minus", UTIntegerConstant(0))
-       (tok, "-")
-       utast2
+      make_uminus tok utast2
     }
   | tok=LNOT; utast2=nxapp
     {

test/parsing/nx.saty

@@ -35,3 +35,5 @@ let op-test =
     F a * b,
     A * b
   )
+
+let uminus = (-1, - 42, -1.0, - 3.14, -1mm, - 2.71828cm, -x, - x)

test/parsing/parser.expected

@@ -60,7 +60,24 @@
                                 ((* a) (not b)); ((* a) F(b));
                                 ((* a) B(U:())); ((* (not a)) b);
                                 ((* F(a)) b); ((* A(U:())) b)]),
-                           UTFinishHeaderFile))
+                           (UTLetNonRecIn (None,
+                              ((Range.Normal ("nx.saty", 39, 4, 39, 10)),
+                               (UTPVariable "uminus")),
+                              (UTTuple
+                                 [((- (UTIntegerConstant 0)) (UTIntegerConstant
+                                                                1));
+                                   ((- (UTIntegerConstant 0)) (UTIntegerConstant
+                                                                 42));
+                                   ((-. (UTFloatConstant 0.)) (UTFloatConstant
+                                                                 1.));
+                                   ((-. (UTFloatConstant 0.)) (UTFloatConstant
+                                                                 3.14));
+                                   L:-1.000000mm;
+                                   ((-' L:0.000000cm) L:2.718280cm);
+                                   ((- (UTIntegerConstant 0)) x);
+                                   ((- (UTIntegerConstant 0)) x)]),
+                              UTFinishHeaderFile))
+                           ))
                         ))
                      ))
                   ))

tests/clip.saty

@@ -0,0 +1,52 @@
+% -*- coding: utf-8 -*-
+@import: head
+@import: ../lib-satysfi/dist/packages/color
+
+
+let-inline ctx \do-fill wid f =
+    let ib = use-image-by-width (load-image `images/peppers-rgb.jpg`) wid
+    in
+    let (w, h, d) = get-natural-metrics ib in
+    inline-graphics w h d (fun (x, y) -> [
+        fill (Color.blue) (f x y w (h +' d))
+    ])
+
+let-inline ctx \do-clip wid f =
+    let ib = use-image-by-width (load-image `images/peppers-rgb.jpg`) wid
+    in
+    let (w, h, d) = get-natural-metrics ib in
+    inline-graphics w h d (fun (x, y) -> [
+        draw-text (x, y) ib
+            |> clip-graphics-by-path (f x y w (h +' d))
+    ])
+
+let path-circle x y w h =
+    start-path (x +' w *' 0.5, y)
+        |> bezier-to (x +' w *' 0.25, y) (x, y +' h *' 0.25) (x, y +' h *' 0.5)
+        |> bezier-to (x, y +' h *' 0.75) (x +' w *' 0.25, y +' h) (x +' w *' 0.5, y +' h)
+        |> bezier-to (x +' w *' 0.75, y +' h) (x +' w, y +' h *' 0.75) (x +' w, y +' h *' 0.5)
+        |> bezier-to (x +' w, y +' h *' 0.25) (x +' w *' 0.75, y) (x +' w *' 0.5, y)
+        |> close-with-line
+in
+
+let path-donut x y w h =
+    unite-path
+        (path-circle x y w h)
+        (path-circle (x +' w *' 0.25) (y +' h *' 0.25) (w *' 0.5) (h *' 0.5))
+in
+
+
+
+document (|
+  title  = {Clipping Examples};
+  author = {\SATySFi; Contributors};
+|) '<
+    +p {
+        \do-fill (5cm) (path-circle);
+        \do-clip (5cm) (path-circle);
+    }
+    +p {
+        \do-fill (5cm) (path-donut);
+        \do-clip (5cm) (path-donut);
+    }
+>

tools/gencode/vminst.ml

@@ -3013,5 +3013,22 @@ in
 let lines = aux Alist.empty in
 close_in inc;
 make_list make_string lines
+|}
+    ; inst "ClipGraphicsByPath"
+        ~name:"clip-graphics-by-path"
+        ~type_:{|
+~% (tPATH @-> tGR @-> tGR)
+|}
+        ~fields:[
+        ]
+        ~params:[
+          param "pathlst" ~type_:"path_value";
+          param "grelem" ~type_:"graphics_element";
+        ]
+        ~is_pdf_mode_primitive:true
+        ~code:{|
+let grelem = GraphicD.clip_graphics grelem pathlst in
+make_graphics grelem
+(* Does it work correctly when len(pathlst) > 1 ?? *)
 |}
     ])