(FILECREATED " 4-Mar-86 17:29:54" {QV}<PEDERSEN>LISP>TWODGRAPHICS.;39 38011
changes to: (VARS TWODGRAPHICSCOMS)
previous date: "25-Feb-86 13:35:18" {QV}<PEDERSEN>LISP>TWODGRAPHICS.;38)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TWODGRAPHICSCOMS)
(RPAQQ TWODGRAPHICSCOMS ((* * World to window transforms)
(FNS CREATEVIEWPORT COMPUTETRANSFORM COMPUTEWORLDREGION SETSTREAMSUBREGION SETWORLDREGION
STREAMREGIONTOWORLDREGION STREAMTOWORLD TWODGRAPHICS.BITBLT TWODGRAPHICS.CLOSEFN
TWODGRAPHICS.DRAWBETWEEN TWODGRAPHICS.DRAWLINE TWODGRAPHICS.DRAWTO TWODGRAPHICS.DRAWTOPT
TWODGRAPHICS.DSPFILL TWODGRAPHICS.DSPRESET TWODGRAPHICS.INIT TWODGRAPHICS.MOVETO
TWODGRAPHICS.MOVETOPT TWODGRAPHICS.PLOTAT TWODGRAPHICS.RELDRAWTO
TWODGRAPHICS.RELDRAWTOPT TWODGRAPHICS.RELMOVETO TWODGRAPHICS.RELMOVETOPT
TWODGRAPHICS.RESHAPEFN WORLDREGIONTOSTREAMREGION WORLDTOSTREAM)
(MACROS STREAMTOWORLDX STREAMTOWORLDXLENGTH STREAMTOWORLDY STREAMTOWORLDYLENGTH
WORLDTOSTREAMX WORLDTOSTREAMXLENGTH WORLDTOSTREAMY WORLDTOSTREAMYLENGTH)
(RECORDS VIEWPORT)
(* * Primitive clipping FNS)
(FNS CLIPCODE CLIPPED.BITBLT CLIPPED.DESTREGION CLIPPED.DRAWBETWEEN CLIPPED.DRAWLINE
CLIPPED.DRAWTO CLIPPED.PLOTAT CLIPPED.PRIN1 CLIPPED.RELDRAWTO CLIPPED.SOURCEREGION
REPLACE.REGION)
(MACROS SWAPARGS)
(* * For unboxed floating point games)
(FILES UNBOXEDOPS)
(DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T))))
(* * World to window transforms)
(DEFINEQ
(CREATEVIEWPORT
[LAMBDA (STREAM STREAMSUBREGION SOURCE) (* jop: "24-Feb-86 13:59")
(* * Create a viewport. If source is a region , then treat it as a region in world coorinates and set up the
transformation to stream coorindates. If source is a Viewport, inherit the transformation and set up the world
coordinates. If Source is NIL then supply a default WORLDREGION. In either case if STREAM is a STREAM then inter
the viewport in the VIEWPORTS property of the window.)
(PROG ((STREAMCLIPPINGREGION (DSPCLIPPINGREGION NIL STREAM))
VIEWPORT)
[if (NULL STREAMSUBREGION)
then (SETQ STREAMSUBREGION (with REGION STREAMCLIPPINGREGION
(CREATEREGION LEFT BOTTOM WIDTH HEIGHT]
(if (NULL SOURCE)
then (SETQ SOURCE (CREATEREGION 0.0 0.0 1.0 1.0)))
(if (NOT (SUBREGIONP STREAMCLIPPINGREGION STREAMSUBREGION))
then (HELP (CONCAT STREAMSUBREGION " Not a subregion of " STREAMCLIPPINGREGION))
)
(SETQ VIEWPORT (if (type? REGION SOURCE)
then (COMPUTETRANSFORM (create VIEWPORT
PARENTSTREAM ← STREAM
STREAMSUBREGION ←
STREAMSUBREGION
WORLDREGION ← SOURCE))
elseif (type? VIEWPORT SOURCE)
then (COMPUTEWORLDREGION (create VIEWPORT
PARENTSTREAM ← STREAM
STREAMSUBREGION ←
STREAMSUBREGION
using SOURCE))
else (HELP "Not region or viewort" SOURCE)))
(if (WINDOWP STREAM)
then (TWODGRAPHICS.INIT STREAM)
(WINDOWADDPROP STREAM (QUOTE VIEWPORTS)
VIEWPORT))
(RETURN VIEWPORT])
(COMPUTETRANSFORM
[LAMBDA (VIEWPORT) (* jop: "24-Feb-86 13:52")
(* * Computes the world to window transformation given a viewport's windowsubregion and worldregion)
(PROG ((STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT))
(WORLDREGION (fetch (VIEWPORT WORLDREGION) of VIEWPORT)))
(* SUB1 since we are dealing width an integer grid)
(replace WORLDTOSTREAMMX of VIEWPORT with (FQUOTIENT (SUB1 (fetch WIDTH
of
STREAMSUBREGION))
(fetch WIDTH of
WORLDREGION)))
[replace WORLDTOSTREAMAX of VIEWPORT with (FDIFFERENCE (fetch LEFT
of STREAMSUBREGION)
(FTIMES (fetch
WORLDTOSTREAMMX
of VIEWPORT)
(fetch LEFT
of
WORLDREGION]
(* Ditto)
(replace WORLDTOSTREAMMY of VIEWPORT with (FQUOTIENT (SUB1 (fetch HEIGHT
of
STREAMSUBREGION))
(fetch HEIGHT
of WORLDREGION)))
[replace WORLDTOSTREAMAY of VIEWPORT with (FDIFFERENCE (fetch BOTTOM
of STREAMSUBREGION)
(FTIMES (fetch
WORLDTOSTREAMMY
of VIEWPORT)
(fetch BOTTOM
of
WORLDREGION]
(replace STREAMTOWORLDMX of VIEWPORT with (FQUOTIENT 1.0 (fetch WORLDTOSTREAMMX
of VIEWPORT)))
[replace STREAMTOWORLDAX of VIEWPORT with (UFMINUS (FQUOTIENT (fetch
WORLDTOSTREAMAX
of VIEWPORT)
(fetch
WORLDTOSTREAMMX
of VIEWPORT]
(replace STREAMTOWORLDMY of VIEWPORT with (FQUOTIENT 1.0 (fetch WORLDTOSTREAMMY
of VIEWPORT)))
[replace STREAMTOWORLDAY of VIEWPORT with (UFMINUS (FQUOTIENT (fetch
WORLDTOSTREAMAY
of VIEWPORT)
(fetch
WORLDTOSTREAMMY
of VIEWPORT]
(RETURN VIEWPORT])
(COMPUTEWORLDREGION
[LAMBDA (VIEWPORT) (* jop: "24-Feb-86 13:55")
(* * Given a Viewport's World to Stream transformation computes the corresponding World region)
(PROG ((STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT))
(MX (fetch (VIEWPORT WORLDTOSTREAMMX) of VIEWPORT))
(AX (fetch (VIEWPORT WORLDTOSTREAMAX) of VIEWPORT))
(MY (fetch (VIEWPORT WORLDTOSTREAMMY) of VIEWPORT))
(AY (fetch (VIEWPORT WORLDTOSTREAMAY) of VIEWPORT))
WORREGION)
[SETQ WORREGION (with REGION STREAMSUBREGION (CREATEREGION (FQUOTIENT
(FDIFFERENCE LEFT AX)
MX)
(FQUOTIENT
(FDIFFERENCE BOTTOM
AY)
MY)
(FQUOTIENT WIDTH MX)
(FQUOTIENT HEIGHT MY]
(replace (VIEWPORT WORLDREGION) of VIEWPORT with WORREGION)
(RETURN VIEWPORT])
(SETSTREAMSUBREGION
[LAMBDA (REGION VIEWPORT) (* jop: "24-Feb-86 14:00")
(* * Set the STREAMSUBREGION of a VIEWPORT)
(if (NOT (type? VIEWPORT VIEWPORT))
then (HELP "Not a VIEWPORT" VIEWPORT))
(if (NOT (SUBREGIONP (WINDOWPROP (fetch PARENTSTREAM of VIEWPORT)
(QUOTE WINCLIPPINGREGION))
REGION))
then (HELP "Not a subregion of stream" REGION))
(replace (VIEWPORT STREAMSUBREGION) of VIEWPORT with REGION)
(COMPUTETRANSFORM VIEWPORT])
(SETWORLDREGION
[LAMBDA (REGION VIEWPORT) (* jop: "24-Feb-86 14:00")
(* * Set the WORLDREGION of a VIEWPORT)
(if (NOT (type? VIEWPORT VIEWPORT))
then (HELP "Not a viewport" VIEWPORT))
(replace (VIEWPORT WORLDREGION) of VIEWPORT with REGION)
(COMPUTETRANSFORM VIEWPORT])
(STREAMREGIONTOWORLDREGION
[LAMBDA (REGION VIEWPORT) (* jop: "24-Feb-86 14:06")
(* *)
(CREATEREGION (STREAMTOWORLDX (fetch (REGION LEFT) of REGION)
VIEWPORT)
(STREAMTOWORLDY (fetch (REGION BOTTOM) of REGION)
VIEWPORT)
(STREAMTOWORLDXLENGTH (fetch (REGION WIDTH) of REGION)
VIEWPORT)
(STREAMTOWORLDYLENGTH (fetch (REGION HEIGHT) of REGION)
VIEWPORT])
(STREAMTOWORLD
[LAMBDA (PT VIEWPORT OLDPT) (* jop: "23-Feb-86 19:48")
(* * smashes OLDPT if provided)
(if OLDPT
then (create POSITION
XCOORD ←(STREAMTOWORLDX (fetch (POSITION XCOORD) of PT)
VIEWPORT)
YCOORD ←(STREAMTOWORLDY (fetch (POSITION YCOORD) of PT)
VIEWPORT)
smashing OLDPT)
else (create POSITION
XCOORD ←(STREAMTOWORLDX (fetch (POSITION XCOORD) of PT)
VIEWPORT)
YCOORD ←(STREAMTOWORLDY (fetch (POSITION YCOORD) of PT)
VIEWPORT])
(TWODGRAPHICS.BITBLT
[LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATIONVIEWPORT DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)
(* jop: "23-Feb-86 19:51")
(* * Destination MUST be a VIEWPORT. Source can be either a VIEWPORT or some other form of BITMAP
(in which case no transformations are performed) or NIL)
(if (NULL DESTINATIONVIEWPORT)
then (SETQ DESTINATIONVIEWPORT TWODGRAPHICS.CURRENTVIEWPORT))
(if (NOT (type? VIEWPORT DESTINATIONVIEWPORT))
then (HELP "Destination must be a viewport" DESTINATIONVIEWPORT))
(LET* ((STREAM (fetch (VIEWPORT PARENTSTREAM) of DESTINATIONVIEWPORT))
(STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of DESTINATIONVIEWPORT))
(STREAMLEFT (if (NULL DESTINATIONLEFT)
then (fetch (REGION LEFT) of STREAMSUBREGION)
else (WORLDTOSTREAMX DESTINATIONLEFT DESTINATIONVIEWPORT)))
(STREAMBOTTOM (if (NULL DESTINATIONBOTTOM)
then (fetch (REGION BOTTOM) of STREAMSUBREGION)
else (WORLDTOSTREAMY DESTINATIONBOTTOM DESTINATIONVIEWPORT)))
[STREAMCLIPPINGREGION (if (NULL CLIPPINGREGION)
then STREAMSUBREGION
else (INTERSECTREGIONS STREAMSUBREGION (
WORLDREGIONTOSTREAMREGION
CLIPPINGREGION
DESTINATIONVIEWPORT]
(SOURCEBITMAP SOURCE)
(SOURCEBITMAPLEFT SOURCELEFT)
(SOURCEBITMAPBOTTOM SOURCEBOTTOM)
(SOURCEWIDTH WIDTH)
(SOURCEHEIGHT HEIGHT))
[if (type? VIEWPORT SOURCE)
then (SETQ SOURCEBITMAP (fetch (VIEWPORT PARENTSTREAM) of SOURCE))
(LET ((SOURCESUBREGION (fetch (VIEWPORT STREAMSUBREGION) of SOURCE)))
(SETQ SOURCEBITMAPLEFT (if (NULL SOURCELEFT)
then (fetch (REGION LEFT) of
SOURCESUBREGION)
else (WORLDTOSTREAMX SOURCELEFT SOURCE)))
(SETQ SOURCEBITMAPBOTTOM (if (NULL SOURCEBOTTOM)
then (fetch (REGION BOTTOM)
of SOURCESUBREGION)
else (WORLDTOSTREAMY SOURCEBOTTOM SOURCE)))
(SETQ SOURCEWIDTH (if (NULL WIDTH)
then (fetch (REGION WIDTH) of SOURCESUBREGION)
else (WORLDTOSTREAMXLENGTH WIDTH SOURCE)))
(SETQ SOURCEHEIGHT (if (NULL HEIGHT)
then (fetch (REGION HEIGHT) of
SOURCESUBREGION)
else (WORLDTOSTREAMYLENGTH HEIGHT SOURCE)))
(SETQ STREAMCLIPPINGREGION (INTERSECTREGIONS STREAMCLIPPINGREGION
SOURCESUBREGION]
[if (EQ SOURCETYPE (QUOTE TEXTURE))
then (SETQ SOURCEWIDTH (if (NULL WIDTH)
then (fetch (REGION WIDTH) of STREAMSUBREGION)
else (WORLDTOSTREAMXLENGTH WIDTH DESTINATIONVIEWPORT)))
(SETQ SOURCEHEIGHT (if (NULL HEIGHT)
then (fetch (REGION HEIGHT) of STREAMSUBREGION)
else (WORLDTOSTREAMYLENGTH HEIGHT DESTINATIONVIEWPORT]
(CLIPPED.BITBLT STREAMCLIPPINGREGION SOURCEBITMAP SOURCEBITMAPLEFT SOURCEBITMAPBOTTOM
STREAM STREAMLEFT STREAMBOTTOM SOURCEWIDTH SOURCEHEIGHT SOURCETYPE
OPERATION TEXTURE])
(TWODGRAPHICS.CLOSEFN
[LAMBDA (W) (* jop: "23-Feb-86 19:56")
(* * Break circularities)
(WINDOWPROP W (QUOTE TWODPROPS?)
NIL)
(WINDOWPROP W (QUOTE VIEWPORTS)
NIL)
(WINDOWPROP W (QUOTE WINCLIPPINGREGION)
NIL)
(WINDOWDELPROP W (QUOTE CLOSEFN)
(FUNCTION TWODGRAPHICS.CLOSEFN))
(WINDOWDELPROP W (QUOTE RESHAPEFN)
(FUNCTION TWODGRAPHICS.RESHAPEFN])
(TWODGRAPHICS.DRAWBETWEEN
[LAMBDA (PT1 PT2 WIDTH OPERATION VIEWPORT COLOR DASHING) (* jop: " 4-Dec-85 15:38")
(TWODGRAPHICS.DRAWLINE (fetch XCOORD of PT1)
(fetch YCOORD of PT1)
(fetch XCOORD of PT2)
(fetch YCOORD of PT2)
WIDTH OPERATION VIEWPORT COLOR DASHING])
(TWODGRAPHICS.DRAWLINE
[LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION VIEWPORT COLOR DASHING)
(* jop: "23-Feb-86 18:54")
(* *)
(LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(CLIPPINGREGION (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(STREAMX1 (WORLDTOSTREAMX X1 VIEWPORT))
(STREAMY1 (WORLDTOSTREAMY Y1 VIEWPORT))
(STREAMX2 (WORLDTOSTREAMX X2 VIEWPORT))
(STREAMY2 (WORLDTOSTREAMY Y2 VIEWPORT)))
(CLIPPED.DRAWLINE CLIPPINGREGION STREAMX1 STREAMY1 STREAMX2 STREAMY2 WIDTH OPERATION
STREAM COLOR DASHING])
(TWODGRAPHICS.DRAWTO
[LAMBDA (X Y WIDTH OPERATION VIEWPORT COLOR DASHING) (* jop: "23-Feb-86 18:54")
(* *)
(LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(CLIPPINGREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT))
(STREAMX (WORLDTOSTREAMX X VIEWPORT))
(STREAMY (WORLDTOSTREAMY Y VIEWPORT)))
(CLIPPED.DRAWTO CLIPPINGREGION STREAMX STREAMY WIDTH OPERATION STREAM COLOR DASHING])
(TWODGRAPHICS.DRAWTOPT
[LAMBDA (PT WIDTH OPERATION VIEWPORT COLOR DASHING) (* jop: "23-Feb-86 18:54")
(* *)
(TWODGRAPHICS.DRAWTO (fetch XCOORD of PT)
(fetch YCOORD of PT)
WIDTH OPERATION VIEWPORT COLOR DASHING])
(TWODGRAPHICS.DSPFILL
[LAMBDA (REGION TEXTURE OPERATION VIEWPORT) (* jop: "23-Feb-86 19:06")
(* *)
(LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)))
(TWODGRAPHICS.BITBLT NIL NIL NIL VIEWPORT NIL NIL NIL NIL (QUOTE TEXTURE)
(OR OPERATION (DSPOPERATION NIL STREAM))
(OR TEXTURE (DSPTEXTURE NIL STREAM))
REGION])
(TWODGRAPHICS.DSPRESET
[LAMBDA (VIEWPORT) (* jop: "23-Feb-86 19:11")
(* * RESET a VIEWPORT)
(LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)))
(DSPXPOSITION (DSPLEFTMARGIN NIL STREAM)
STREAM)
[DSPYPOSITION (DIFFERENCE (fetch (REGION TOP) of STREAMSUBREGION)
(FONTPROP STREAM (QUOTE ASCENT]
(TWODGRAPHICS.DSPFILL NIL NIL (QUOTE REPLACE)
VIEWPORT])
(TWODGRAPHICS.INIT
[LAMBDA (W) (* jop: "23-Feb-86 19:55")
(if (NULL (WINDOWPROP W (QUOTE TWODPROPS?)))
then (WINDOWPROP W (QUOTE TWODPROPS?)
T)
(WINDOWPROP W (QUOTE VIEWPORTS)
NIL)
(WINDOWPROP W (QUOTE WINCLIPPINGREGION)
(DSPCLIPPINGREGION NIL W))
(WINDOWADDPROP W (QUOTE CLOSEFN)
(FUNCTION TWODGRAPHICS.CLOSEFN))
(WINDOWADDPROP W (QUOTE RESHAPEFN)
(FUNCTION TWODGRAPHICS.RESHAPEFN)
T])
(TWODGRAPHICS.MOVETO
[LAMBDA (X Y VIEWPORT) (* jop: "23-Feb-86 19:12")
(* *)
(MOVETO (WORLDTOSTREAMX X VIEWPORT)
(WORLDTOSTREAMY Y VIEWPORT)
(fetch PARENTSTREAM of VIEWPORT])
(TWODGRAPHICS.MOVETOPT
[LAMBDA (PT VIEWPORT) (* jop: "23-Feb-86 19:12")
(* *)
(TWODGRAPHICS.MOVETO (fetch XCOORD of PT)
(fetch YCOORD of PT)
VIEWPORT])
(TWODGRAPHICS.PLOTAT
[LAMBDA (PT GLYPH VIEWPORT OPERATION) (* jop: "24-Feb-86 14:26")
(* *)
(PROG ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(STREAMSUBREGION (fetch (VIEWPORT STREAMSUBREGION) of VIEWPORT)))
(CLIPPED.PLOTAT STREAMSUBREGION (WORLDTOSTREAM PT VIEWPORT)
GLYPH STREAM OPERATION])
(TWODGRAPHICS.RELDRAWTO
[LAMBDA (DELTAX DELTAY WIDTH OPERATION VIEWPORT COLOR DASHING)
(* jop: "23-Feb-86 19:25")
(* *)
(LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(CLIPPINGREGION (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT))
(STREAMDX (WORLDTOSTREAMXLENGTH DELTAX VIEWPORT))
(STREAMDY (WORLDTOSTREAMYLENGTH DELTAY VIEWPORT)))
(CLIPPED.DRAWTO CLIPPINGREGION STREAMDX STREAMDY WIDTH OPERATION VIEWPORT COLOR DASHING])
(TWODGRAPHICS.RELDRAWTOPT
[LAMBDA (DPT WIDTH OPERATION VIEWPORT COLOR DASHING) (* jop: "23-Feb-86 19:25")
(* *)
(TWODGRAPHICS.RELDRAWTO (fetch XCOORD of DPT)
(fetch YCOORD DPT)
WIDTH OPERATION VIEWPORT COLOR DASHING])
(TWODGRAPHICS.RELMOVETO
[LAMBDA (DX DY VIEWPORT) (* jop: "23-Feb-86 19:27")
(* *)
(LET ((STREAM (fetch (VIEWPORT PARENTSTREAM) of VIEWPORT)))
(RELMOVETO (WORLDTOSTREAMXLENGTH DX VIEWPORT)
(WORLDTOSTREAMYLENGTH DY VIEWPORT)
STREAM])
(TWODGRAPHICS.RELMOVETOPT
[LAMBDA (DPT VIEWPORT) (* jop: "23-Feb-86 19:29")
(* *)
(TWODGRAPHICS.RELMOVETO (fetch XCOORD of DPT)
(fetch YCOORD of DPT)
VIEWPORT])
(TWODGRAPHICS.RESHAPEFN
[LAMBDA (WINDOW) (* jop: "23-Feb-86 17:55")
(* * updates all viewports associated with window)
(PROG ((OLDCLIPPINGREGION (WINDOWPROP WINDOW (QUOTE WINCLIPPINGREGION)))
(NEWCLIPPINGREGION (DSPCLIPPINGREGION NIL WINDOW))
WIDTHRATIO HEIGHTRATIO)
(SETQ WIDTHRATIO (FQUOTIENT (fetch (REGION WIDTH) of NEWCLIPPINGREGION)
(fetch (REGION WIDTH) of OLDCLIPPINGREGION)))
(SETQ HEIGHTRATIO (FQUOTIENT (fetch (REGION HEIGHT) of NEWCLIPPINGREGION)
(fetch (REGION HEIGHT) of OLDCLIPPINGREGION)))
(bind REGION for V in (WINDOWPROP WINDOW (QUOTE VIEWPORTS))
do (SETQ REGION (fetch (VIEWPORT STREAMSUBREGION) of V))
[replace (VIEWPORT STREAMSUBREGION) of V
with (with REGION REGION (CREATEREGION (FIXR (FTIMES WIDTHRATIO LEFT)
)
(FIXR (FTIMES HEIGHTRATIO
BOTTOM))
(FIXR (FTIMES WIDTHRATIO
WIDTH))
(FIXR (FTIMES HEIGHTRATIO
HEIGHT]
(COMPUTETRANSFORM V))
(WINDOWPROP WINDOW (QUOTE WINCLIPPINGREGION)
NEWCLIPPINGREGION)
(RETURN WINDOW])
(WORLDREGIONTOSTREAMREGION
[LAMBDA (REGION VIEWPORT) (* jop: "23-Feb-86 19:29")
(* *)
(CREATEREGION (WORLDTOSTREAMX (fetch (REGION LEFT) of REGION)
VIEWPORT)
(WORLDTOSTREAMY (fetch (REGION BOTTOM) of REGION)
VIEWPORT)
(WORLDTOSTREAMXLENGTH (fetch (REGION WIDTH) of REGION)
VIEWPORT)
(WORLDTOSTREAMYLENGTH (fetch (REGION HEIGHT) of REGION)
VIEWPORT])
(WORLDTOSTREAM
[LAMBDA (PT VIEWPORT OLDPT) (* jop: "23-Feb-86 19:30")
(* *)
(if OLDPT
then (create POSITION
XCOORD ←(WORLDTOSTREAMX (fetch (POSITION XCOORD) of PT)
VIEWPORT)
YCOORD ←(WORLDTOSTREAMY (fetch (POSITION YCOORD) of PT)
VIEWPORT)
smashing OLDPT)
else (create POSITION
XCOORD ←(WORLDTOSTREAMX (fetch (POSITION XCOORD) of PT)
VIEWPORT)
YCOORD ←(WORLDTOSTREAMY (fetch (POSITION YCOORD) of PT)
VIEWPORT])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS STREAMTOWORLDX MACRO (OPENLAMBDA (X VIEWPORT)
(PROG (RESULT)
(DECLARE (TYPE FLOATP RESULT))
(RETURN (SETQ RESULT
(FPLUS (fetch STREAMTOWORLDAX of
VIEWPORT)
(FTIMES (fetch STREAMTOWORLDMX
of VIEWPORT)
(FLOAT X]
[PUTPROPS STREAMTOWORLDXLENGTH MACRO (OPENLAMBDA (DX VIEWPORT)
(PROG (RESULT)
(DECLARE (TYPE FLOATP RESULT))
(RETURN (SETQ RESULT
(FTIMES (fetch STREAMTOWORLDMX
of VIEWPORT)
(FLOAT DX]
[PUTPROPS STREAMTOWORLDY MACRO (OPENLAMBDA (Y VIEWPORT)
(PROG (RESULT)
(DECLARE (TYPE FLOATP RESULT))
(RETURN (SETQ RESULT
(FPLUS (fetch STREAMTOWORLDAY of
VIEWPORT)
(FTIMES (fetch STREAMTOWORLDMY
of VIEWPORT)
(FLOAT Y]
[PUTPROPS STREAMTOWORLDYLENGTH MACRO (OPENLAMBDA (DY VIEWPORT)
(PROG (RESULT)
(DECLARE (TYPE FLOATP RESULT))
(RETURN (SETQ RESULT
(FTIMES (fetch STREAMTOWORLDMY
of VIEWPORT)
(FLOAT DY]
[PUTPROPS WORLDTOSTREAMX MACRO (OPENLAMBDA (X VIEWPORT)
(UFIX (FPLUS (fetch WORLDTOSTREAMAX of VIEWPORT)
(FTIMES (fetch WORLDTOSTREAMMX of VIEWPORT)
(FLOAT X]
[PUTPROPS WORLDTOSTREAMXLENGTH MACRO (OPENLAMBDA (DX VIEWPORT)
(UFIX (FTIMES (fetch WORLDTOSTREAMMX of VIEWPORT)
(FLOAT DX]
[PUTPROPS WORLDTOSTREAMY MACRO (OPENLAMBDA (Y VIEWPORT)
(UFIX (FPLUS (fetch WORLDTOSTREAMAY of VIEWPORT)
(FTIMES (fetch WORLDTOSTREAMMY of VIEWPORT)
(FLOAT Y]
[PUTPROPS WORLDTOSTREAMYLENGTH MACRO (OPENLAMBDA (DY VIEWPORT)
(UFIX (FTIMES (fetch WORLDTOSTREAMMY of VIEWPORT)
(FLOAT DY]
)
[DECLARE: EVAL@COMPILE
(DATATYPE VIEWPORT (PARENTSTREAM STREAMSUBREGION WORLDREGION (WORLDTOSTREAMMX FLOATP)
(WORLDTOSTREAMAX FLOATP)
(WORLDTOSTREAMMY FLOATP)
(WORLDTOSTREAMAY FLOATP)
(STREAMTOWORLDMX FLOATP)
(STREAMTOWORLDAX FLOATP)
(STREAMTOWORLDMY FLOATP)
(STREAMTOWORLDAY FLOATP)))
]
(/DECLAREDATATYPE (QUOTE VIEWPORT)
(QUOTE (POINTER POINTER POINTER FLOATP FLOATP FLOATP FLOATP FLOATP FLOATP FLOATP
FLOATP))
(QUOTE ((VIEWPORT 0 POINTER)
(VIEWPORT 2 POINTER)
(VIEWPORT 4 POINTER)
(VIEWPORT 6 FLOATP)
(VIEWPORT 8 FLOATP)
(VIEWPORT 10 FLOATP)
(VIEWPORT 12 FLOATP)
(VIEWPORT 14 FLOATP)
(VIEWPORT 16 FLOATP)
(VIEWPORT 18 FLOATP)
(VIEWPORT 20 FLOATP)))
(QUOTE 22))
(* * Primitive clipping FNS)
(DEFINEQ
(CLIPCODE
[LAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* jop: "21-Feb-86 14:02")
(* * Cohen-Sutherland clip codes. Assumes integer args)
(* RIGHT and TOP are one past the region.)
(* RIGHT and TOP are one past the region.)
(LET ((ABOVEBIT (if (GREATERP Y TOP)
then 8
else 0))
(BELOWBIT (if (GREATERP BOTTOM Y)
then 4
else 0))
(RIGHTBIT (if (GREATERP X RIGHT)
then 2
else 0))
(LEFTBIT (if (GREATERP LEFT X)
then 1
else 0)))
(LOGOR ABOVEBIT BELOWBIT RIGHTBIT LEFTBIT])
(CLIPPED.BITBLT
[LAMBDA (CLIPPINGREGION SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT
DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE)
(* jop: "23-Feb-86 16:56")
(* *)
(* Process defaults)
(if (NULL SOURCELEFT)
then (SETQ SOURCELEFT 0))
(if (NULL SOURCEBOTTOM)
then (SETQ SOURCEBOTTOM 0))
(if (NULL DESTINATIONLEFT)
then (SETQ DESTINATIONLEFT 0))
(if (NULL DESTINATIONBOTTOM)
then (SETQ DESTINATIONBOTTOM 0))
[if (NULL WIDTH)
then (if (EQ SOURCETYPE (QUOTE TEXTURE))
then (SETQ WIDTH (if (WINDOWP DESTINATION)
then (WINDOWPROP DESTINATION (QUOTE WIDTH))
else (BITMAPWIDTH DESTINATION)))
else (SETQ WIDTH (if (WINDOWP SOURCEBITMAP)
then (WINDOWPROP SOURCEBITMAP (QUOTE WIDTH))
else (BITMAPWIDTH SOURCEBITMAP]
[if (NULL HEIGHT)
then (if (EQ SOURCETYPE (QUOTE TEXTURE))
then (SETQ HEIGHT (if (WINDOWP DESTINATION)
then (WINDOWPROP DESTINATION (QUOTE HEIGHT))
else (BITMAPHEIGHT DESTINATION)))
else (SETQ HEIGHT (if (WINDOWP SOURCEBITMAP)
then (WINDOWPROP SOURCEBITMAP (QUOTE HEIGHT))
else (BITMAPHEIGHT SOURCEBITMAP]
(LET* [(SCRATCHREGION (CONSTANT (CREATEREGION)))
(NEWDESTREGION (if (EQ SOURCETYPE (QUOTE TEXTURE))
then (REPLACE.REGION SCRATCHREGION DESTINATIONLEFT
DESTINATIONBOTTOM WIDTH HEIGHT)
(if (SUBREGIONP CLIPPINGREGION SCRATCHREGION)
then T
else (INTERSECTREGIONS SCRATCHREGION CLIPPINGREGION))
else (REPLACE.REGION SCRATCHREGION SOURCELEFT SOURCEBOTTOM WIDTH
HEIGHT)
(CLIPPED.DESTREGION SCRATCHREGION CLIPPINGREGION DESTINATIONLEFT
DESTINATIONBOTTOM DESTINATION]
(if (NULL NEWDESTREGION)
then (* Gross clipping)
NIL
elseif (EQ NEWDESTREGION T)
then (* No clipping)
(BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT
DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE)
else (* Adjusted bitblt)
(if (EQ SOURCETYPE (QUOTE TEXTURE))
then (with REGION NEWDESTREGION
(BITBLT NIL NIL NIL DESTINATION LEFT BOTTOM WIDTH HEIGHT
SOURCETYPE OPERATION TEXTURE))
else (LET ((NEWSOURCEREGION (CLIPPED.SOURCEREGION SCRATCHREGION
NEWDESTREGION
DESTINATIONLEFT
DESTINATIONBOTTOM
DESTINATION)))
(BITBLT SOURCEBITMAP (fetch (REGION LEFT) of NEWSOURCEREGION)
(fetch (REGION BOTTOM) of NEWSOURCEREGION)
DESTINATION
(fetch (REGION LEFT) of NEWDESTREGION)
(fetch (REGION BOTTOM) of NEWDESTREGION)
(fetch (REGION WIDTH) of NEWSOURCEREGION)
(fetch (REGION HEIGHT) of NEWSOURCEREGION)
SOURCETYPE OPERATION])
(CLIPPED.DESTREGION
[LAMBDA (SOURCEREGION DESTREGION DESTLEFT DESTBOTTOM DESTSTREAM)
(* jop: "23-Feb-86 16:55")
(* * Stream NIL implies the display. Returns NIL if gross clipped, T if no clipping, else a clipped dest region)
(if (NULL DESTLEFT)
then (SETQ DESTLEFT (fetch (REGION LEFT) of DESTREGION)))
(if (NULL DESTBOTTOM)
then (SETQ DESTLEFT (fetch (REGION BOTTOM) of DESTREGION)))
(PROG [(SWIDTH (fetch (REGION WIDTH) of SOURCEREGION))
(SHEIGHT (fetch (REGION HEIGHT) of SOURCEREGION))
(DESTSCALE (if (NULL DESTSTREAM)
then 1
else (DSPSCALE NIL DESTSTREAM)))
(SCRATCHREGION (CONSTANT (create REGION]
(REPLACE.REGION SCRATCHREGION DESTLEFT DESTBOTTOM (TIMES DESTSCALE SWIDTH)
(TIMES DESTSCALE SHEIGHT))
(RETURN (if (SUBREGIONP DESTREGION SCRATCHREGION)
then (* Region totally inside)
T
else (* Clip NEWDESTREGION)
(INTERSECTREGIONS SCRATCHREGION DESTREGION])
(CLIPPED.DRAWBETWEEN
[LAMBDA (CLIPPINGREGION FIRSTPOSITION SECONDPOSITION WIDTH OPERATION STREAM COLOR DASHING)
(* jop: "24-Feb-86 16:02")
(* *)
(CLIPPED.DRAWLINE CLIPPINGREGION (fetch (POSITION XCOORD) of FIRSTPOSITION)
(fetch (POSITION YCOORD) of FIRSTPOSITION)
(fetch (POSITION XCOORD) of SECONDPOSITION)
(fetch (POSITION YCOORD) of SECONDPOSITION)
WIDTH OPERATION STREAM COLOR DASHING])
(CLIPPED.DRAWLINE
[LAMBDA (CLIPPINGREGION X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING)
(* jop: "25-Feb-86 11:55")
(* * Clip against CLIPPINGREGION and draw in STREAM. Implements Cohen-Sutherland clipping. From Foley and Van Dam,
pg. 146)
(PROG ((CLIPLEFT (fetch LEFT of CLIPPINGREGION))
(CLIPRIGHT (fetch RIGHT of CLIPPINGREGION))
(CLIPTOP (fetch TOP of CLIPPINGREGION))
(CLIPBOTTOM (fetch BOTTOM of CLIPPINGREGION))
(OLDX2 X2)
(OLDY2 Y2)
OUTCODE1 OUTCODE2 ACCEPT DONE)
(repeatuntil DONE
do (SETQ OUTCODE1 (CLIPCODE X1 Y1 CLIPLEFT CLIPRIGHT CLIPTOP CLIPBOTTOM))
(SETQ OUTCODE2 (CLIPCODE X2 Y2 CLIPLEFT CLIPRIGHT CLIPTOP CLIPBOTTOM))
(if (EQ 0 (LOGAND OUTCODE1 OUTCODE2))
then (* Possible accept)
(if (SETQ ACCEPT (EQ 0 (LOGOR OUTCODE1 OUTCODE2)))
then (* accept)
(SETQ DONE T)
else (* Find intersections)
(if (EQ 0 OUTCODE1)
then (* Swap points so (X1 . Y1) is guaranteed to be
outside)
(LET (TEMP)
(SWAPARGS TEMP X1 X2)
(SWAPARGS TEMP Y1 Y2)
(SWAPARGS TEMP OUTCODE1 OUTCODE2)))
(if (NEQ 0 (LOGAND OUTCODE1 8))
then (* divide line at top)
[SETQ X1 (PLUS X1
(QUOTIENT
(TIMES (DIFFERENCE X2 X1)
(DIFFERENCE
CLIPTOP Y1))
(DIFFERENCE Y2 Y1]
(SETQ Y1 CLIPTOP)
elseif (NEQ 0 (LOGAND OUTCODE1 4))
then (* divide line at bottom)
[SETQ X1 (PLUS X1
(QUOTIENT
(TIMES (DIFFERENCE X2 X1)
(DIFFERENCE
CLIPBOTTOM Y1))
(DIFFERENCE Y2 Y1]
(SETQ Y1 CLIPBOTTOM)
elseif (NEQ 0 (LOGAND OUTCODE1 2))
then (* divide line at right)
[SETQ Y1 (PLUS Y1
(QUOTIENT
(TIMES (DIFFERENCE Y2 Y1)
(DIFFERENCE
CLIPRIGHT X1))
(DIFFERENCE X2 X1]
(SETQ X1 CLIPRIGHT)
else (* divide line at left)
[SETQ Y1 (PLUS Y1
(QUOTIENT (TIMES
(DIFFERENCE
Y2 Y1)
(DIFFERENCE
CLIPLEFT X1))
(DIFFERENCE X2 X1]
(SETQ X1 CLIPLEFT)))
else (* Reject)
(SETQ DONE T))) (* actually draw a line if one accepted)
(if ACCEPT
then (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING))
(* Correctly Update posistion in stream)
(MOVETO OLDX2 OLDY2 STREAM])
(CLIPPED.DRAWTO
[LAMBDA (CLIPPINGREGION X Y WIDTH OPERATION STREAM COLOR DASHING)
(* jop: "21-Feb-86 17:04")
(* *)
(CLIPPED.DRAWLINE CLIPPINGREGION (DSPXPOSITION NIL STREAM)
(DSPYPOSITION NIL STREAM)
X Y WIDTH OPERATION STREAM COLOR DASHING])
(CLIPPED.PLOTAT
[LAMBDA (CLIPPINGREGION PT GLYPH STREAM OPERATION) (* jop: "24-Feb-86 15:24")
(* *)
(PROG ((WIDTHGLYPH (BITMAPWIDTH GLYPH))
(HEIGHTGLYPH (BITMAPHEIGHT GLYPH))
NEWX NEWY)
[SETQ NEWX (DIFFERENCE (fetch XCOORD of PT)
(TIMES (DSPSCALE NIL STREAM)
(IQUOTIENT WIDTHGLYPH 2]
[SETQ NEWY (DIFFERENCE (fetch YCOORD of PT)
(TIMES (DSPSCALE NIL STREAM)
(IQUOTIENT HEIGHTGLYPH 2]
(CLIPPED.BITBLT CLIPPINGREGION GLYPH 0 0 STREAM NEWX NEWY WIDTHGLYPH HEIGHTGLYPH
(QUOTE INPUT)
OPERATION])
(CLIPPED.PRIN1
[LAMBDA (CLIPPINGREGION EXPR STREAM) (* jop: "24-Feb-86 17:23")
(* *)
(PROG ((STRINGREGION (STRINGREGION EXPR STREAM))
IREGION)
(if (SUBREGIONP CLIPPINGREGION STRINGREGION)
then (* No clipping)
(PRIN1 EXPR STREAM)
else (SETQ IREGION (INTERSECTREGIONS STRINGREGION CLIPPINGREGION))
(if (AND IREGION (IEQP (fetch (REGION HEIGHT) of IREGION)
(fetch (REGION HEIGHT) of STRINGREGION)))
then (* Some chars visible)
(bind (MINX ←(fetch (REGION LEFT) of CLIPPINGREGION))
(MAXX ←(fetch (REGION RIGHT) of CLIPPINGREGION))
(X ←(DSPXPOSITION NIL STREAM))
(Y ←(DSPYPOSITION NIL STREAM))
NEXTX CHARWIDTH for I from 1 to (NCHARS EXPR)
do (SETQ CHARWIDTH (CHARWIDTH (NTHCHARCODE EXPR I)
STREAM))
(SETQ NEXTX (IPLUS X CHARWIDTH))
(if (NOT (OR (ILESSP X MINX)
(IGREATERP NEXTX MAXX)))
then (PRIN1 (NTHCHAR EXPR I)
STREAM)
else (MOVETO NEXTX Y STREAM))
(SETQ X NEXTX])
(CLIPPED.RELDRAWTO
[LAMBDA (CLIPPINGREGION DX DY WIDTH OPERATION STREAM COLOR DASHING)
(* jop: "21-Feb-86 17:09")
(* *)
(PROG ((X (DSPXPOSITION NIL STREAM))
(Y (DSPYPOSITION NIL STREAM)))
(CLIPPED.DRAWLINE CLIPPINGREGION X Y (PLUS X DX)
(PLUS Y DY)
WIDTH OPERATION STREAM COLOR DASHING])
(CLIPPED.SOURCEREGION
[LAMBDA (SOURCEREGION CLIPPEDDESTREGION DESTLEFT DESTBOTTOM DESTSTREAM)
(* jop: "23-Feb-86 15:41")
(* * Stream NIL implies the display. Returns a clipped source region -- or NIL if gross clipped.)
(if (NULL CLIPPEDDESTREGION)
then NIL
elseif (EQ CLIPPEDDESTREGION T)
then SOURCEREGION
else (LET ((DESTSCALE (if (NULL DESTSTREAM)
then 1
else (DSPSCALE NIL DESTSTREAM)))
(CDLEFT (fetch (REGION LEFT) of CLIPPEDDESTREGION))
(CDBOTTOM (fetch (REGION BOTTOM) of CLIPPEDDESTREGION))
(CDWIDTH (fetch (REGION WIDTH) of CLIPPEDDESTREGION))
(CDHEIGHT (fetch (REGION HEIGHT) of CLIPPEDDESTREGION)))
(if (EQ DESTSCALE 1)
then (CREATEREGION (DIFFERENCE CDLEFT DESTLEFT)
(DIFFERENCE CDBOTTOM DESTBOTTOM)
CDWIDTH CDHEIGHT)
else (CREATEREGION (FIXR (QUOTIENT (DIFFERENCE CDLEFT DESTLEFT)
DESTSCALE))
(FIXR (QUOTIENT (DIFFERENCE CDBOTTOM DESTBOTTOM)
DESTSCALE))
(FIXR (QUOTIENT CDWIDTH DESTSCALE))
(FIXR (QUOTIENT CDHEIGHT DESTSCALE])
(REPLACE.REGION
[LAMBDA (REGION RLEFT RBOTTOM RWIDTH RHEIGHT) (* jop: "23-Feb-86 16:52")
(* *)
(with REGION REGION (SETQ LEFT RLEFT)
(SETQ BOTTOM RBOTTOM)
(SETQ WIDTH RWIDTH)
(SETQ HEIGHT RHEIGHT))
REGION])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS SWAPARGS MACRO ((TEMP FIRST SECOND)
(SETQ TEMP FIRST)
(SETQ FIRST SECOND)
(SETQ SECOND TEMP)))
)
(* * For unboxed floating point games)
(FILESLOAD UNBOXEDOPS)
(DECLARE: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS TWODGRAPHICS COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1564 21312 (CREATEVIEWPORT 1574 . 3360) (COMPUTETRANSFORM 3362 . 5783) (
COMPUTEWORLDREGION 5785 . 6830) (SETSTREAMSUBREGION 6832 . 7433) (SETWORLDREGION 7435 . 7813) (
STREAMREGIONTOWORLDREGION 7815 . 8336) (STREAMTOWORLD 8338 . 8993) (TWODGRAPHICS.BITBLT 8995 . 12483)
(TWODGRAPHICS.CLOSEFN 12485 . 12995) (TWODGRAPHICS.DRAWBETWEEN 12997 . 13342) (TWODGRAPHICS.DRAWLINE
13344 . 14010) (TWODGRAPHICS.DRAWTO 14012 . 14487) (TWODGRAPHICS.DRAWTOPT 14489 . 14770) (
TWODGRAPHICS.DSPFILL 14772 . 15190) (TWODGRAPHICS.DSPRESET 15192 . 15789) (TWODGRAPHICS.INIT 15791 .
16379) (TWODGRAPHICS.MOVETO 16381 . 16656) (TWODGRAPHICS.MOVETOPT 16658 . 16909) (TWODGRAPHICS.PLOTAT
16911 . 17313) (TWODGRAPHICS.RELDRAWTO 17315 . 17883) (TWODGRAPHICS.RELDRAWTOPT 17885 . 18173) (
TWODGRAPHICS.RELMOVETO 18175 . 18516) (TWODGRAPHICS.RELMOVETOPT 18518 . 18783) (TWODGRAPHICS.RESHAPEFN
18785 . 20156) (WORLDREGIONTOSTREAMREGION 20158 . 20679) (WORLDTOSTREAM 20681 . 21310)) (23968 37603
(CLIPCODE 23978 . 24754) (CLIPPED.BITBLT 24756 . 28247) (CLIPPED.DESTREGION 28249 . 29482) (
CLIPPED.DRAWBETWEEN 29484 . 30030) (CLIPPED.DRAWLINE 30032 . 33197) (CLIPPED.DRAWTO 33199 . 33551) (
CLIPPED.PLOTAT 33553 . 34236) (CLIPPED.PRIN1 34238 . 35560) (CLIPPED.RELDRAWTO 35562 . 35984) (
CLIPPED.SOURCEREGION 35986 . 37310) (REPLACE.REGION 37312 . 37601)))))
STOP