(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")

(filecreated " 7-Oct-88 12:26:27" {indigo}<gslws>lyric>library>plotobjects2.\;6
 23088  

      |changes| |to:|  (fns clipped.fillpolygon clipped.polygon finish-clip-polygon 
                            clip-polygon-vertex clip-insidep clip-intersect getfilledpolygon 
                            drawfilledpolygon createfilledpolygon distancetofilledpolygon 
                            erasefilledpolygon extentoffilledpolygon highlightfilledpolygon 
                            plotfilledpolygon clipped.findto clipped.findline copyfilledpolygon 
                            movefilledpolygon putfilledpolygon)
                       (vars plotobjects2coms)
                       (records clipedgeinfo filledpolygondata)

      |previous| |date:| " 5-Oct-88 11:21:10" {indigo}<gslws>lyric>library>plotobjects2.\;1)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(prettycomprint plotobjects2coms)

(rpaqq plotobjects2coms

       ((fns copyfilledpolygon createfilledpolygon distancetofilledpolygon drawfilledpolygon 
             erasefilledpolygon extentoffilledpolygon getfilledpolygon highlightfilledpolygon 
             movefilledpolygon plotfilledpolygon putfilledpolygon)
        (vars object2opstable)
        (records filledpolygondata)
        (p (plot.setup object2opstable))
        (fns clipped.fillpolygon clipped.polygon clip-polygon-vertex finish-clip-polygon clip-insidep
             clip-intersect)
        (records clipedgeinfo)))
(defineq

(copyfilledpolygon

  (lambda (plotobject plot)
                                  (* \; "Edited  5-Oct-88 10:23 by thh:")


    (* |;;| "Copyfn for FILLEDPOLYGON objects")


    (let ((objectdata (fetch
 (plotobject objectdata) of
 plotobject)))
         (create
 filledpolygondata
                polygonpoints _ (copyall (fetch
 (filledpolygondata polygonpoints) of
 objectdata))
                style _ (copyall (fetch
 (filledpolygondata style) of
 objectdata))
                texture _ (fetch
 (filledpolygondata texture) of
 objectdata)))))

(createfilledpolygon

  (lambda (positions label style texture menu)
               (* \; "Edited  5-Oct-88 12:49 by thh:")

    (createplotobject filledpolygonfns 'filledpolygon label menu
           (|create|
 filledpolygondata
                  polygonpoints _ positions
                  style _ (cond
                             ((fixp style)
                              (|create|
 plot.style
                                     linewidth _ style))
                             ((listp style)
                              (|create|
 plot.style
                                     linewidth _ (car style)
                                     dashing _ (cadr style)
                                     color _ (caddr style)))
                             (t (|create|
 plot.style
                                       linewidth _ 1)))
                  texture _ texture))))

(distancetofilledpolygon

  (lambda (filledpolygon streamposition plot)
                (* \; "Edited  5-Oct-88 10:32 by thh:")

    (l1metric streamposition (|for|
 point |in|
 (|fetch|
 (filledpolygondata streampoints)
                                                  |of|
 (|fetch|
 objectdata |of|
 filledpolygon))
                                |smallest|
 (l1metric point streamposition)))))

(drawfilledpolygon

  (lambda (filledpolygon viewport plot)
                      (* \; "Edited  5-Oct-88 13:05 by thh:")

    (let* ((stream (|fetch|
 (viewport parentstream) |of|
 viewport))
           (streamsubregion (|fetch|
 (viewport streamsubregion) |of|
 viewport))
           (objectdata (|fetch|
 (plotobject objectdata) |of|
 filledpolygon))
           (points (|fetch|
 (filledpolygondata polygonpoints) |of|
 objectdata))
           (streampoints (|for|
 pt |in|
 points |collect|
 (worldtostream pt viewport)))
           (style (|fetch|
 (filledpolygondata style) |of|
 objectdata))
           (linewidth (times (dspscale nil stream)
                             (|fetch|
 (plot.style linewidth) |of|
 style)))
           (dashing (|fetch|
 (plot.style dashing) |of|
 style))
           (color (|fetch|
 (plot.style color) |of|
 style)))
          (clipped.fillpolygon
 streamsubregion streampoints (|fetch|
 (filledpolygondata texture)
                                                               |of|
 objectdata)
                 stream
                 'replace nil (< 0 linewidth)
                 linewidth
                 'replace color dashing)
          (cond
             ((eq stream (windowprop (|fetch|
 (plot plotwindow) |of|
 plot)
                                'dsp))
              (|replace|
 (filledpolygondata streampoints) |of|
 objectdata |with|
 streampoints))))))

(erasefilledpolygon

  (lambda (filledpolygon viewport plot)
                      (* \; "Edited  5-Oct-88 13:05 by thh:")


    (* |;;| "Erase a FILLEDPOLYGONDATA")


    (let* ((stream (|fetch|
 (viewport parentstream) |of|
 viewport))
           (streamsubregion (|fetch|
 (viewport streamsubregion) |of|
 viewport))
           (objectdata (|fetch|
 (plotobject objectdata) |of|
 filledpolygon))
           (streampoints (|fetch|
 (filledpolygondata streampoints) |of|
 objectdata))
           (style (|fetch|
 (filledpolygondata style) |of|
 objectdata))
           (linewidth (iplus 2 (|fetch|
 (plot.style linewidth) |of|
 style)))
           (color (|fetch|
 (plot.style color) |of|
 style)))
          (clipped.fillpolygon
 streamsubregion streampoints (|fetch|
 (filledpolygondata texture)
                                                               |of|
 objectdata)
                 stream
                 'erase nil (< 0 (|fetch|
 (plot.style linewidth) |of|
 style))
                 linewidth
                 'erase color))))

(extentoffilledpolygon

  (lambda (filledpolygon)
                                    (* \; "Edited  5-Oct-88 10:50 by thh:")

    (|bind|
 (minx _ max.float)
           (maxx _ min.float)
           (miny _ max.float)
           (maxy _ min.float)
           x y |for|
 position |in|
 (|fetch|
 (filledpolygondata polygonpoints)
                                      |of|
 (|fetch|
 objectdata |of|
 filledpolygon))
       |declare|
 (type floating minx maxx miny maxy x y) |do|
 (setq x (|fetch|
 xcoord |of|
 position))
                                                              (setq y (|fetch|
 ycoord |of|
 position))
                                                              (cond
                                                                 ((flessp x minx)
                                                                  (setq minx x)))
                                                              (cond
                                                                 ((fgreaterp x maxx)
                                                                  (setq maxx x)))
                                                              (cond
                                                                 ((flessp y miny)
                                                                  (setq miny y)))
                                                              (cond
                                                                 ((fgreaterp y maxy)
                                                                  (setq maxy y)))
       |finally|
 (return (|create|
 extent
                                minx _ minx
                                maxx _ maxx
                                miny _ miny
                                maxy _ maxy)))))

(getfilledpolygon

  (lambda (proplst)
                                          (* \; "Edited  5-Oct-88 13:22 by thh:")

    (let ((stylelst (listget proplst 'style)))
         (|create|
 filledpolygondata
                polygonpoints _ (listget proplst 'polygonpoints)
                style _ (|create|
 plot.style
                               linewidth _ (car stylelst)
                               dashing _ (cadr stylelst)
                               color _ (caddr stylelst))
                texture _ (listget proplst 'texture)))))

(highlightfilledpolygon

  (lambda (filledpolygon viewport plot)
                      (* \; "Edited  5-Oct-88 13:12 by thh:")

    (let* ((stream (|fetch|
 (viewport parentstream) |of|
 viewport))
           (streamsubregion (|fetch|
 (viewport streamsubregion) |of|
 viewport))
           (objectdata (|fetch|
 (plotobject objectdata) |of|
 filledpolygon))
           (streampoints (|fetch|
 (filledpolygondata streampoints) |of|
 objectdata))
           (style (|fetch|
 (filledpolygondata style) |of|
 objectdata))
           (linewidth (iplus 2 (|fetch|
 (plot.style linewidth) |of|
 style)))
           (color (|fetch|
 (plot.style color) |of|
 style)))
          (clipped.fillpolygon
 streamsubregion streampoints blackshade stream 'invert nil
                 (< 0 (|fetch|
 (plot.style linewidth) |of|
 style))
                 linewidth
                 'invert color))))

(movefilledpolygon

  (lambda (filledpolygon dx dy plot)
                         (* \; "Edited  5-Oct-88 11:09 by thh:")

    (let ((points (fetch
 (filledpolygondata polygonpoints) of
 (fetch
 objectdata of
 filledpolygon))))
         (for
 point in
 points do
 (replace
 xcoord of
 point with
 (plus dx (fetch
 xcoord of
 point)))
                                 (replace
 ycoord of
 point with
 (plus dy (fetch
 ycoord of
 point)))))))

(plotfilledpolygon

  (lambda (plot positions label style texture menu nodrawflg)
(* \; "Edited  5-Oct-88 11:11 by thh:")

    (cond
       ((not (|type?|
 plot plot))
        (help "NOT a PLOT" plot)))
    (addplotobject (createfilledpolygon
 positions label style texture menu)
           plot nodrawflg)))

(putfilledpolygon

  (lambda (plotobject plot stream)
                           (* \; "Edited  5-Oct-88 11:13 by thh:")

    (prog ((objectdata (|fetch|
 (plotobject objectdata) |of|
 plotobject))
           style)
          (setq style (|fetch|
 (filledpolygondata style) |of|
 objectdata))
          (printout stream "(" \, "POLYGONPOINTS" \, |.P2| (|fetch|
 (filledpolygondata polygonpoints)
                                                              |of|
 objectdata)
                 \, "TEXTURE" \, |.P2| (|fetch|
 (filledpolygondata texture) |of|
 objectdata)
                 \, "STYLE" \, |.P2| (list (|fetch|
 (plot.style linewidth) |of|
 style)
                                           (|fetch|
 (plot.style dashing) |of|
 style)
                                           (|fetch|
 (plot.style color) |of|
 style))
                 \, ")"))))
)

(rpaqq object2opstable

       ((filledpolygon (drawfn drawfilledpolygon)
               (erasefn erasefilledpolygon)
               (highlightfn highlightfilledpolygon)
               (movefn movefilledpolygon)
               (labelfn labelgeneric)
               (extentfn extentoffilledpolygon)
               (distancefn distancetofilledpolygon)
               (copyfn copyfilledpolygon)
               (putfn putfilledpolygon)
               (getfn getfilledpolygon))))
(declare\: eval@compile

(datatype filledpolygondata
 (polygonpoints streampoints style texture)
                            style _ 1)
)

(/declaredatatype 'filledpolygondata '(pointer pointer pointer pointer)
       '((filledpolygondata 0 pointer)
         (filledpolygondata 2 pointer)
         (filledpolygondata 4 pointer)
         (filledpolygondata 6 pointer))
       '8)

(plot.setup object2opstable)
(defineq

(clipped.fillpolygon

  (lambda (clippingregion points texture stream operation windnumber draw? width drawoperation color
                 dashing)
                                    (* \; "Edited  7-Oct-88 09:03 by thh:")


    (* |;;| "Clip filled polygon against CLIPPINGREGION. If DRAW? is non-NIL, the clipped perimeter of the polygon is drawn as well using the remaining parameters.")


    (let ((clippedpoints (clipped.polygon
 clippingregion points)))
                                                             (* \; 

                                   "CLIPPEDPOINTS is NIL if polygon doesn't intersect CLIPPINGREGION")

         (cond
            (clippedpoints 

                   (* |;;| "fill clipped polygon")


                   (fillpolygon clippedpoints texture stream operation windnumber)

                   (* |;;| "draw if requested")


                   (and draw? (|bind|
 (start _ (car points))
                                 |first|
 (moveto (|fetch|
 xcoord |of|
 start)
                                                (|fetch|
 ycoord |of|
 start)
                                                stream) |for|
 pt |in|
 (cdr points)
                                 |do|
 (clipped.drawto clippingregion (|fetch|
 xcoord |of|
 pt)
                                             (|fetch|
 ycoord |of|
 pt)
                                             width drawoperation stream color dashing)
                                 |finally|
 (clipped.drawto clippingregion (|fetch|
 xcoord
                                                                             |of|
 start)
                                                  (|fetch|
 ycoord |of|
 start)
                                                  width drawoperation stream color dashing))))))))

(clipped.polygon

  (lambda (clippingregion points)
                            (* \; "Edited  6-Oct-88 17:10 by thh:")


    (* |;;| "clips polygon whose vertices are given in POINTS to CLIPPINGREGION using Sutherland-Hodgman algorithm. cf. p.450 of Foley and Van Dam")


    (let* ((left (|fetch|
 left |of|
 clippingregion))
           (right (|fetch|
 right |of|
 clippingregion))
           (top (|fetch|
 top |of|
 clippingregion))
           (bottom (|fetch|
 bottom |of|
 clippingregion))
           (edges (list (|create|
 clipedgeinfo
                               x _ left
                               y _ bottom
                               end _ top
                               vertical? _ t)
                        (|create|
 clipedgeinfo
                               x _ left
                               y _ top
                               end _ right
                               vertical? _ nil)
                        (|create|
 clipedgeinfo
                               x _ right
                               y _ top
                               end _ bottom
                               vertical? _ t)
                        (|create|
 clipedgeinfo
                               x _ right
                               y _ bottom
                               end _ left
                               vertical? _ nil)))
           clippedpoints)

          (* |;;| "each edge in EDGES is a pair of points such that on moving from first to second, inside of CLIPPINGREGION is on the right. THESE ARE LEFT, TOP, RIGHT AND BOTTOM EDGES RESPECTIVELY.")


          (for
 pt in
 points do
 (setq clippedpoints (clip-polygon-vertex
 pt edges clippedpoints)))
          (finish-clip-polygon
 edges clippedpoints))))

(clip-polygon-vertex

  (lambda (point edges clippedpoints)
                        (* \; "Edited  6-Oct-88 16:02 by thh:")


(* |;;;| "implements single step of Sutherland-Hodgman algorithm")


    (cond
       (edges (let* ((edge (car edges))
                     (prevpoint (|fetch|
 (clipedgeinfo prevpt) |of|
 edge))
                     (previnside? (|fetch|
 (clipedgeinfo previnside?) |of|
 edge))
                     (inside? (clip-insidep
 point edge)))

                    (* |;;| "update points and check for intersection")


                    (cond
                       ((|fetch|
 (clipedgeinfo firstpt) |of|
 edge)

                        (* |;;| "this is not first point of polygon to be clipped with this edge")


                        (cond
                           ((neq previnside? inside?)        (* \; "polygon side crosses edge")

                            (setq clippedpoints (clip-polygon-vertex
 (clip-intersect
 prevpoint point
                                                                            edge)
                                                       (cdr edges)
                                                       clippedpoints)))))
                       (t 
                          (* |;;| "this is first point of the polygon for this edge")


                          (|replace|
 (clipedgeinfo firstpt) |of|
 edge |with|
 point)
                          (|replace|
 (clipedgeinfo firstinside?) |of|
 edge |with|
 inside?)))
                    (|replace|
 (clipedgeinfo prevpt) |of|
 edge |with|
 point)
                    (|replace|
 (clipedgeinfo previnside?) |of|
 edge |with|
 inside?)

                    (* |;;| "")


                    (* |;;| "check if new point should be included")


                    (cond
                       (inside? (setq clippedpoints (clip-polygon-vertex
 point (cdr edges)
                                                           clippedpoints))))))
       (t                                                    (* \; "nothing to clip against")

          (push
 clippedpoints point)))
    clippedpoints))

(finish-clip-polygon

  (lambda (edges clippedpoints)
                              (* \; "Edited  6-Oct-88 16:10 by thh:")

    (cond
       (edges (let ((edge (car edges)))
                   (cond
                      ((and clippedpoints (neq (|fetch|
 (clipedgeinfo firstinside?) |of|
 edge)
                                               (|fetch|
 (clipedgeinfo previnside?) |of|
 edge)))
                                                             (* \; 

                                                             "last side of polygon crosses edge")

                       (setq clippedpoints (clip-polygon-vertex
 (clip-intersect
 (|fetch|
 (
                                                                                         clipedgeinfo
                                                                                          firstpt)
                                                                                   |of|
 edge)
                                                                       (|fetch|
 (clipedgeinfo prevpt)
                                                                          |of|
 edge)
                                                                       edge)
                                                  (cdr edges)
                                                  clippedpoints))))
                   (|replace|
 (clipedgeinfo firstpt) |of|
 edge |with|
 nil)
                   (finish-clip-polygon
 (cdr edges)
                          clippedpoints)))
       (t clippedpoints))))

(clip-insidep

  (lambda (pt edge)
                                          (* \; "Edited  6-Oct-88 16:32 by thh:")


    (* |;;| "T if PT is on or to the right of the directed EDGE (which is the inside of the region of which it is a part)")


    (cond
       ((|fetch|
 (clipedgeinfo vertical?) |of|
 edge)         (* \; "vertical edge")

        (cond
           ((greaterp (|fetch|
 (clipedgeinfo end) |of|
 edge)
                   (|fetch|
 (clipedgeinfo y) |of|
 edge))     (* \; 

                                                         "edge is going up, right is positive x-axis")

            (geq (|fetch|
 xcoord |of|
 pt)
                 (|fetch|
 (clipedgeinfo x) |of|
 edge)))
           (t (leq (|fetch|
 xcoord |of|
 pt)
                   (|fetch|
 (clipedgeinfo x) |of|
 edge)))))
       (t                                                    (* \; "horizontal edge")

          (cond
             ((greaterp (|fetch|
 (clipedgeinfo end) |of|
 edge)
                     (|fetch|
 (clipedgeinfo x) |of|
 edge))   (* \; 

                                                      "edge is going right, right is negative y-axis")

              (leq (|fetch|
 ycoord |of|
 pt)
                   (|fetch|
 (clipedgeinfo y) |of|
 edge)))
             (t (geq (|fetch|
 ycoord |of|
 pt)
                     (|fetch|
 (clipedgeinfo y) |of|
 edge))))))))

(clip-intersect

  (lambda (p1 p2 edge)
                                       (* \; "Edited  6-Oct-88 16:42 by thh:")


    (* |;;| "returns point where segment between P1 and P2 intersect EDGE (the two points are on opposite sides of the edge)")


    (cond
       ((|fetch|
 (clipedgeinfo vertical?) |of|
 edge)         (* \; "vertical edge")

        (let ((x (|fetch|
 (clipedgeinfo x) |of|
 edge)))
             (|create|
 position
                    xcoord _ x
                    ycoord _ (plus (|fetch|
 ycoord |of|
 p1)
                                   (quotient (times (difference x (|fetch|
 xcoord |of|
 p1))
                                                    (difference (|fetch|
 ycoord |of|
 p2)
                                                           (|fetch|
 ycoord |of|
 p1)))
                                          (difference (|fetch|
 xcoord |of|
 p2)
                                                 (|fetch|
 xcoord |of|
 p1)))))))
       (t                                                    (* \; "horizontal edge")

          (let ((y (|fetch|
 (clipedgeinfo y) |of|
 edge)))
               (|create|
 position
                      xcoord _ (plus (|fetch|
 xcoord |of|
 p1)
                                     (quotient (times (difference y (|fetch|
 ycoord |of|
 p1))
                                                      (difference (|fetch|
 xcoord |of|
 p2)
                                                             (|fetch|
 xcoord |of|
 p1)))
                                            (difference (|fetch|
 ycoord |of|
 p2)
                                                   (|fetch|
 ycoord |of|
 p1))))
                      ycoord _ y))))))
)
(declare\: eval@compile

(record clipedgeinfo
 (x y end vertical? firstpt firstinside? prevpt previnside?))
)
(putprops plotobjects2 copyright ("Xerox Corporation" 1988))
(declare\: dontcopy
  (filemap (nil (1540 11177 (copyfilledpolygon 1550 . 2136) (createfilledpolygon 2138 . 3044) (
distancetofilledpolygon 3046 . 3475) (drawfilledpolygon 3477 . 4973) (erasefilledpolygon 4975 . 6088) 
(extentoffilledpolygon 6090 . 7929) (getfilledpolygon 7931 . 8492) (highlightfilledpolygon 8494 . 9435
) (movefilledpolygon 9437 . 9937) (plotfilledpolygon 9939 . 10262) (putfilledpolygon 10264 . 11175)) (
12069 22891 (clipped.fillpolygon 12079 . 13948) (clipped.polygon 13950 . 15777) (clip-polygon-vertex 
15779 . 17993) (finish-clip-polygon 17995 . 19602) (clip-insidep 19604 . 21079) (clip-intersect 21081
 . 22889)))))
stop