(FILECREATED "24-Feb-86 23:52:13" {QV}<PEDERSEN>LISP>CLIPPER.;4 14601
changes to: (VARS CLIPPERCOMS)
(FNS CLIPPED.DRAWLINE)
previous date: "24-Feb-86 18:25:00" {QV}<PEDERSEN>LISP>CLIPPER.;3)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CLIPPERCOMS)
(RPAQQ CLIPPERCOMS ((FNS CLIPCODE CLIPPED.BITBLT CLIPPED.DESTREGION CLIPPED.DRAWBETWEEN
CLIPPED.DRAWLINE CLIPPED.DRAWTO CLIPPED.PLOTAT CLIPPED.PRIN1
CLIPPED.RELDRAWTO CLIPPED.SOURCEREGION REPLACE.REGION)
(MACROS SWAPARGS)
(DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T))))
(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: "24-Feb-86 22:33")
(* * 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)))
)
(DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS CLIPPER COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (641 14276 (CLIPCODE 651 . 1427) (CLIPPED.BITBLT 1429 . 4920) (CLIPPED.DESTREGION 4922
. 6155) (CLIPPED.DRAWBETWEEN 6157 . 6703) (CLIPPED.DRAWLINE 6705 . 9870) (CLIPPED.DRAWTO 9872 . 10224
) (CLIPPED.PLOTAT 10226 . 10909) (CLIPPED.PRIN1 10911 . 12233) (CLIPPED.RELDRAWTO 12235 . 12657) (
CLIPPED.SOURCEREGION 12659 . 13983) (REPLACE.REGION 13985 . 14274)))))
STOP