(FILECREATED "23-Jan-85 19:20:28" {ERIS}<LISPCORE>SOURCES>HLDISPLAY.;9 98637
changes to: (FNS SHRINKBITMAP)
previous date: "19-Dec-84 15:39:46" {ERIS}<LISPCORE>SOURCES>HLDISPLAY.;8)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT HLDISPLAYCOMS)
(RPAQQ HLDISPLAYCOMS ((* GRID functions)
(FNS GRID GRIDXCOORD GRIDYCOORD LEFTOFGRIDCOORD BOTTOMOFGRIDCOORD EDITBMSCROLLFN SHADEGRIDBOX)
(* Low level compatibility and extensions)
(FNS INSIDE?)
[COMS (* Mouse selection code)
(FNS MOUSESTATE-EXPR MOUSESTATE-NAME)
(PROP ARGNAMES MOUSESTATE LASTMOUSESTATE UNTILMOUSESTATE KEYSETSTATE LASTKEYSETSTATE)
(EXPORT (DECLARE: DOCOPY (MACROS MOUSESTATE LASTMOUSESTATE UNTILMOUSESTATE KEYSETSTATE
LASTKEYSETSTATE))
(DECLARE: DONTCOPY (MACROS WITHIN))
(ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS]
(* High Level Display utilities)
(FNS DECODEBUTTONS)
(FNS PTDIFFERENCE PTPLUS)
(COMS (* User interaction for regions, etc)
(FNS GETPOSITION GETBOXPOSITION DSPYSCREENTOWINDOW DSPXSCREENTOWINDOW GETREGION
\GETREGION.PACKPTS \GETREGION.CHECKBASEPT \GETREGION.CHECKOPPT
\GETREGIONTRACKWITHBOX \UPDATEXYANDBOX GETBOXREGION \TRACKWITHBOX MOVEBOX
DRAWGRAYBOX BLTHLINE BLTVLINE SETCORNER)
(FNS MOUSECONFIRM)
(CURSORS MOUSECONFIRMCURSOR))
(FNS NEAREST/PT/ON/GRID PTON10GRID NEAREST/MULTIPLE)
(EXPORT (MACROS IABS))
(UGLYVARS DASHEDSHADE)
(CURSORS CROSSHAIRS EXPANDINGBOX FORCEPS BOXCURSOR LOCKEDSPOT OLDEXPANDINGBOX LowerLeftCursor
UpperRightCursor UpperLeftCursor LowerRightCursor)
(FNS \SW2BM COMPOSEREGS TRANSLATEREG)
(COMS (* Bitmap and shade editors)
(FNS EDITBM EDITBMCLOSEFN TILEAREA EDITBMBUTTONFN \EDITBM/PUTUP/DISPLAY \EDITBMHOWMUCH
EDITBMRESHAPEFN EDITBMREPAINTFN UPDATE/SHADE/DISPLAY
UPDATE/BM/DISPLAY/SELECTED/REGION SHOWBUTTON RESETGRID \READBMDIMENSIONS EDITSHADE
\BITMAPFROMTEXTURE EDITSHADEREPAINTFN GRAYBOXAREA \SHADEBITS READHOTSPOT WBOX
\CLEARBM)
(DECLARE: DONTCOPY (RECORDS BUTTON)
(MACROS BITMASK UPDATE/BM/DISPLAY))
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (DARKBITSHADE 23130)
(NORMALGRIDSQUARE 16)
(NOTINUSEGRAY 42405)
(EDITBMMENU)
(EDITBMWINDOWMENU)
(GRIDSIZEMENU)
(CLICKWAITTIME 250)))
(DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DARKBITSHADE NORMALGRIDSQUARE
NOTINUSEGRAY EDITBMMENU CLICKWAITTIME))
(CONSTANTS (GRIDTHICKNESS 2)
(MINGRIDSQUARE 8)
(MAXGRIDWIDTH 199)
(MAXGRIDHEIGHT 175)
(BMWINDOWSHADE 33410)))
(FNS EXPANDBITMAP SHRINKBITMAP \FAST4BIT)
(UGLYVARS \4BITEXPANSIONTABLE)))
(* GRID functions)
(DEFINEQ
(GRID
[LAMBDA (GRIDSPEC WIDTH HEIGHT BORDER DS GRIDSHADE) (* rrb "21-MAR-83 18:27")
(* draws a grid)
(PROG ((X0 (fetch (REGION LEFT) of GRIDSPEC))
(Y0 (fetch (REGION BOTTOM) of GRIDSPEC))
(SQWIDTH (fetch (REGION WIDTH) of GRIDSPEC))
(SQHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC))
(GRIDSHADE (COND
((TEXTUREP GRIDSHADE))
(T BLACKSHADE)))
LINELENGTH TWICEBORDER)
(COND
((OR (ZEROP BORDER)
(NULL BORDER)) (* don't draw anything.)
(RETURN))
((NUMBERP BORDER)
(SETQ TWICEBORDER (ITIMES BORDER 2))
(PROGN
(* draw vertical lines use BITBLT so that we don't have to correct for the width of the line since line drawing
will put the coordinate in the middle.)
(BITBLT NIL NIL NIL DS X0 Y0 BORDER (SETQ LINELENGTH (ITIMES HEIGHT SQHEIGHT))
(QUOTE TEXTURE)
(QUOTE REPLACE)
GRIDSHADE)
(for X from (IDIFFERENCE (IPLUS X0 SQWIDTH)
BORDER)
to (IDIFFERENCE (IPLUS X0 (ITIMES (SUB1 WIDTH)
SQWIDTH))
BORDER)
by SQWIDTH do (BITBLT NIL NIL NIL DS X Y0 TWICEBORDER LINELENGTH
(QUOTE TEXTURE)
(QUOTE REPLACE)
GRIDSHADE))
(BITBLT NIL NIL NIL DS (IDIFFERENCE (IPLUS X0 (ITIMES WIDTH SQWIDTH))
BORDER)
Y0 BORDER LINELENGTH (QUOTE TEXTURE)
(QUOTE REPLACE)
GRIDSHADE))
(PROGN (* draw horizontal lines)
(BITBLT NIL NIL NIL DS X0 Y0 (SETQ LINELENGTH (ITIMES WIDTH SQWIDTH))
BORDER
(QUOTE TEXTURE)
(QUOTE REPLACE)
GRIDSHADE)
(for Y from (IDIFFERENCE (IPLUS Y0 SQHEIGHT)
BORDER)
to (IDIFFERENCE (IPLUS Y0 (ITIMES (SUB1 HEIGHT)
SQHEIGHT))
BORDER)
by SQHEIGHT do (BITBLT NIL NIL NIL DS X0 Y LINELENGTH TWICEBORDER
(QUOTE TEXTURE)
(QUOTE REPLACE)
GRIDSHADE))
(BITBLT NIL NIL NIL DS X0 (IDIFFERENCE (IPLUS Y0 (ITIMES HEIGHT SQHEIGHT))
BORDER)
LINELENGTH BORDER (QUOTE TEXTURE)
(QUOTE REPLACE)
GRIDSHADE)))
[(EQ BORDER (QUOTE POINT)) (* put a point in the lower left corner of each box)
(for X from X0 to (IPLUS X0 (ITIMES WIDTH SQWIDTH)) by SQWIDTH
do (for Y from Y0 to (IPLUS Y0 (ITIMES HEIGHT SQHEIGHT)) by SQHEIGHT
do (BITMAPBIT DS X Y 1]
(T (\ILLEGAL.ARG BORDER])
(GRIDXCOORD
[LAMBDA (XPOS GRIDSPEC) (* rrb "21-MAR-83 13:04")
(PROG [(GX (IDIFFERENCE XPOS (fetch (REGION LEFT) of GRIDSPEC]
(* because (IQUOTIENT -1 2) is 0 instead of -1 like we
would like)
(RETURN (COND
((IGEQ GX 0)
(IQUOTIENT GX (fetch (REGION WIDTH) of GRIDSPEC)))
(T (SUB1 (IQUOTIENT GX (fetch (REGION WIDTH) of GRIDSPEC])
(GRIDYCOORD
[LAMBDA (YPOS GRIDSPEC) (* rrb "21-MAR-83 13:07")
(PROG [(GY (IDIFFERENCE YPOS (fetch (REGION BOTTOM) of GRIDSPEC]
(* because (IQUOTIENT -1 2) is 0 instead of -1 like we
would like)
(RETURN (COND
((IGEQ GY 0)
(IQUOTIENT GY (fetch (REGION HEIGHT) of GRIDSPEC)))
(T (SUB1 (IQUOTIENT GY (fetch (REGION HEIGHT) of GRIDSPEC])
(LEFTOFGRIDCOORD
[LAMBDA (GRIDX GRIDSPEC) (* rrb "19-MAR-82 09:20")
(* returns the Left position of a grid location.)
(IPLUS (fetch (REGION LEFT) of GRIDSPEC)
(ITIMES (fetch (REGION WIDTH) of GRIDSPEC)
GRIDX])
(BOTTOMOFGRIDCOORD
[LAMBDA (GRIDY GRIDSPEC) (* rrb "19-MAR-82 09:38")
(IPLUS (fetch (REGION BOTTOM) of GRIDSPEC)
(ITIMES (fetch (REGION HEIGHT) of GRIDSPEC)
GRIDY])
(EDITBMSCROLLFN
[LAMBDA (W DX DY) (* rrb "20-JUN-82 16:56")
(* Do scrolling for the bitmap editor.)
(PROG (GRIDSPEC REG WHEIGHT WWIDTH (DXGRID 0)
(DYGRID 0)
GILEFT GIBOTTOM GIHEIGHT GWIDTH GHEIGHT GRIDINTERIOR EBMXLIMIT EBMYLIMIT
EBMXOFFSET EBMYOFFSET BM BITSWIDE BITSHIGH DXOFFSET DYOFFSET)
(SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC)))
(SETQ REG (WINDOWPROP W (QUOTE REGION)))
(SETQ WHEIGHT (WINDOWPROP W (QUOTE HEIGHT)))
(SETQ WWIDTH (WINDOWPROP W (QUOTE WIDTH)))
(SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR)))
(SETQ EBMXOFFSET (WINDOWPROP W (QUOTE XOFFSET)))
(SETQ EBMYOFFSET (WINDOWPROP W (QUOTE YOFFSET)))
(SETQ BM (WINDOWPROP W (QUOTE BM)))
(SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE)))
(SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH)))
(SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET)))
(SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET)))
(SETQ EBMXLIMIT (IPLUS EBMXOFFSET BITSWIDE))
(SETQ EBMYLIMIT (IPLUS EBMYOFFSET BITSHIGH))
(COND
(GRIDSPEC (SETQ GILEFT (fetch (REGION LEFT) of GRIDINTERIOR))
(SETQ GIBOTTOM (fetch (REGION BOTTOM) of GRIDINTERIOR))
(SETQ GIHEIGHT (fetch (REGION HEIGHT) of GRIDINTERIOR))
(SETQ GWIDTH (fetch (REGION WIDTH) of GRIDSPEC))
(SETQ GHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC))
(* Make a horizontal adjustment)
(COND
((FLOATP DX)
(printout PROMPTWINDOW "Thumbing isn't implemented yet." T))
((ILESSP DX 0) (* moving to the left.)
(* determine how many grid points to move.)
(SETQ DXGRID (IMIN (GRIDXCOORD (IMINUS DX)
GRIDSPEC)
(IDIFFERENCE (fetch (BITMAP BITMAPWIDTH) of BM)
EBMXLIMIT)))
(COND
((NOT (IGREATERP DXGRID 0)) (* right edge is at the right margin)
(RETURN)))
(WINDOWPROP W (QUOTE XOFFSET)
(SETQ EBMXOFFSET (IPLUS EBMXOFFSET DXGRID)))
(* move image to the left.)
(BITBLT W (IPLUS GILEFT (ITIMES DXGRID GWIDTH))
GIBOTTOM W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
(QUOTE REPLACE)
NIL GRIDINTERIOR) (* clear the newly exposed area.)
(BITBLT NIL 0 0 W (IPLUS GILEFT (ITIMES (IDIFFERENCE BITSWIDE DXGRID)
GWIDTH))
GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE GRIDINTERIOR)
(RESETGRID BM GRIDSPEC DXGRID BITSHIGH (IDIFFERENCE BITSWIDE DXGRID)
0 W))
((ILESSP 0 DX) (* determine how many grid point to the left to move.)
(SETQ DXGRID (IMIN EBMXOFFSET (GRIDXCOORD DX GRIDSPEC)))
(COND
((NOT (IGREATERP DXGRID 0)) (* left edge is at the left margin)
(RETURN)))
(WINDOWPROP W (QUOTE XOFFSET)
(SETQ EBMXOFFSET (IDIFFERENCE EBMXOFFSET DXGRID)))
(* move image to the right.)
(BITBLT W GILEFT GIBOTTOM W (IPLUS GILEFT (ITIMES DXGRID GWIDTH))
GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
(QUOTE REPLACE)
NIL GRIDINTERIOR) (* clear the newly exposed area.)
(BITBLT NIL 0 0 W GILEFT GIBOTTOM (ITIMES DXGRID GWIDTH)
GIHEIGHT
(QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(RESETGRID BM GRIDSPEC DXGRID BITSHIGH 0 0 W)))
(* Make a vertical adjustment)
(COND
((FLOATP DY)
(printout PROMPTWINDOW "Thumbing isn't implemented yet." T))
((ILESSP DY 0) (* determine how many squares to move down.)
(SETQ DYGRID (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of BM)
EBMYLIMIT)
(GRIDYCOORD (IMIN GIHEIGHT (IPLUS WHEIGHT DY))
GRIDSPEC)))
(COND
((NOT (IGREATERP DYGRID 0)) (* top edge is at the top margin)
(RETURN)))
(WINDOWPROP W (QUOTE YOFFSET)
(SETQ EBMYOFFSET (IPLUS EBMYOFFSET DYGRID)))
(BITBLT W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT))
W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
(QUOTE REPLACE)
NIL GRIDINTERIOR)
(BITBLT NIL 0 0 W GILEFT (IPLUS GIBOTTOM (ITIMES (IDIFFERENCE BITSHIGH
DYGRID)
GHEIGHT))
SCREENWIDTH SCREENHEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE GRIDINTERIOR)
(RESETGRID BM GRIDSPEC BITSWIDE DYGRID 0 (IDIFFERENCE BITSHIGH DYGRID)
W))
((ILESSP 0 DY) (* moving up; determine how may grid squares to move.)
(SETQ DYGRID (IMIN EBMYOFFSET (GRIDYCOORD (IMIN GIHEIGHT (IDIFFERENCE
WHEIGHT DY))
GRIDSPEC)))
(COND
((NOT (IGREATERP DYGRID 0)) (* bottom edge is at the bottom margin)
(RETURN)))
(WINDOWPROP W (QUOTE YOFFSET)
(SETQ EBMYOFFSET (IDIFFERENCE EBMYOFFSET DYGRID)))
(BITBLT W GILEFT GIBOTTOM W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT))
SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
(QUOTE REPLACE)
NIL GRIDINTERIOR)
(BITBLT NIL 0 0 W GILEFT GIBOTTOM (fetch (REGION WIDTH) of GRIDINTERIOR)
(ITIMES DYGRID GHEIGHT)
(QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(RESETGRID BM GRIDSPEC BITSWIDE DYGRID 0 0 W)))
(GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT)
W)
[COND
([OR (ILESSP EBMXOFFSET DXOFFSET)
(ILESSP EBMYOFFSET DYOFFSET)
[IGREATERP (IPLUS EBMXOFFSET BITSWIDE)
(IPLUS DXOFFSET (WINDOWPROP W (QUOTE BMDISPLAYWIDTH]
(IGREATERP (IPLUS EBMYOFFSET BITSHIGH)
(IPLUS DYOFFSET (WINDOWPROP W (QUOTE BMDISPLAYHEIGHT]
(* Adjust the display region left lower corner so the
selected region is near the center.)
[WINDOWPROP W (QUOTE DXOFFSET)
(SETQ DXOFFSET (IMAX 0
(IMIN (IDIFFERENCE (fetch (BITMAP
BITMAPWIDTH)
of BM)
(WINDOWPROP
W
(QUOTE BMDISPLAYWIDTH)
))
(IDIFFERENCE
(IPLUS EBMXOFFSET
(LRSH BITSWIDE 1))
(LRSH (WINDOWPROP W (QUOTE
BMDISPLAYWIDTH))
1]
(WINDOWPROP W (QUOTE DYOFFSET)
(SETQ DYOFFSET (IMAX 0
(IMIN (IDIFFERENCE (fetch (BITMAP
BITMAPHEIGHT)
of BM)
(WINDOWPROP
W
(QUOTE
BMDISPLAYHEIGHT)))
(IDIFFERENCE
(IPLUS EBMYOFFSET
(LRSH BITSHIGH 1))
(LRSH (WINDOWPROP W (QUOTE
BMDISPLAYHEIGHT))
1]
(UPDATE/BM/DISPLAY BM W])
(SHADEGRIDBOX
[LAMBDA (X Y SHADE OPERATION GRIDSPEC GRIDBORDER DS) (* rrb "13-JUN-82 16:48")
(* shades the interior of a grid box.)
(PROG ((BORDER (OR (FIXP GRIDBORDER)
0)))
(BITBLT NIL NIL NIL DS (IPLUS (LEFTOFGRIDCOORD X GRIDSPEC)
BORDER)
(IPLUS (BOTTOMOFGRIDCOORD Y GRIDSPEC)
BORDER)
(IDIFFERENCE (fetch (REGION WIDTH) of GRIDSPEC)
(ITIMES BORDER 2))
(IDIFFERENCE (fetch (REGION HEIGHT) of GRIDSPEC)
(ITIMES BORDER 2))
(QUOTE TEXTURE)
OPERATION SHADE) (* if this is POINT grid, set lower left corner.)
(COND
((EQ GRIDBORDER (QUOTE POINT))
(BITMAPBIT DS (LEFTOFGRIDCOORD X GRIDSPEC)
(BOTTOMOFGRIDCOORD Y GRIDSPEC)
1])
)
(* Low level compatibility and extensions)
(DEFINEQ
(INSIDE?
[LAMBDA (BOX X Y) (* rrb "19-MAR-82 09:32")
(AND (WITHIN (OR X LASTMOUSEX)
(fetch (REGION LEFT) of BOX)
(fetch (REGION WIDTH) of BOX))
(WITHIN (OR Y LASTMOUSEY)
(fetch (REGION BOTTOM) of BOX)
(fetch (REGION HEIGHT) of BOX])
)
(* Mouse selection code)
(DEFINEQ
(MOUSESTATE-EXPR
[LAMBDA (EXPR MOUSEONLYFLG) (* rrb " 5-Apr-84 17:05")
(* if MOUSEONLYFLG is non-NIL, the testing should be done only on the mouse buttons. MOUSEONLYFLG will be passed
in as T by MOUSESTATE but will get reset if any of the names are not mouse button names.)
(PROG (NAMEMASK (MOUSEBUTTONMASK 7))
(RETURN (COND
[(NLISTP EXPR)
(COND
[(EQ EXPR (QUOTE UP))
(LIST (QUOTE ZEROP)
(COND
(MOUSEONLYFLG (LIST (QUOTE LOGAND)
MOUSEBUTTONMASK
(QUOTE LASTMOUSEBUTTONS)))
(T (QUOTE LASTMOUSEBUTTONS]
(T
(* MOUSEONLYFLG can be ignored on this branch because it is generating code for the case where the user is listing
the button names and if he includes keyset names you want to include them anyway.)
(LIST (QUOTE NEQ)
(LIST (QUOTE LOGAND)
(QUOTE LASTMOUSEBUTTONS)
(MOUSESTATE-NAME EXPR))
0]
((EQ (CAR EXPR)
(QUOTE ONLY))
(COND
((SETQ NAMEMASK (MOUSESTATE-NAME (CADR EXPR)
MOUSEONLYFLG)))
((SETQ NAMEMASK (MOUSESTATE-NAME (CADR EXPR)
NIL))
(* non-mouse buttons were named, use all keys.)
(SETQ MOUSEONLYFLG NIL)))
(LIST (QUOTE EQ)
(COND
(MOUSEONLYFLG (LIST (QUOTE LOGAND)
MOUSEBUTTONMASK
(QUOTE LASTMOUSEBUTTONS)))
(T (QUOTE LASTMOUSEBUTTONS)))
NAMEMASK))
([EVERY EXPR (FUNCTION (LAMBDA (X)
(AND (ATOM X)
(NEQ X (QUOTE UP] (* Cant use LOGx trick for UP as it is a disjunct not a
key selector)
(SELECTQ (CAR EXPR)
[OR (LIST (QUOTE NEQ)
0
(LIST (QUOTE LOGAND)
(QUOTE LASTMOUSEBUTTONS)
(CONS (QUOTE LOGOR)
(MAPCAR (CDR EXPR)
(FUNCTION MOUSESTATE-NAME]
[AND (LIST (QUOTE EQ)
(CONS (QUOTE LOGOR)
(MAPCAR (CDR EXPR)
(FUNCTION MOUSESTATE-NAME)))
(LIST (QUOTE LOGAND)
(QUOTE LASTMOUSEBUTTONS)
(CONS (QUOTE LOGOR)
(MAPCAR (CDR EXPR)
(FUNCTION MOUSESTATE-NAME]
[NOT (COND
((CDDR EXPR)
(SHOULDNT)))
(LIST (QUOTE ZEROP)
(LIST (QUOTE LOGAND)
(QUOTE LASTMOUSEBUTTONS)
(MOUSESTATE-NAME (CADR EXPR]
(HELP (CAR EXPR)
" unrecognized mouse key operator")))
(T (CONS (CAR EXPR)
(MAPCAR (CDR EXPR)
(FUNCTION (LAMBDA (OPT)
(MOUSESTATE-EXPR OPT MOUSEONLYFLG])
(MOUSESTATE-NAME
[LAMBDA (KEYNAME MOUSEONLYFLG) (* rrb "13-JUN-82 11:17")
(* return the numeric code for a mouse or keyset key.)
(SELECTQ KEYNAME
((LEFT RED)
4)
((RIGHT BLUE)
2)
((YELLOW MIDDLE)
1)
(COND
((NOT MOUSEONLYFLG) (* if wants mouse only, return NIL)
(SELECTQ KEYNAME
(LEFTKEY 128)
(LEFTMIDDLEKEY 64)
(MIDDLEKEY 32)
(RIGHTMIDDLEKEY 16)
(RIGHTKEY 8)
(HELP KEYNAME " is not a recognized key name."])
)
(PUTPROPS MOUSESTATE ARGNAMES (BUTTONFORM))
(PUTPROPS LASTMOUSESTATE ARGNAMES (BUTTONFORM))
(PUTPROPS UNTILMOUSESTATE ARGNAMES (BUTTONFORM INTERVAL))
(PUTPROPS KEYSETSTATE ARGNAMES (BUTTONFORM))
(PUTPROPS LASTKEYSETSTATE ARGNAMES (BUTTONFORM))
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS MOUSESTATE MACRO (ARGS (LIST (QUOTE PROGN)
(QUOTE (GETMOUSESTATE))
(MOUSESTATE-EXPR (CAR ARGS)
T))))
(PUTPROPS LASTMOUSESTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS)
T)))
(PUTPROPS UNTILMOUSESTATE MACRO [ARGS (COND
[(AND (CDR ARGS)
(CADR ARGS)
(NEQ (CADR ARGS)
T)) (* time argument is given and is not T or NIL;
compile in time keeping loop.)
(LIST (QUOTE PROG)
[LIST (LIST (QUOTE TIMEOUT)
(LIST (QUOTE IPLUS)
(QUOTE (CLOCK 0))
(LIST (QUOTE OR)
(LIST (QUOTE NUMBERP)
(CADR ARGS))
100)))
(QUOTE (NOWTIME (CLOCK 0]
(QUOTE LP)
[LIST (QUOTE COND)
(LIST (CONS (QUOTE MOUSESTATE)
(LIST (CAR ARGS)
T))
(QUOTE (RETURN T]
[QUOTE (COND ((IGREATERP (CLOCK0 NOWTIME)
TIMEOUT)
(RETURN NIL))
(T (\BACKGROUND]
(QUOTE (GO LP]
(T (LIST (QUOTE PROG)
NIL
(QUOTE LP)
[LIST (QUOTE COND)
(LIST (CONS (QUOTE MOUSESTATE)
(LIST (CAR ARGS)
T))
(QUOTE (RETURN T]
(QUOTE (\BACKGROUND))
(QUOTE (GO LP])
(PUTPROPS KEYSETSTATE MACRO [ARGS (LIST (QUOTE PROGN)
(QUOTE (GETMOUSESTATE))
(MOUSESTATE-EXPR (CAR ARGS])
(PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS))))
)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS WITHIN MACRO [(A B C)
(AND (IGEQ A B)
(ILESSP A (IPLUS B C])
)
)
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS)
(* END EXPORTED DEFINITIONS)
(* High Level Display utilities)
(DEFINEQ
(DECODEBUTTONS
[LAMBDA (BUTTONSTATE)
(DECLARE (GLOBALVARS LASTMOUSEBUTTONS)) (* rrb " 9-JAN-82 14:20")
(* return a list of the buttons and keys that are down
from a button state.)
(OR (SMALLP BUTTONSTATE)
(SETQ BUTTONSTATE LASTMOUSEBUTTONS))
(NCONC (AND (NEQ 0 (LOGAND BUTTONSTATE 4))
(CONS (QUOTE LEFT)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 2))
(CONS (QUOTE RIGHT)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 1))
(CONS (QUOTE MIDDLE)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 128))
(CONS (QUOTE LEFTKEY)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 64))
(CONS (QUOTE LEFTMIDDLEKEY)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 32))
(CONS (QUOTE MIDDLEKEY)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 16))
(CONS (QUOTE RIGHTMIDDLEKEY)))
(AND (NEQ 0 (LOGAND BUTTONSTATE 8))
(CONS (QUOTE RIGHTKEY])
)
(DEFINEQ
(PTDIFFERENCE
[LAMBDA (PT1 PT2) (* rrb "24-JAN-83 14:54")
(* adds two positions)
(create POSITION
XCOORD ←(DIFFERENCE (fetch (POSITION XCOORD) of PT1)
(fetch (POSITION XCOORD) of PT2))
YCOORD ←(DIFFERENCE (fetch (POSITION YCOORD) of PT1)
(fetch (POSITION YCOORD) of PT2])
(PTPLUS
[LAMBDA (PT1 PT2) (* rrb "24-JAN-83 14:54")
(* adds two positions)
(create POSITION
XCOORD ←(PLUS (fetch (POSITION XCOORD) of PT1)
(fetch (POSITION XCOORD) of PT2))
YCOORD ←(PLUS (fetch (POSITION YCOORD) of PT1)
(fetch (POSITION YCOORD) of PT2])
)
(* User interaction for regions, etc)
(DEFINEQ
(GETPOSITION
[LAMBDA (WINDOW CURSOR) (* rmk: "31-AUG-83 16:22")
(* reads a point from a WINDOW if non-NIL or the screen.
Will change to cursor if given.)
(RESETFORM (CURSOR (OR CURSOR CROSSHAIRS))
(until (MOUSESTATE LEFT))
(until (MOUSESTATE (NOT LEFT)))
(COND
((NULL WINDOW)
(create POSITION
XCOORD ← LASTMOUSEX
YCOORD ← LASTMOUSEY))
((SETQ WINDOW (OR (DISPLAYSTREAMP (\OUTSTREAMARG WINDOW))
(\ILLEGAL.ARG WINDOW)))
(create POSITION
XCOORD ←(LASTMOUSEX WINDOW)
YCOORD ←(LASTMOUSEY WINDOW])
(GETBOXPOSITION
[LAMBDA (BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG) (* rrb "12-Dec-83 15:10")
(* gets a box position, returning the lower left corner. During the moving the outline of the box is displayed.
If ORGX is given, the box is originally drawn at that location and the nearest corner to the cursor is snapped to
the cursor position.)
(RESETFORM (CURSOR BOXCURSOR)
(PROG [(MOUSEDOWNFLG (MOUSESTATE (OR LEFT MIDDLE]
(COND
((AND (FIXP ORGX)
(FIXP ORGY)) (* origin given, move cursor to nearest corner.)
[COND
((IGREATERP LASTMOUSEX (IPLUS ORGX (IQUOTIENT BOXWIDTH 2)))
(SETQ ORGX (IPLUS ORGX BOXWIDTH))
(SETQ BOXWIDTH (IMINUS BOXWIDTH]
[COND
((IGREATERP LASTMOUSEY (IPLUS ORGY (IQUOTIENT BOXHEIGHT 2)))
(SETQ ORGY (IPLUS ORGY BOXHEIGHT))
(SETQ BOXHEIGHT (IMINUS BOXHEIGHT]
(\SETCURSORPOSITION ORGX ORGY))
(T (SETQ ORGX LASTMOUSEX)
(SETQ ORGY LASTMOUSEY)))
(AND PROMPTMSG (PROMPTPRINT PROMPTMSG))
TRACKLP (* track the cursor with a box ghost until the left or
middle button changes.)
(\TRACKWITHBOX)
[COND
((AND (NULL MOUSEDOWNFLG)
(LASTMOUSESTATE (NOT UP)))
(SETQ MOUSEDOWNFLG T)
(CURSOR CROSSHAIRS))
((AND MOUSEDOWNFLG (LASTMOUSESTATE UP))
(AND PROMPTMSG (CLRPROMPT))
(RETURN (COND
(WINDOW (create POSITION
XCOORD ←(DSPXSCREENTOWINDOW (IMIN ORGX
(IPLUS ORGX
BOXWIDTH))
WINDOW)
YCOORD ←(DSPYSCREENTOWINDOW (IMIN ORGY
(IPLUS ORGY
BOXHEIGHT))
WINDOW)))
(T (create POSITION
XCOORD ←(IMIN ORGX (IPLUS ORGX BOXWIDTH))
YCOORD ←(IMIN ORGY (IPLUS ORGY BOXHEIGHT]
(GO TRACKLP])
(DSPYSCREENTOWINDOW
[LAMBDA (Y DS) (* rmk: "26-AUG-83 14:08")
(* transforms an y coordinate from screen coordinates
into window coordinates)
(IDIFFERENCE Y (fetch DDYOFFSET of (\GETDISPLAYDATA DS])
(DSPXSCREENTOWINDOW
[LAMBDA (X DS) (* rmk: "26-AUG-83 14:08")
(* transforms an x coordinate from screen coordinates
into window coordinates)
(IDIFFERENCE X (fetch DDXOFFSET of (\GETDISPLAYDATA DS])
(GETREGION
[LAMBDA (MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG)
(* rrb " 3-Jul-84 16:38")
(* accepts region from the user.)
(RESETFORM (CURSOR EXPANDINGBOX)
(PROG [BASEX BASEY OPPX OPPY OLDMOUSEX OLDMOUSEY INITLEFT INITRIGHT INITBOTTOM INITTOP
(BASEPT (create POSITION))
(OPPT (create POSITION))
NEWMOUSEX NEWMOUSEY DOWNFLG BEGCLOCK (NOTTIMEDOUT T)
(MINWIDTH (COND
((FIXP MINWIDTH))
(T 0)))
(MINHEIGHT (COND
((FIXP MINHEIGHT))
(T 0)))
(NEWREGFNS (COND
((LISTP NEWREGIONFN)
NEWREGIONFN)
(NEWREGIONFN (LIST NEWREGIONFN))
(T NIL]
(GETMOUSESTATE) (* set up the initial box to prompt with.)
(* start with the cursor in the lower right corner of
the ghost box.)
(SETQ OPPX LASTMOUSEX)
(SETQ OPPY LASTMOUSEY)
[COND
((ILESSP (SETQ BASEX (IDIFFERENCE OPPX MINWIDTH))
0)
(* arrange things so that the whole box if possible is on the screen. If this is not possible, the lower right
corner is on the screen.)
(SETQ OPPX (SUB1 (IMIN MINWIDTH SCREENWIDTH)))
(SETQ BASEX (IDIFFERENCE OPPX MINWIDTH]
[COND
((IGEQ (SETQ BASEY (IPLUS OPPY MINHEIGHT))
SCREENHEIGHT)
(* if the top corner would be off the screen, move the bottom corner as low as necessary but limited to the bottom
of the screen.)
(SETQ OPPY (IMAX 0 (IDIFFERENCE SCREENHEIGHT MINHEIGHT)))
(SETQ BASEY (IPLUS OPPY MINHEIGHT]
(\SETCURSORPOSITION OPPX OPPY) (* wait for the user to put down the first corner.)
(\GETREGIONTRACKWITHBOX)
[COND
((AND INITREGION (LASTMOUSESTATE MIDDLE))
(* switch the nearest corner of INITREGION to the cursor
and track it.)
(* Pull from closest corner, ie.
set BASEX,Y to be opposite corner)
(SETQ BASEX (COND
((ILESSP (SETQ OPPX LASTMOUSEX)
(IQUOTIENT [IPLUS (SETQ INITLEFT (fetch (REGION LEFT)
of INITREGION))
(SETQ INITRIGHT (IPLUS INITLEFT
(fetch (REGION WIDTH)
of INITREGION]
2)) (* pointing at left half of box, so make origin be in
right)
INITRIGHT)
(T (* pointing at right half of box,)
INITLEFT)))
(SETQ BASEY (COND
((ILESSP (SETQ OPPY LASTMOUSEY)
(IQUOTIENT [IPLUS (SETQ INITBOTTOM (fetch (REGION BOTTOM)
of INITREGION))
(SETQ INITTOP (IPLUS INITBOTTOM
(fetch (REGION HEIGHT)
of INITREGION]
2))
INITTOP)
(T INITBOTTOM] (* copy from variable into position for the constraint
checks.)
(\GETREGION.PACKPTS)
(\GETREGION.CHECKOPPT MINWIDTH MINHEIGHT NEWREGFNS BASEPT OPPT)
(SETQ OPPX (fetch (POSITION XCOORD) of OPPT))
(SETQ OPPY (fetch (POSITION YCOORD) of OPPT))
(* Now draw the initial box)
(DRAWGRAYBOX BASEX BASEY OPPX OPPY)
(\SETCURSORPOSITION OPPX OPPY)
(SETCORNER BASEX BASEY OPPX OPPY)
(SETQ BEGCLOCK (CLOCK 0))
(COND
[[ERSETQ (until (PROGN (GETMOUSESTATE)
(COND
[NOTTIMEDOUT
(* wait to see if user was clicking to mark a corner)
(COND
((\CLOCKGREATERP BEGCLOCK
CLICKWAITTIME)
(SETQ NOTTIMEDOUT NIL]
(DOWNFLG (LASTMOUSESTATE UP))
((LASTMOUSESTATE (NOT UP))
(* mouse button when down, continue tracking until it
goes up.)
(SETQ DOWNFLG T)
NIL)))
do (COND
((LASTMOUSESTATE (AND RIGHT (OR LEFT MIDDLE)))
(CURSOR FORCEPS)
(until (MOUSESTATE (NOT RIGHT)))
(* Switch to nearest corner)
[COND
((IGEQ (IABS (IDIFFERENCE LASTMOUSEX OPPX))
(IABS (IDIFFERENCE LASTMOUSEX BASEX)))
(SETQ BASEX (PROG1 OPPX (SETQ OPPX BASEX]
[COND
((IGEQ (IABS (IDIFFERENCE LASTMOUSEY OPPY))
(IABS (IDIFFERENCE LASTMOUSEY BASEY)))
(SETQ BASEY (PROG1 OPPY (SETQ OPPY BASEY]
(\GETREGION.PACKPTS)
(\GETREGION.CHECKBASEPT NEWREGFNS BASEPT)
(\GETREGION.CHECKOPPT MINWIDTH MINHEIGHT NEWREGFNS BASEPT
OPPT)
(SETCORNER BASEX BASEY OPPX OPPY)
(\UPDATEXYANDBOX T)
(\SETCURSORPOSITION OPPX OPPY))
((OR (NEQ LASTMOUSEX OLDMOUSEX)
(NEQ LASTMOUSEY OLDMOUSEY))
(* the cursor has moved, check user constraints.)
(replace (POSITION XCOORD) of OPPT with (SETQ OLDMOUSEX
LASTMOUSEX))
(replace (POSITION YCOORD) of OPPT with (SETQ OLDMOUSEY
LASTMOUSEY))
(\GETREGION.CHECKOPPT MINWIDTH MINHEIGHT NEWREGFNS BASEPT
OPPT)
(\UPDATEXYANDBOX NIL]
(* erase box image.)
(DRAWGRAYBOX BASEX BASEY OPPX OPPY)
(RETURN (create REGION
LEFT ←(IMIN BASEX OPPX)
BOTTOM ←(IMIN BASEY OPPY)
WIDTH ←(IABS (IDIFFERENCE OPPX BASEX))
HEIGHT ←(IABS (IDIFFERENCE BASEY OPPY]
(T (* ↑E take down box.)
(DRAWGRAYBOX BASEX BASEY OPPX OPPY)
(ERROR!])
(\GETREGION.PACKPTS
[LAMBDA NIL (* rrb "12-Dec-83 18:01")
(* copy from variable into position for the constraint
checks.)
(replace (POSITION XCOORD) of BASEPT with BASEX)
(replace (POSITION YCOORD) of BASEPT with BASEY)
(replace (POSITION XCOORD) of OPPT with OPPX)
(replace (POSITION YCOORD) of OPPT with OPPY])
(\GETREGION.CHECKBASEPT
[LAMBDA (NEWREGFNS BASEPT) (* rrb "12-Dec-83 16:13")
(* calls by GETREGION to check the constraints imposed
on the base point by the user functions.)
(* if the new region fns is a list, apply them in
order.)
(bind USERPT for FN in NEWREGFNS
do (* call user fn on base pt)
(* copying the user return point is time cnsuming but
necessary to isolate the system from user code.)
(SETQ USERPT (APPLY* FN BASEPT NIL NEWREGIONFNARG))
(COND
((NOT (POSITIONP USERPT))
(ERROR "non-POSITION returned by NEWREGIONFN" USERPT))
(T (replace (POSITION XCOORD) of BASEPT with (fetch XCOORD of USERPT))
(replace (POSITION YCOORD) of BASEPT with (fetch YCOORD of USERPT])
(\GETREGION.CHECKOPPT
[LAMBDA (MINWID MINHGHT NEWREGFNS BASEPT OPPT) (* rrb "12-Dec-83 17:12")
(* called by GETREGION to check the constraints imposed by the minimum sizes and user functions.
It assumes BASEPT and OPPT are POSITIONs set to the fixed corner BASEPT and moving corner OPPT.)
(PROG ((BASEX (fetch (POSITION XCOORD) of BASEPT))
(BASEY (fetch (POSITION YCOORD) of BASEPT))
(OPPX (fetch (POSITION XCOORD) of OPPT))
(OPPY (fetch (POSITION YCOORD) of OPPT))
USERPT) (* check for minimum height and width constraints.)
(AND [COND
[(IGREATERP BASEX OPPX)
(COND
((ILESSP (IDIFFERENCE BASEX OPPX)
MINWID)
(SETQ OPPX (IDIFFERENCE BASEX MINWID]
((ILESSP (IDIFFERENCE OPPX BASEX)
MINWID)
(SETQ OPPX (IPLUS BASEX MINWID]
(replace (POSITION XCOORD) of OPPT with OPPX))
(AND [COND
[(IGREATERP BASEY OPPY)
(COND
((ILESSP (IDIFFERENCE BASEY OPPY)
MINHGHT)
(SETQ OPPY (IDIFFERENCE BASEY MINHGHT]
((ILESSP (IDIFFERENCE OPPY BASEY)
MINHGHT)
(SETQ OPPY (IPLUS BASEY MINHGHT]
(replace (POSITION YCOORD) of OPPT with OPPY))
(* if the new region fns is a list, apply them in
order.)
(for FN in NEWREGFNS
do (SETQ USERPT (APPLY* FN BASEPT OPPT NEWREGIONFNARG))
(COND
((NOT (POSITIONP USERPT))
(ERROR "non-POSITION returned by NEWREGIONFN" USERPT))
(T (replace (POSITION XCOORD) of OPPT with (fetch XCOORD of USERPT))
(replace (POSITION YCOORD) of OPPT with (fetch YCOORD of USERPT])
(\GETREGIONTRACKWITHBOX
[LAMBDA NIL (* rrb "17-Jul-84 16:30")
(DECLARE (GLOBALVARS DASHEDSHADE)
(LOCALVARS . T)) (* tracks a box sized between BASEX BASEY and OPPX OPPY
until the left or middle mouse button go down.)
(PROG (OLDCURSOR NOERROR XTEMP YTEMP OLDMOUSEX OLDMOUSEY POSTEMP THRUONCE
(WIDTH (IDIFFERENCE BASEX OPPX))
(HEIGHT (IDIFFERENCE BASEY OPPY)))
(DRAWGRAYBOX OPPX OPPY BASEX BASEY NIL DASHEDSHADE)
(* go thru the loop at least once so that checking of
user function against the first point is always done.)
[SETQ NOERROR (ERSETQ (until (AND THRUONCE (MOUSESTATE (OR LEFT MIDDLE)))
do (SETQ THRUONCE T)
(COND
((LASTMOUSESTATE RIGHT)
(SETQ OLDCURSOR (CURSOR FORCEPS))
(until (MOUSESTATE (NOT RIGHT)))
(CURSOR OLDCURSOR)
(* switch to drag nearest corner)
[COND
((COND
((IGREATERP BASEX OPPX)
(IGREATERP LASTMOUSEX (IQUOTIENT (IPLUS OPPX BASEX)
2)))
(T (IGREATERP (IQUOTIENT (IPLUS OPPX BASEX)
2)
LASTMOUSEX)))
(* switch X)
(swap OPPX BASEX)
(SETQ WIDTH (IDIFFERENCE BASEX OPPX]
[COND
((COND
((IGREATERP BASEY OPPY)
(IGREATERP LASTMOUSEY (IQUOTIENT (IPLUS OPPY BASEY)
2)))
(T (IGREATERP (IQUOTIENT (IPLUS OPPY BASEY)
2)
LASTMOUSEY)))
(* switch Y)
(swap OPPY BASEY)
(SETQ HEIGHT (IDIFFERENCE BASEY OPPY]
(\SETCURSORPOSITION OPPX OPPY))
((OR (NEQ LASTMOUSEX OLDMOUSEX)
(NEQ LASTMOUSEY OLDMOUSEY))
(* the cursor has moved, check user constraints.)
(SETQ POSTEMP (IPLUS (SETQ OLDMOUSEX LASTMOUSEX)
WIDTH))
(* make sure the base corner {which is opposite the one
tracked with the mouse} is on the screen.)
(COND
[(IGREATERP POSTEMP (CONSTANT (SUB1 SCREENWIDTH)))
(SETQ POSTEMP (CONSTANT (SUB1 SCREENWIDTH]
((ILESSP POSTEMP 0)
(SETQ POSTEMP 0)))
(replace (POSITION XCOORD) of BASEPT
with (COND
((IGREATERP POSTEMP (CONSTANT (SUB1 SCREENWIDTH)))
(CONSTANT (SUB1 SCREENWIDTH)))
((ILESSP POSTEMP 0)
0)
(T POSTEMP)))
(SETQ POSTEMP (IPLUS (SETQ OLDMOUSEY LASTMOUSEY)
HEIGHT))
(replace (POSITION YCOORD) of BASEPT
with (COND
[(IGREATERP POSTEMP (CONSTANT (SUB1 SCREENHEIGHT))
)
(SETQ POSTEMP (CONSTANT (SUB1 SCREENHEIGHT]
((ILESSP POSTEMP 0)
(SETQ POSTEMP 0))
(T POSTEMP)))
(\GETREGION.CHECKBASEPT NEWREGFNS BASEPT)
(SETQ YTEMP (fetch (POSITION YCOORD) of BASEPT))
(COND
((NOT (AND (IEQP BASEX (SETQ XTEMP (fetch (POSITION
XCOORD)
of BASEPT)))
(IEQP BASEY YTEMP)))
(* move the box)
(SETQ XTEMP (IDIFFERENCE XTEMP BASEX))
(SETQ YTEMP (IDIFFERENCE YTEMP BASEY))
(DRAWGRAYBOX OPPX OPPY BASEX BASEY NIL DASHEDSHADE)
(* Erase old box, make new one)
(DRAWGRAYBOX (SETQ OPPX (IPLUS OPPX XTEMP))
(SETQ OPPY (IPLUS OPPY YTEMP))
(SETQ BASEX (IPLUS BASEX XTEMP))
(SETQ BASEY (IPLUS BASEY YTEMP))
NIL DASHEDSHADE]
(DRAWGRAYBOX OPPX OPPY BASEX BASEY NIL DASHEDSHADE)
(COND
((NULL NOERROR) (* pass back ↑E)
(ERROR!])
(\UPDATEXYANDBOX
[LAMBDA (BASEPTCHANGE?) (* rrb "12-Dec-83 18:36")
(* moves the values in BASEPT and OPPT into the variables BASEX BASEY OPPX OPPY and updates the image on the
screen if it has changed.)
(PROG (TEMPX TEMPY)
[COND
(BASEPTCHANGE? (* the base point might have changed, check it too.)
(SETQ TEMPY (fetch (POSITION YCOORD) of BASEPT))
(COND
((NOT (AND (IEQP BASEX (SETQ TEMPX (fetch (POSITION XCOORD)
of BASEPT)))
(IEQP BASEY TEMPY)))
(* move the box)
(MOVEBOX OPPX OPPY BASEX BASEY (SETQ BASEX TEMPX)
(SETQ BASEY TEMPY]
(SETQ TEMPY (fetch (POSITION YCOORD) of OPPT))
(COND
((NOT (AND (IEQP OPPX (SETQ TEMPX (fetch (POSITION XCOORD) of OPPT)))
(IEQP OPPY TEMPY))) (* move the box)
(MOVEBOX BASEX BASEY OPPX OPPY (SETQ OPPX TEMPX)
(SETQ OPPY TEMPY))
(SETCORNER BASEX BASEY OPPX OPPY])
(GETBOXREGION
[LAMBDA (WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG) (* edited: "17-SEP-82 09:36")
(* returns a region width by height positioned where
user says.)
(PROG ((POS (GETBOXPOSITION WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG)))
(RETURN (create REGION
LEFT ←(fetch (POSITION XCOORD) of POS)
BOTTOM ←(fetch (POSITION YCOORD) of POS)
WIDTH ← WIDTH
HEIGHT ← HEIGHT])
(\TRACKWITHBOX
[LAMBDA NIL (* rrb "12-Dec-83 23:09")
(* tracks the cursor with a box from corner ORGX ORGY with dimensions BOXWIDTH and BOXHEIGHT until the left or
middle button changes. Implements the convention that the RIGHT button can be used to change corners.
Returns non-NIL unless an error occurred. Returns the result by setting freely the variable ORGX ORGY BOXWIDTH
BOXHEIGHT)
(PROG [OLDCURSOR ORGLEFTMIDDLE NOERROR (MLMASK (CONSTANT (LOGOR (MOUSESTATE-NAME (QUOTE LEFT))
(MOUSESTATE-NAME (QUOTE MIDDLE]
(SETQ ORGLEFTMIDDLE (LOGAND MLMASK LASTMOUSEBUTTONS))
(DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH)
(IPLUS ORGY BOXHEIGHT))
[SETQ NOERROR (ERSETQ (until (PROGN (GETMOUSESTATE)
(NEQ (LOGAND MLMASK LASTMOUSEBUTTONS)
ORGLEFTMIDDLE))
do (COND
((LASTMOUSESTATE RIGHT)
(SETQ OLDCURSOR (CURSOR FORCEPS))
(until (MOUSESTATE (NOT RIGHT)))
(CURSOR OLDCURSOR)
(* switch to drag nearest corner)
[COND
((COND
[(IGREATERP BOXWIDTH 0)
(IGREATERP LASTMOUSEX (IPLUS ORGX (IQUOTIENT
BOXWIDTH 2]
(T (IGREATERP (IPLUS ORGX (IQUOTIENT BOXWIDTH 2))
LASTMOUSEX)))
(* switch X)
(SETQ ORGX (IPLUS ORGX BOXWIDTH))
(SETQ BOXWIDTH (IMINUS BOXWIDTH]
[COND
((COND
[(IGREATERP BOXHEIGHT 0)
(IGREATERP LASTMOUSEY (IPLUS ORGY (IQUOTIENT
BOXHEIGHT 2]
(T (IGREATERP (IPLUS ORGY (IQUOTIENT BOXHEIGHT 2))
LASTMOUSEY)))
(* switch Y)
(SETQ ORGY (IPLUS ORGY BOXHEIGHT))
(SETQ BOXHEIGHT (IMINUS BOXHEIGHT]
(\SETCURSORPOSITION ORGX ORGY))
(T (COND
((NOT (AND (IEQP ORGX LASTMOUSEX)
(IEQP ORGY LASTMOUSEY)))
(* the cursor has moved, move the box)
(DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH)
(IPLUS ORGY BOXHEIGHT))
(* Erase old box, make new one)
(DRAWGRAYBOX (SETQ ORGX LASTMOUSEX)
(SETQ ORGY LASTMOUSEY)
(IPLUS ORGX BOXWIDTH)
(IPLUS ORGY BOXHEIGHT]
(DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH)
(IPLUS ORGY BOXHEIGHT))
(COND
((NULL NOERROR) (* pass back ↑E)
(ERROR!])
(MOVEBOX
[LAMBDA (X1 Y1 X2 Y2 X3 Y3) (* rrb " 6-AUG-81 09:09")
(* moves the opposite corner of a box from {X2,Y2} to
{X3,Y3}.)
(BLTHLINE Y1 X2 X3)
(BLTVLINE X1 Y2 Y3)
(BLTHLINE Y2 X1 X2)
(BLTHLINE Y3 X1 X3)
(BLTVLINE X2 Y1 Y2)
(BLTVLINE X3 Y1 Y3])
(DRAWGRAYBOX
[LAMBDA (X1 Y1 X2 Y2 W SHADE) (* rrb "12-Dec-83 22:53")
(* Put a gray box in window W
(or on screen, if W←NIL))
(BLTHLINE Y1 X1 X2 W SHADE)
(BLTVLINE X1 Y1 Y2 W SHADE)
(BLTHLINE Y2 X1 X2 W SHADE)
(BLTVLINE X2 Y1 Y2 W SHADE])
(BLTHLINE
[LAMBDA (Y XA XB W SHADE) (* rrb "12-Dec-83 22:53")
(BITBLT NIL NIL NIL (OR W (SCREENBITMAP))
(IMIN XA XB)
Y
(IABS (IDIFFERENCE XB XA))
2
(QUOTE TEXTURE)
(QUOTE INVERT)
(OR SHADE GRAYSHADE])
(BLTVLINE
[LAMBDA (X YA YB W SHADE) (* rrb "12-Dec-83 22:53")
(BITBLT NIL NIL NIL (OR W (SCREENBITMAP))
X
(IMIN YA YB)
2
(IABS (IDIFFERENCE YB YA))
(QUOTE TEXTURE)
(QUOTE INVERT)
(OR SHADE GRAYSHADE])
(SETCORNER
[LAMBDA (X1 Y1 X2 Y2) (* rrb " 4-NOV-81 15:32")
(* sets the cursor shape for the box from x1,y1 to x2,
y2)
(DECLARE (GLOBALVARS LowerLeftCursor LowerRightCursor UpperLeftCursor UpperRightCursor))
(SETCURSOR (COND
((IGREATERP X2 X1) (* moving to left)
(COND
((IGREATERP Y2 Y1) (* moving up)
UpperRightCursor)
(T LowerRightCursor)))
(T (* moving to right)
(COND
((IGREATERP Y2 Y1)
UpperLeftCursor)
(T LowerLeftCursor])
)
(DEFINEQ
(MOUSECONFIRM
[LAMBDA (PROMPTSTRING HELPSTRING WINDOW DON'TCLEARWINDOWFLG)
(* bvm: "14-Dec-83 16:06")
(* * Changes the cursor to a "little mouse"; prints a prompt; and waits for the user to press and then release a
mouse button. If the LEFT was the final one release then return T otherwise return NIL -- uses PROMPTWINDOW unless
provided a window * *)
(DECLARE (GLOBALVARS MOUSECONFIRMCURSOR))
(OR WINDOW (SETQ WINDOW PROMPTWINDOW))
(COND
[(OR (AND PROMPTSTRING (NEQ PROMPTSTRING T))
(NEQ HELPSTRING T))
(FRESHLINE WINDOW)
[COND
((AND PROMPTSTRING (NEQ PROMPTSTRING T))
(printout WINDOW PROMPTSTRING)
(COND
((NEQ HELPSTRING T)
(SPACES 2 WINDOW]
(COND
((NEQ HELPSTRING T)
(printout WINDOW (OR HELPSTRING "Click LEFT to confirm, RIGHT to abort."]
(T (SETQ DON'TCLEARWINDOWFLG T)))
(PROG1 (RESETFORM (CURSOR MOUSECONFIRMCURSOR)
(until (MOUSESTATE (OR LEFT MIDDLE RIGHT)))
(bind (LEFTDOWN ←(LASTMOUSESTATE LEFT)) until (MOUSESTATE UP)
do (* If buttons are still down, but not LEFT, user must
have changed mind)
(SETQ LEFTDOWN (LASTMOUSESTATE LEFT))
finally (RETURN LEFTDOWN)))
(COND
((NULL DON'TCLEARWINDOWFLG)
(CLEARW WINDOW])
)
(RPAQ MOUSECONFIRMCURSOR (CURSORCREATE (READBITMAP) 8 8))
(16 16
"GOOL"
"D@@D"
"ELID"
"ELID"
"ELID"
"ELID"
"ELID"
"ELID"
"ELID"
"D@@D"
"D@@D"
"D@@D"
"D@@D"
"D@@D"
"D@@D"
"GOOL")(DEFINEQ
(NEAREST/PT/ON/GRID
[LAMBDA (PT GRIDN) (* rrb " 6-AUG-81 08:45")
(* finds the point on a grid of multiple GRIDN closest
to PT.)
(create POSITION
XCOORD ←(NEAREST/MULTIPLE (fetch XCOORD of PT)
GRIDN)
YCOORD ←(NEAREST/MULTIPLE (fetch YCOORD of PT)
GRIDN)
smashing PT])
(PTON10GRID
[LAMBDA (FIXEDPT MOVINGPT) (* rrb " 6-AUG-81 08:45")
(* insists that a pt be on a 10 grid)
(COND
(MOVINGPT (NEAREST/PT/ON/GRID MOVINGPT 10))
(T (NEAREST/PT/ON/GRID FIXEDPT 10])
(NEAREST/MULTIPLE
[LAMBDA (X N) (* rrb " 6-AUG-81 08:42")
(* finds the multiple of N that is nearest to X)
(COND
((IGREATERP X 0)
(ITIMES (IQUOTIENT (IPLUS X (IQUOTIENT N 2))
N)
N))
(T (ITIMES (IQUOTIENT (IDIFFERENCE X (IQUOTIENT N 2))
N)
N])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS IABS MACRO [OPENLAMBDA (A)
(COND
((IGEQ A 0)
A)
(T (IMINUS A])
)
(* END EXPORTED DEFINITIONS)
(READVARS DASHEDSHADE)
({(READBITMAP)(16 16
"@@OO"
"@@OO"
"@@OO"
"@@OO"
"@@OO"
"@@OO"
"@@OO"
"@@OO"
"OO@@"
"OO@@"
"OO@@"
"OO@@"
"OO@@"
"OO@@"
"OO@@"
"OO@@")})
(RPAQ CROSSHAIRS (CURSORCREATE (READBITMAP) 7 7))
(16 16
"@@@@"
"@GL@"
"AMG@"
"CAAH"
"FA@L"
"DA@D"
"LA@F"
"HA@B"
"OOON"
"HA@B"
"LA@F"
"DA@D"
"FA@L"
"CAAH"
"AMG@"
"@GL@")(RPAQ EXPANDINGBOX (CURSORCREATE (READBITMAP) 0 13))
(16 16
"@@@@"
"@@@@"
"H@@@"
"L@@@"
"N@@@"
"O@@@"
"OHNG"
"OLLC"
"ONKM"
"O@BD"
"MHBD"
"IHKM"
"@LLC"
"@LNG"
"@F@@"
"@F@@")(RPAQ FORCEPS (CURSORCREATE (READBITMAP) 7 15))
(16 16
"@NG@"
"@JE@"
"@NG@"
"@DB@"
"@FF@"
"@CL@"
"@AH@"
"@AH@"
"@CL@"
"@FF@"
"ALCH"
"BDBD"
"BDBD"
"BDBD"
"BDBD"
"AHAH")(RPAQ BOXCURSOR (CURSORCREATE (READBITMAP) 7 7))
(16 16
"@@@@"
"@@@@"
"COOL"
"COOL"
"C@@L"
"C@@L"
"C@@L"
"C@@L"
"C@@L"
"C@@L"
"C@@L"
"C@@L"
"COOL"
"COOL"
"@@@@"
"@@@@")(RPAQ LOCKEDSPOT (CURSORCREATE (READBITMAP) 7 7))
(16 16
"@@@@"
"@@@@"
"COOL"
"COOL"
"C@@L"
"C@@L"
"CCLL"
"CCLL"
"CCLL"
"CCLL"
"C@@L"
"C@@L"
"COOL"
"COOL"
"@@@@"
"@@@@")(RPAQ OLDEXPANDINGBOX (CURSORCREATE (READBITMAP) 7 7))
(16 16
"@@@@"
"OHCN"
"N@@N"
"O@AN"
"KHCJ"
"IMGB"
"@ON@"
"@DD@"
"@LF@"
"@DD@"
"@ON@"
"IMGB"
"KHCJ"
"O@AN"
"N@@N"
"OHCN")(RPAQ LowerLeftCursor (CURSORCREATE (READBITMAP) 0 0))
(16 16
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"H@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"OOL@"
"OON@")(RPAQ UpperRightCursor (CURSORCREATE (READBITMAP) 15 15))
(16 16
"@COO"
"@AOO"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@A"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@")(RPAQ UpperLeftCursor (CURSORCREATE (READBITMAP) 0 15))
(16 16
"OOL@"
"OOH@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"L@@@"
"H@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@")(RPAQ LowerRightCursor (CURSORCREATE (READBITMAP) 15 0))
(16 16
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@@"
"@@@A"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@@@C"
"@COO"
"@GOO")(DEFINEQ
(\SW2BM
[LAMBDA (P PR Q QR) (* bas: "21-OCT-82 16:53")
(* Switches the areas of P and Q defined by the regions
PR and QR respectively)
(PROG (PL PH PW PB QL QH QW QB)
(if PR
then (SETQ PL (fetch LEFT of PR))
(SETQ PB (fetch BOTTOM of PR))
(SETQ PH (fetch HEIGHT of PR))
(SETQ PW (fetch WIDTH of PR))
else (SETQ PL (SETQ PB 0))
(SETQ PW (fetch BITMAPWIDTH of P))
(SETQ PH (fetch BITMAPHEIGHT of P)))
(if QR
then (SETQ QL (fetch LEFT of QR))
(SETQ QB (fetch BOTTOM of QR))
(SETQ QW (fetch WIDTH of QR))
(SETQ QH (fetch HEIGHT of QR))
else (SETQ QL (SETQ QB 0))
(SETQ QW (fetch BITMAPWIDTH of Q))
(SETQ QH (fetch BITMAPHEIGHT of Q)))
(PROG ((CL (IMAX (IMINUS PL)
(IMINUS QL)
0))
(CB (IMAX (IMINUS PB)
(IMINUS QB)
0)))
(PROG ((XP (IPLUS CL PL))
(YP (IPLUS CB PB))
(XQ (IPLUS CL QL))
(YQ (IPLUS CB QB))
CW CH)
(SETQ CW (IMIN (IDIFFERENCE (IMIN (fetch BITMAPWIDTH of P)
(IPLUS PL PW))
XP)
(IDIFFERENCE (IMIN (fetch BITMAPWIDTH of Q)
(IPLUS QL QW))
XQ)))
(SETQ CH (IMIN (IDIFFERENCE (IMIN (fetch BITMAPHEIGHT of P)
(IPLUS PB PH))
YP)
(IDIFFERENCE (IMIN (fetch BITMAPHEIGHT of Q)
(IPLUS QB QH))
YQ)))
(UNINTERRUPTABLY
(BITBLT P XP YP Q XQ YQ CW CH (QUOTE INPUT)
(QUOTE INVERT))
(BITBLT Q XQ YQ P XP YP CW CH (QUOTE INPUT)
(QUOTE INVERT))
(BITBLT P XP YP Q XQ YQ CW CH (QUOTE INPUT)
(QUOTE INVERT)))])
(COMPOSEREGS
[LAMBDA (INNER OUTER) (* rrb "19-MAR-82 09:35")
(* Converts INNER from OUTER relative coords to same
units as OUTER -
inverse of TRANSLATEREGS)
(create REGION
LEFT ←(IPLUS (fetch (REGION LEFT) of OUTER)
(fetch (REGION LEFT) of INNER))
BOTTOM ←(IPLUS (fetch (REGION BOTTOM) of OUTER)
(fetch (REGION BOTTOM) of INNER))
using INNER])
(TRANSLATEREG
[LAMBDA (INNER OUTER) (* rrb "19-MAR-82 09:35")
(* Translates a nested INNER region to OUTER region
relative coordinates)
(create REGION
LEFT ←(IDIFFERENCE (fetch (REGION LEFT) of INNER)
(fetch (REGION LEFT) of OUTER))
BOTTOM ←(IDIFFERENCE (fetch (REGION BOTTOM) of INNER)
(fetch (REGION BOTTOM) of OUTER))
WIDTH ←(fetch (REGION WIDTH) of INNER)
HEIGHT ←(fetch (REGION HEIGHT) of INNER])
)
(* Bitmap and shade editors)
(DEFINEQ
(EDITBM
[LAMBDA (BMSPEC) (* rrb "18-Apr-84 18:47")
(* edits a bitmap)
(* the edit part of the display is from 0 to MAXGRIDWIDTH in width and from 0 to MAXGRIDHEIGHT in height.
The commands and display area for the bitmap being edited are above the edit region.)
(PROG (BMW BMWINTERIOR BMWWIDTH BMWHEIGHT WIDTH HEIGHT BM CR ORIGBM GRIDSQUARE ORIGBPP)
(* set ORIGBM to the input bitmap if any and BM to a
copy of it for editting.)
[COND
((OR (EQ BMSPEC CursorBitMap)
(AND (EQ BMSPEC (QUOTE CursorBitMap))
(SETQ BMSPEC CursorBitMap))) (* editting cursor, save old value and make changes to
the original.)
(SETQ ORIGBM (BITMAPCOPY CursorBitMap))
(SETQ BM CursorBitMap))
[(BITMAPP BMSPEC)
(SETQ BM (BITMAPCOPY (SETQ ORIGBM BMSPEC]
[(LITATOM BMSPEC)
(COND
([BITMAPP (SETQ ORIGBM (EVALV BMSPEC (QUOTE EDITBM]
(* use value.)
(SETQ BM (BITMAPCOPY ORIGBM)))
(T (SETQ ORIGBM NIL)
(SETQ BM (\READBMDIMENSIONS]
((REGIONP BMSPEC) (* if BMSPEC is a region, treat it as a region of the
screen.)
[SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC)
(fetch (REGION HEIGHT) of BMSPEC)
(BITSPERPIXEL (SCREENBITMAP]
(* note that bm has initial bits in it.)
(SETQ ORIGBM BMSPEC)
(BITBLT (SCREENBITMAP)
(fetch (REGION LEFT) of BMSPEC)
(fetch (REGION BOTTOM) of BMSPEC)
BM 0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE)))
((WINDOWP BMSPEC)
(SETQ ORIGBM BMSPEC)
[SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC (QUOTE WIDTH))
(WINDOWPROP BMSPEC (QUOTE HEIGHT]
(* open the window and bring it to the top.)
(TOTOPW BMSPEC)
(SETQ CR (DSPCLIPPINGREGION NIL BMSPEC))
(BITBLT BMSPEC (fetch LEFT of CR)
(fetch BOTTOM of CR)
BM 0 0 (fetch WIDTH of CR)
(fetch HEIGHT of CR)))
(T (* otherwise create a bitmap)
(SETQ BM (\READBMDIMENSIONS]
(SETQ HEIGHT (fetch BITMAPHEIGHT of BM)) (* get and use width in bits not pixels.)
(SETQ WIDTH (fetch BITMAPWIDTH of BM)) (* calculate a default window size.)
(* start by calculating the grid size from the bitmap
size.)
(SETQ GRIDSQUARE (IMAX (IMIN (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES SCREENWIDTH 2)
3)
GRIDTHICKNESS)
WIDTH)
(IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES SCREENHEIGHT 2)
3)
(ITIMES GRIDTHICKNESS 2))
(ADD1 HEIGHT))
NORMALGRIDSQUARE)
MINGRIDSQUARE))
(SETQ BMWWIDTH (IMIN (IPLUS (ITIMES GRIDSQUARE WIDTH)
GRIDTHICKNESS)
(IQUOTIENT (ITIMES SCREENWIDTH 2)
3)))
(SETQ BMWHEIGHT (IMIN (IPLUS (ITIMES HEIGHT (ADD1 GRIDSQUARE))
(ITIMES GRIDTHICKNESS 2)
1)
(IQUOTIENT (ITIMES SCREENHEIGHT 2)
3)))
(SETQ BMW (CREATEW (GETBOXREGION (WIDTHIFWINDOW BMWWIDTH)
(HEIGHTIFWINDOW BMWHEIGHT T)
NIL NIL NIL
"Indicate the position for the Bitmap Edit window.")
"Bitmap Editor"))
(WINDOWPROP BMW (QUOTE BM)
BM)
(WINDOWPROP BMW (QUOTE SCROLLFN)
(FUNCTION EDITBMSCROLLFN))
(WINDOWPROP BMW (QUOTE RESHAPEFN)
(FUNCTION EDITBMRESHAPEFN))
(WINDOWPROP BMW (QUOTE REPAINTFN)
(FUNCTION EDITBMREPAINTFN))
(WINDOWPROP BMW (QUOTE BUTTONEVENTFN)
(FUNCTION EDITBMBUTTONFN))
(WINDOWPROP BMW (QUOTE CLOSEFN)
(FUNCTION EDITBMCLOSEFN))
(WINDOWPROP BMW (QUOTE XOFFSET)
0)
(WINDOWPROP BMW (QUOTE YOFFSET)
0)
(WINDOWPROP BMW (QUOTE DXOFFSET)
0)
(WINDOWPROP BMW (QUOTE DYOFFSET)
0)
(WINDOWPROP BMW (QUOTE ORIGINALBITMAP)
ORIGBM)
(WINDOWPROP BMW (QUOTE FINISHEDFLG)
NIL)
(SETQ ORIGBPP (fetch (BITMAP BITMAPBITSPERPIXEL) of BM))
(* save the actual number of bits per pixel and set it to 1 in the bitmap being editted so that it can be BITBLT
ed on the screen.)
(replace (BITMAP BITMAPBITSPERPIXEL) of BM with 1)
(* call reshapefn to initialize the display and values)
(EDITBMRESHAPEFN BMW NIL NIL (NOT ORIGBM)) (* start a mouse process in case this process is the
mouse process.)
(SPAWN.MOUSE)
(while (NOT (WINDOWPROP BMW (QUOTE FINISHEDFLG))) do (DISMISS 500))
(* remove the closefn before closing the window.)
(WINDOWPROP BMW (QUOTE CLOSEFN)
NIL)
(CLOSEW BMW)
(replace (BITMAP BITMAPBITSPERPIXEL) of BM with ORIGBPP)
(RETURN (COND
((EQ T (WINDOWPROP BMW (QUOTE FINISHEDFLG)))
(* editor exited via ok, stuff contents into original
bitmap.)
(COND
((EQ BMSPEC CursorBitMap) (* editting happened in original, leave it alone.)
CursorBitMap)
((REGIONP ORIGBM) (* put it back into the screen.)
(BITBLT BM 0 0 (SCREENBITMAP)
(fetch (REGION LEFT) of ORIGBM)
(fetch (REGION BOTTOM) of ORIGBM)
(fetch (REGION WIDTH) of ORIGBM)
(fetch (REGION HEIGHT) of ORIGBM)
(QUOTE INPUT)
(QUOTE REPLACE))
BM)
((WINDOWP ORIGBM) (* put it back into the window)
(BITBLT BM 0 0 ORIGBM (fetch (REGION LEFT) of CR)
(fetch (REGION BOTTOM) of CR)
(fetch (REGION WIDTH) of CR)
(fetch (REGION HEIGHT) of CR)
(QUOTE INPUT)
(QUOTE REPLACE))
BM)
(ORIGBM (BITBLT BM 0 0 ORIGBM 0 0 WIDTH HEIGHT)
[COND
((AND BMSPEC (LITATOM BMSPEC))
(* if spec was an atom without a bm value, set it.
in the environment above EDITBM.)
(MARKASCHANGED BMSPEC (QUOTE VARS))
(STKEVAL (QUOTE EDITBM)
(LIST (QUOTE SETQQ)
BMSPEC BM]
ORIGBM)
(T BM)))
(T (* error exit, if cursor return it to original value.)
(COND
((EQ BMSPEC CursorBitMap)
(BITBLT ORIGBM NIL NIL CursorBitMap)))
(ERROR!])
(EDITBMCLOSEFN
[LAMBDA (BMW) (* rrb "21-MAR-83 18:58")
(* the close function for a bitmap edit window.
For now do what a STOP would have done.)
(WINDOWPROP BMW (QUOTE FINISHEDFLG)
(QUOTE KILL])
(TILEAREA
[LAMBDA (LFT BTM WDTH HGHT SRCBM WIN) (* rrb "20-JUN-82 17:01")
(* lays tiles out in an area of a window.)
(PROG ((X LFT)
(Y BTM)
(RGHT (IPLUS LFT WDTH))
(TOP (IPLUS BTM HGHT))
(W (fetch BITMAPWIDTH of SRCBM))
(H (fetch BITMAPHEIGHT of SRCBM)))
(while (ILESSP X RGHT) do (SETQ Y BTM)
(while (ILESSP Y TOP)
do (BITBLT SRCBM 0 0 WIN X Y W H NIL (QUOTE REPLACE))
(add Y H))
(add X W])
(EDITBMBUTTONFN
[LAMBDA (W) (* rrb "28-Aug-84 15:26")
(* inner function of bitmap editor.)
(PROG [GRIDX0 GRIDY0 BITMAPWIDTH BITMAPHEIGHT NEWGRIDSIZE PAINTW ORIGBM
(GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC)))
(GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR)))
(BM (WINDOWPROP W (QUOTE BM)))
(BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE)))
(BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH)))
(WREGION (WINDOWPROP W (QUOTE REGION)))
(XOFFSET (WINDOWPROP W (QUOTE XOFFSET)))
(YOFFSET (WINDOWPROP W (QUOTE YOFFSET)))
(DISPLAYREGION (WINDOWPROP W (QUOTE DISPLAYREGION]
(SETQ GRIDX0 (fetch (REGION LEFT) of GRIDSPEC))
(SETQ GRIDY0 (fetch (REGION BOTTOM) of GRIDSPEC))
(SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM))
(SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM))
(* mark the region of the bitmap that is being editted.)
(COND
((INSIDE? GRIDINTERIOR (LASTMOUSEX W)
(LASTMOUSEY W)) (* if cursor is inside, shade it.)
(\SHADEBITS BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH))
((INSIDE? DISPLAYREGION (LASTMOUSEX W)
(LASTMOUSEY W)) (* Run the menu foe re-windowing into the whole bitmap)
(SELECTQ [MENU (COND
((type? MENU EDITBMWINDOWMENU)
EDITBMWINDOWMENU)
((SETQ EDITBMWINDOWMENU (create MENU
ITEMS ←(QUOTE ((Move (QUOTE Move)
"Selects a different part of the bitmap to be editting.")))
CENTERFLG ← T]
(Move (* move the editing window's location on the bitmap.)
(PROG [(POS (GETBOXPOSITION BITSWIDE BITSHIGH
[IPLUS 4 (fetch LEFT of WREGION)
(IDIFFERENCE XOFFSET
(WINDOWPROP
W
(QUOTE DXOFFSET]
(IPLUS (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM))
(IDIFFERENCE YOFFSET
(WINDOWPROP
W
(QUOTE DYOFFSET)))
4
(fetch BOTTOM of WREGION]
(WINDOWPROP W (QUOTE XOFFSET)
(IMIN (IDIFFERENCE BITMAPWIDTH BITSWIDE)
(IMAX [IPLUS (WINDOWPROP W (QUOTE DXOFFSET))
(IDIFFERENCE (fetch XCOORD
of POS)
(IPLUS 4
(fetch LEFT
of WREGION]
0)))
[WINDOWPROP
W
(QUOTE YOFFSET)
(IMAX 0
(IMIN (IDIFFERENCE BITMAPHEIGHT BITSHIGH)
(IDIFFERENCE (IPLUS (WINDOWPROP W (QUOTE DYOFFSET))
(IDIFFERENCE
(fetch YCOORD of POS)
(IPLUS (fetch BOTTOM
of WREGION)
4)))
(WINDOWPROP W (QUOTE BMDISPLAYBOTTOM]
(DSPFILL GRIDINTERIOR WHITESHADE (QUOTE REPLACE)
W)
(UPDATE/BM/DISPLAY BM W)
(GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT)
W)
(RESETGRID BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W)))
NIL))
((LASTMOUSESTATE LEFT)
(UPDATE/BM/DISPLAY/SELECTED/REGION W)
[RESETFORM (CURSOR (CURSORCREATE BM (CURSORHOTSPOT)))
(until (MOUSESTATE (NOT LEFT]
(UPDATE/BM/DISPLAY/SELECTED/REGION W))
(T (* the region being editted is inverted while the menu
is active. Each command must make sure that it is
recomplemented.)
(UPDATE/BM/DISPLAY/SELECTED/REGION W)
(SELECTQ [MENU (COND
((type? MENU EDITBMMENU)
EDITBMMENU)
(T (SETQ EDITBMMENU (create MENU
ITEMS ←(QUOTE ((Paint (QUOTE Paint)
"Calls the window PAINT command on the bitmap.")
(ShowAsTile (QUOTE
ShowAsTile)
"tiles the upper part of the edit window with the bitmap.")
(GridSize←(QUOTE
GridSize←)
"Allows setting of the size of a bit in the edit area.")
(Reset (QUOTE Reset)
"Sets the bitmap back to the state at the start of this edit session.")
(Clear (QUOTE Clear)
"Sets the entire bitmap to 0")
(Cursor←(QUOTE Cursor←)
"Puts the bitmap into the cursor and exits the editor.")
(OK (QUOTE OK)
"Leaves the edit session.")
(Stop (QUOTE Stop)
"Restores the bitmap to its original values and leaves the editor.")))
CENTERFLG ← T]
(OK (WINDOWPROP W (QUOTE FINISHEDFLG)
T))
(Stop (WINDOWPROP W (QUOTE FINISHEDFLG)
(QUOTE KILL)))
[Reset (* allow the user to choose between everything or just
visible part. This also give the user a chance to change
their mind.)
(COND
((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH "RESET how much?")
(VISIBLE (COND
[(SETQ ORIGBM (WINDOWPROP W (QUOTE
ORIGINALBITMAP)))
(COND
((REGIONP ORIGBM)
(BITBLT (SCREENBITMAP)
(IPLUS XOFFSET
(fetch (REGION LEFT)
of ORIGBM))
(IPLUS YOFFSET
(fetch (REGION BOTTOM)
of ORIGBM))
BM XOFFSET YOFFSET BITSWIDE
BITSHIGH (QUOTE INPUT)
(QUOTE REPLACE)))
(T (BITBLT ORIGBM XOFFSET YOFFSET BM
XOFFSET YOFFSET BITSWIDE
BITSHIGH]
(T (BITBLT NIL NIL NIL BM XOFFSET YOFFSET
BITSWIDE BITSHIGH (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)))
T)
(WHOLE (COND
[(SETQ ORIGBM (WINDOWPROP W (QUOTE ORIGINALBITMAP)
))
(COND
((REGIONP ORIGBM)
(BITBLT (SCREENBITMAP)
(fetch (REGION LEFT) of ORIGBM)
(fetch (REGION BOTTOM)
of ORIGBM)
BM))
(T (BITBLT ORIGBM NIL NIL BM]
(T (\CLEARBM BM)))
T)
(PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W)
NIL))
(\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE
BITSHIGH]
[Clear (* allow the user to choose between everything or just
visible part. This also give the user a chance to change
their mind.)
(COND
((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH "CLEAR how much?")
(VISIBLE (BITBLT NIL NIL NIL BM XOFFSET YOFFSET BITSWIDE
BITSHIGH (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
T)
(WHOLE (\CLEARBM BM)
T)
(PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W)
NIL))
(DSPFILL GRIDINTERIOR WHITESHADE (QUOTE REPLACE)
W)
(GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT)
W)
(UPDATE/BM/DISPLAY BM W]
[GridSize← (* sets the grid square size and calls the reshapefn.)
(COND
([SETQ NEWGRIDSIZE
(NUMBERP (MENU (COND
((TYPENAMEP GRIDSIZEMENU (QUOTE MENU))
GRIDSIZEMENU)
(T (SETQ GRIDSIZEMENU
(create MENU
ITEMS ←(QUOTE (3 4 5 6 7 8 12
16 20 24 28
32))
MENUROWS ← 4]
(WINDOWPROP W (QUOTE GRIDSQUARE)
NEWGRIDSIZE)
(EDITBMRESHAPEFN W]
(ShowAsTile (* tiles the upper part of the window with the bitmap so
the user can see what it would be as a shade.)
(UPDATE/SHADE/DISPLAY BM W))
[Paint (* call the window paint command on the contents of the
bitmap.)
[SETQ PAINTW (CREATEW (create REGION
LEFT ←(IQUOTIENT (IDIFFERENCE
SCREENWIDTH
BITMAPWIDTH)
2)
BOTTOM ←(IQUOTIENT (IDIFFERENCE
SCREENHEIGHT
BITMAPHEIGHT)
2)
WIDTH ←(WIDTHIFWINDOW BITMAPWIDTH)
HEIGHT ←(HEIGHTIFWINDOW BITMAPHEIGHT NIL]
(OPENW PAINTW)
(BITBLT BM 0 0 PAINTW)
(PAINTW PAINTW)
(COND
((MENU (create MENU
ITEMS ←(QUOTE ((YES T
"Will put the newly painted bits back in the bitmap being editted.")
(NO NIL
"Will discard the painted bits, not changing the bitmap being editted.")))
TITLE ← "Put change into bitmap?"
CENTERFLG ← T))
(BITBLT PAINTW 0 0 BM)
(CLOSEW PAINTW) (* set PAINTW so that space can be reclaimed)
(SETQ PAINTW)
(\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE
BITSHIGH]
(Cursor← (* Stuffs lower left part of image into the cursor and
sets the hotspot.)
(READHOTSPOT BM GRIDSPEC GRIDINTERIOR W)
(WINDOWPROP W (QUOTE FINISHEDFLG)
T))
(UPDATE/BM/DISPLAY/SELECTED/REGION W])
(\EDITBM/PUTUP/DISPLAY
[LAMBDA (WINDOW BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH)
(* rrb " 2-AUG-82 10:59")
(* initializes the display for the bitmap editor.)
(DSPFILL GRIDINTERIOR WHITESHADE (QUOTE REPLACE)
WINDOW)
(GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT)
WINDOW)
(RESETGRID BM GRIDSPEC BITSWIDE BITSHIGH 0 0 WINDOW)
(UPDATE/BM/DISPLAY BM WINDOW])
(\EDITBMHOWMUCH
[LAMBDA (BM EDITWIDTH EDITHEIGHT TITLEQ) (* rrb "21-JUN-82 10:30")
(* asks the user how much to clear)
(MENU (COND
((OR (IGREATERP (fetch (BITMAP BITMAPWIDTH) of BM)
EDITWIDTH)
(IGREATERP (fetch (BITMAP BITMAPHEIGHT) of BM)
EDITHEIGHT))
(create MENU
TITLE ← TITLEQ
ITEMS ←(QUOTE ((VisiblePart (QUOTE VISIBLE)
"Operates on just the part visible in the edit region")
(WholeBitmap (QUOTE WHOLE)
"Operates on the entire bitmap")))
CENTERFLG ← T))
(T (create MENU
TITLE ← TITLEQ
ITEMS ←(QUOTE ((WholeBitmap (QUOTE WHOLE)
"Operates on the entire bitmap")))
CENTERFLG ← T])
(EDITBMRESHAPEFN
[LAMBDA (BMEDITWINDOW OLDIMAGE OLDREGION ZEROBMFLG) (* rrb "17-JUN-82 12:45")
(* allows the bitmap edit window to be reshaped to enlarge the editting area. This is also called to set up the
image during initialization.)
(PROG (BMWINTERIORWIDTH BMWINTERIORHEIGHT EDITAREABITWIDTH EDITAREABITHEIGHT GRIDSQUARE
GRIDINTERIOR BITMAPWIDTH BMDISPLAYWIDTH BMDISPLAYBOTTOM BMDISPLAYHEIGHT
BITMAPHEIGHT (BM (WINDOWPROP BMEDITWINDOW (QUOTE BM)))
(MINCOMMANDAREAWIDTH 30))
(SETQ BITMAPWIDTH (fetch BITMAPWIDTH of BM))
(SETQ BITMAPHEIGHT (fetch BITMAPHEIGHT of BM))
(SETQ BMWINTERIORWIDTH (WINDOWPROP BMEDITWINDOW (QUOTE WIDTH)))
(* leave room at the top for the full size display area.
But not more than half of the window.)
(SETQ BMWINTERIORHEIGHT (IMAX (IDIFFERENCE (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT))
(IPLUS BITMAPHEIGHT GRIDTHICKNESS))
(IQUOTIENT (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT))
2)))
(* if the user hasn't set it, determine the grid size as the largest size which fits the interior but not larger
than NORMALGRIDSQUARE nor smaller than MINGRIDSQUARE. If GRIDSQUARE was specified, reset it to NIL so that if
reshaped it will be recalculated.)
(SETQ GRIDSQUARE (OR (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSQUARE)
NIL)
(IMAX (IMIN (IQUOTIENT BMWINTERIORWIDTH BITMAPWIDTH)
(IQUOTIENT BMWINTERIORHEIGHT BITMAPHEIGHT)
NORMALGRIDSQUARE)
MINGRIDSQUARE))) (* calculate how many bits will be displayed at once.)
(SETQ EDITAREABITWIDTH (IMIN (IQUOTIENT BMWINTERIORWIDTH GRIDSQUARE)
BITMAPWIDTH))
(WINDOWPROP BMEDITWINDOW (QUOTE BITSWIDE)
EDITAREABITWIDTH)
(SETQ EDITAREABITHEIGHT (IMIN (IQUOTIENT BMWINTERIORHEIGHT GRIDSQUARE)
BITMAPHEIGHT)) (* calculate offset of display and command regions at
the top of the window.)
(WINDOWPROP BMEDITWINDOW (QUOTE BITSHIGH)
EDITAREABITHEIGHT)
(SETQ BMDISPLAYBOTTOM (IPLUS (ITIMES GRIDSQUARE EDITAREABITHEIGHT)
GRIDTHICKNESS))
(SETQ BMDISPLAYWIDTH (IMIN BITMAPWIDTH (IDIFFERENCE BMWINTERIORWIDTH MINCOMMANDAREAWIDTH)))
(* put the offset -
the lower left coordinate -
in the same place unless the new shape allows more to be shown past the upper right corner.)
(WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET)
(IMIN (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET))
(IDIFFERENCE BITMAPWIDTH EDITAREABITWIDTH)))
(WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET)
(IMIN (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET))
(IDIFFERENCE BITMAPHEIGHT EDITAREABITHEIGHT)))
(* Center edit square)
(SETQ GRIDINTERIOR (create REGION
LEFT ←(IQUOTIENT (IDIFFERENCE BMWINTERIORWIDTH (ITIMES
EDITAREABITWIDTH
GRIDSQUARE))
2)
BOTTOM ←(IQUOTIENT (IDIFFERENCE BMDISPLAYBOTTOM
(ITIMES EDITAREABITHEIGHT
GRIDSQUARE))
2)
WIDTH ←(ITIMES EDITAREABITWIDTH GRIDSQUARE)
HEIGHT ←(ITIMES EDITAREABITHEIGHT GRIDSQUARE)))
(WINDOWPROP BMEDITWINDOW (QUOTE GRIDINTERIOR)
GRIDINTERIOR)
(WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYBOTTOM)
BMDISPLAYBOTTOM)
(WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYWIDTH)
BMDISPLAYWIDTH)
(WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYHEIGHT)
(SETQ BMDISPLAYHEIGHT (IDIFFERENCE (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT))
BMDISPLAYBOTTOM)))
(WINDOWPROP BMEDITWINDOW (QUOTE DISPLAYREGION)
(create REGION
LEFT ← 0
BOTTOM ← BMDISPLAYBOTTOM
WIDTH ← BMDISPLAYWIDTH
HEIGHT ← BMDISPLAYHEIGHT))
(WINDOWPROP BMEDITWINDOW (QUOTE GRIDSPEC)
(create REGION
LEFT ←(fetch (REGION LEFT) of GRIDINTERIOR)
BOTTOM ←(fetch (REGION BOTTOM) of GRIDINTERIOR)
WIDTH ← GRIDSQUARE
HEIGHT ← GRIDSQUARE))
(EDITBMREPAINTFN BMEDITWINDOW NIL ZEROBMFLG])
(EDITBMREPAINTFN
[LAMBDA (WIN REGION ZEROBM) (* edited: "17-SEP-82 09:34")
(* redisplays a bitmap editting window If ZEROBM is
non-NIL, it doesn't bother to display the bits.)
(PROG [(GRIDSPEC (WINDOWPROP WIN (QUOTE GRIDSPEC)))
(EDITAREABITWIDTH (WINDOWPROP WIN (QUOTE BITSWIDE)))
(EDITAREABITHEIGHT (WINDOWPROP WIN (QUOTE BITSHIGH)))
(BM (WINDOWPROP WIN (QUOTE BM]
(CLEARW WIN) (* gray the area above the edit grid that is not bitmap
display area.)
(BITBLT NIL NIL NIL WIN (IPLUS (WINDOWPROP WIN (QUOTE BMDISPLAYWIDTH))
GRIDTHICKNESS)
(WINDOWPROP WIN (QUOTE BMDISPLAYBOTTOM))
NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
NOTINUSEGRAY) (* put in the display of the full sized bitmap.)
(UPDATE/BM/DISPLAY BM WIN) (* put in grid markings.)
(GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT (QUOTE POINT)
WIN)
(* shade in the bits that are on. If the expectation is that most bits were on it would be faster to change
RESETGRID to show both off and on bits and remove the previous call to GRID.)
(OR ZEROBM (RESETGRID BM GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 0 0 WIN])
(UPDATE/SHADE/DISPLAY
[LAMBDA (BM WIN) (* rrb "20-JUN-82 16:53")
(* displays BM as if it were a shade.)
(PROG [(BOTTOM (WINDOWPROP WIN (QUOTE BMDISPLAYBOTTOM]
(TILEAREA 0 BOTTOM (WINDOWPROP WIN (QUOTE WIDTH))
(IDIFFERENCE (WINDOWPROP WIN (QUOTE HEIGHT))
BOTTOM)
BM WIN])
(UPDATE/BM/DISPLAY/SELECTED/REGION
[LAMBDA (W) (* rrb "17-JUN-82 11:19")
(* Shade the selected region of the bitmap display
area.)
(COND
([OR (IGREATERP (FETCH (BITMAP BITMAPWIDTH) OF (WINDOWPROP W (QUOTE BM)))
(WINDOWPROP W (QUOTE BITSWIDE)))
(IGREATERP (FETCH (BITMAP BITMAPHEIGHT) OF (WINDOWPROP W (QUOTE BM)))
(WINDOWPROP W (QUOTE BITSHIGH] (* only invert the region being editted if it is less
than the entire bitmap.)
(BITBLT NIL 0 0 W (IDIFFERENCE (WINDOWPROP W (QUOTE XOFFSET))
(WINDOWPROP W (QUOTE DXOFFSET)))
(IDIFFERENCE (IPLUS (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM))
(WINDOWPROP W (QUOTE YOFFSET)))
(WINDOWPROP W (QUOTE DYOFFSET)))
(WINDOWPROP W (QUOTE BITSWIDE))
(WINDOWPROP W (QUOTE BITSHIGH))
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE])
(SHOWBUTTON
[LAMBDA (BUTTON DS) (* rrb "27-JUL-81 10:59")
(* displays a menu box and its title.)
(PROG ((BLOCK (fetch (BUTTON REGION) of BUTTON)))
(WBOX BLOCK NIL NIL DS) (* Display the title in the middle of the box)
(CENTERPRINTINREGION (fetch (BUTTON LABEL) of BUTTON)
BLOCK DS])
(RESETGRID
[LAMBDA (BM GRIDSPEC WIDTH HEIGHT ORGX ORGY W) (* rrb "17-JUN-82 11:48")
(* copies the contents of a bitmap into the edit display
grid.)
(bind [(XOFFSET ←(WINDOWPROP W (QUOTE XOFFSET)))
(YOFFSET ←(WINDOWPROP W (QUOTE YOFFSET]
for Y from (OR ORGY 0) to (SUB1 (COND
(ORGY (IPLUS ORGY HEIGHT))
(T HEIGHT)))
do (for X from (OR ORGX 0) to (SUB1 (COND
(ORGX (IPLUS ORGX WIDTH))
(T WIDTH)))
when (EQ (BITMAPBIT BM (IPLUS X XOFFSET)
(IPLUS Y YOFFSET))
1)
do (SHADEGRIDBOX X Y DARKBITSHADE (QUOTE REPLACE)
GRIDSPEC
(QUOTE POINT)
W])
(\READBMDIMENSIONS
[LAMBDA NIL (* rrb "24-AUG-82 10:42")
(* asks the user for dimensions of a bitmap and creates
it.)
(PROG (WIDTH HEIGHT)
WIDTHLP
(PRIN1 "How wide would you like the bitmap to be? " T)
(COND
([NOT (NUMBERP (SETQ WIDTH (READ T]
(PRIN1 "?" T)
(TERPRI T)
(GO WIDTHLP))
((ILESSP WIDTH 1)
(PRIN1 "WIDTH must be positive." T)
(TERPRI T)
(GO WIDTHLP)))
HEIGHTLP
(PRIN1 "How high would you like the bitmap to be? " T)
(COND
([NOT (NUMBERP (SETQ HEIGHT (READ T]
(PRIN1 "?" T)
(TERPRI T)
(GO HEIGHTLP))
((ILESSP HEIGHT 1)
(PRIN1 "HEIGHT must be positive." T)
(TERPRI T)
(GO HEIGHTLP)))
(RETURN (BITMAPCREATE WIDTH HEIGHT])
(EDITSHADE
[LAMBDA (SHADE) (* rrb "17-May-84 12:00")
(* allows the editing of a shade.)
(PROG ([SHADEBM (COND
((BITMAPP SHADE)
(CREATETEXTUREFROMBITMAP SHADE))
((FIXP SHADE)
(\BITMAPFROMTEXTURE SHADE))
((EQ SHADE T)
(BITMAPCREATE 16 16))
((NULL SHADE)
(BITMAPCREATE 4 4))
(T (\ILLEGAL.ARG SHADE]
(QUITREGION (CREATEREGION 125 150 50 20))
(SHADEREGION (CREATEREGION 10 185 272 100))
BMWIDTH BMHEIGHT GRIDINTERIOR GRIDSPEC X Y SEDW DS BOXSIZE)
(SETQ DS (WINDOWPROP (SETQ SEDW (CREATEW (GETBOXREGION 300 300 NIL NIL NIL
"Indicate position of Shade edit window.")))
(QUOTE DSP)))
(SETQ BMWIDTH (BITMAPWIDTH SHADEBM))
(SETQ BMHEIGHT (BITMAPHEIGHT SHADEBM))
(SETQ BOXSIZE (IMIN (IQUOTIENT 144 BMHEIGHT)
(IQUOTIENT 256 BMWIDTH)))
(WINDOWPROP SEDW (QUOTE PROCESS)
(THIS.PROCESS))
(WINDOWPROP SEDW (QUOTE REPAINTFN)
(QUOTE EDITSHADEREPAINTFN))
(WINDOWPROP SEDW (QUOTE QUITREGION)
QUITREGION)
(WINDOWPROP SEDW (QUOTE GRIDSPEC)
(SETQ GRIDSPEC (CREATEREGION (SETQ X (IQUOTIENT (IDIFFERENCE 292
(ITIMES BOXSIZE
BMWIDTH))
2))
(SETQ Y (IQUOTIENT (IDIFFERENCE 150
(ITIMES BOXSIZE
BMHEIGHT))
2))
BOXSIZE BOXSIZE)))
[WINDOWPROP SEDW (QUOTE GRIDINTERIOR)
(SETQ GRIDINTERIOR (CREATEREGION X Y (ITIMES BOXSIZE BMWIDTH)
(ITIMES BOXSIZE BMHEIGHT]
(WINDOWPROP SEDW (QUOTE SHADEBM)
SHADEBM)
(WINDOWPROP SEDW (QUOTE SHADEREGION)
SHADEREGION)
(WINDOWPROP SEDW (QUOTE XOFFSET)
0)
(WINDOWPROP SEDW (QUOTE YOFFSET)
0)
(EDITSHADEREPAINTFN SEDW)
[RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEW)
SEDW))
(do (DSPFILL SHADEREGION (COND
((EQ BMWIDTH 4) (* bitblt doesn't like bitmaps that are not 16 by 16.0)
(CREATETEXTUREFROMBITMAP SHADEBM))
(T SHADEBM))
(QUOTE TEXTURE)
DS)
(until (MOUSESTATE (OR LEFT MIDDLE RIGHT))
do (TOTOPW SEDW)
(BLOCK))
(COND
[(LASTMOUSESTATE RIGHT)
(ERSETQ (DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY]
((EQ (QUOTE STOP)
(until (MOUSESTATE UP) bind (XPIXEL YPIXEL)
do (TOTOPW SEDW)
[COND
[(INSIDE? GRIDINTERIOR (SETQ X (LASTMOUSEX DS))
(SETQ Y (LASTMOUSEY DS)))
(COND
((AND (STRICTLY/BETWEEN (SETQ XPIXEL (GRIDXCOORD X
GRIDSPEC))
-1 BMWIDTH)
(STRICTLY/BETWEEN (SETQ YPIXEL (GRIDYCOORD Y
GRIDSPEC))
-1 BMHEIGHT))
(SHADEGRIDBOX XPIXEL YPIXEL (COND
((LASTMOUSESTATE LEFT)
DARKBITSHADE)
(T WHITESHADE))
(QUOTE REPLACE)
GRIDSPEC
(QUOTE POINT)
DS)
(BITMAPBIT SHADEBM XPIXEL YPIXEL (COND
((LASTMOUSESTATE LEFT)
1)
(T 0]
((INSIDE? QUITREGION X Y)
(DSPFILL QUITREGION BLACKSHADE (QUOTE INVERT)
DS)
(RETURN (until (MOUSESTATE UP)
do (COND
((NOT (INSIDE? QUITREGION (LASTMOUSEX DS)
(LASTMOUSEY DS)))
(DSPFILL QUITREGION BLACKSHADE
(QUOTE INVERT)
DS)
(RETURN)))
finally (DSPFILL QUITREGION BLACKSHADE
(QUOTE INVERT)
DS)
(* close window.)
(RETURN (QUOTE STOP]
(BLOCK)))
(RETURN]
(RETURN (COND
((AND (OR (NUMBERP SHADE)
(NULL SHADE))
(EQ BMWIDTH 4)
(EQ BMHEIGHT 4)) (* user passed in a number or NIL, give them a number
back.)
(CREATETEXTUREFROMBITMAP SHADEBM))
(T SHADEBM])
(\BITMAPFROMTEXTURE
[LAMBDA (FIXP) (* rrb "16-May-84 14:56")
(* returns a 4 by 4 bitmap that contains the texture
represented by FIXP.)
(PROG ((SHADE (BITMAPCREATE 4 4)))
[for X from 0 to 3
do (for Y from 0 to 3
do (COND
([NOT (EQ 0 (LOGAND FIXP (\BITMASK (IPLUS (ITIMES (IDIFFERENCE 3 Y)
4)
X]
(BITMAPBIT SHADE X Y 1]
(RETURN SHADE])
(EDITSHADEREPAINTFN
[LAMBDA (WIN) (* rrb "16-May-84 15:03")
(* redisplays an edit shade window.)
(PROG ((GRIDSPEC (WINDOWPROP WIN (QUOTE GRIDSPEC)))
(SHADE (WINDOWPROP WIN (QUOTE SHADEBM)))
BMWIDTH BMHEIGHT)
(SETQ BMWIDTH (BITMAPWIDTH SHADE))
(SETQ BMHEIGHT (BITMAPHEIGHT SHADE))
(SHOWBUTTON (create BUTTON
REGION ←(WINDOWPROP WIN (QUOTE QUITREGION))
LABEL ←(QUOTE QUIT)
HELP ← "Quits")
WIN)
(GRAYBOXAREA (fetch LEFT of GRIDSPEC)
(fetch BOTTOM of GRIDSPEC)
(ITIMES (fetch WIDTH of GRIDSPEC)
BMWIDTH)
(ITIMES (fetch HEIGHT of GRIDSPEC)
BMHEIGHT)
2 BLACKSHADE WIN)
(GRID GRIDSPEC BMWIDTH BMHEIGHT (QUOTE POINT)
WIN)
(RESETGRID SHADE GRIDSPEC BMWIDTH BMHEIGHT 0 0 WIN)
(DSPFILL (WINDOWPROP WIN (QUOTE SHADEREGION))
SHADE
(QUOTE TEXTURE)
WIN])
(GRAYBOXAREA
[LAMBDA (X Y WIDTH HEIGHT OUTLINESIZE TEXTURE DS) (* rrb "13-JUN-82 17:41")
(* outlines an area with a gray box.)
(COND
((FIXP OUTLINESIZE))
((NULL OUTLINESIZE)
(SETQ OUTLINESIZE 1))
(T (\ILLEGAL.ARG OUTLINESIZE)))
(BITBLT NIL NIL NIL DS (IDIFFERENCE X OUTLINESIZE)
(IDIFFERENCE Y OUTLINESIZE)
(IPLUS WIDTH (ITIMES 2 OUTLINESIZE))
(IPLUS HEIGHT (ITIMES 2 OUTLINESIZE))
(QUOTE TEXTURE)
(QUOTE REPLACE)
(OR TEXTURE BLACKSHADE))
(BITBLT NIL NIL NIL DS X Y WIDTH HEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
(DSPTEXTURE NIL DS])
(\SHADEBITS
[LAMBDA (BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH) (* rrb "16-JUN-82 16:14")
(* cursor is inside the edit grid, so change the bit in
the bitmap, change the edit grid and redisplay the
bitmap.)
(bind (XPIXEL YPIXEL INTENSITY X Y) until (MOUSESTATE UP)
when (AND [NEQ (AND [EQ XPIXEL (SETQ XPIXEL (IMAX 0 (IMIN BITSWIDE (GRIDXCOORD (SETQ X
(LASTMOUSEX
W))
GRIDSPEC]
YPIXEL)
(SETQ YPIXEL (IMAX 0 (IMIN BITSHIGH (GRIDYCOORD (SETQ Y (LASTMOUSEY W))
GRIDSPEC]
(INSIDE? GRIDINTERIOR X Y))
do [BITMAPBIT BM (IPLUS XPIXEL (WINDOWPROP W (QUOTE XOFFSET)))
(IPLUS YPIXEL (WINDOWPROP W (QUOTE YOFFSET)))
(SETQ INTENSITY (COND
((LASTMOUSESTATE LEFT)
DARKBITSHADE)
(T WHITESHADE]
(UPDATE/BM/DISPLAY BM W)
(SHADEGRIDBOX XPIXEL YPIXEL INTENSITY (QUOTE REPLACE)
GRIDSPEC
(QUOTE POINT)
W])
(READHOTSPOT
[LAMBDA (BM GRIDSPEC GRIDINTERIOR DS) (* rrb "16-JUN-82 11:26")
(DECLARE (GLOBALVARS \MOUSEHOTSPOTX \MOUSEHOTSPOTY)) (* reads the hotspot from the cursor and sets cursor)
(UNTILMOUSESTATE UP)
(PROG ((NOWCURSOR (CURSOR))
XPIXEL YPIXEL DOWNYET?)
(CURSORPOSITION (create POSITION
XCOORD ←(IPLUS (LEFTOFGRIDCOORD (SETQ XPIXEL (fetch CURSORHOTSPOTX
of NOWCURSOR))
GRIDSPEC)
(IQUOTIENT (fetch (REGION WIDTH) of GRIDSPEC)
2))
YCOORD ←(IPLUS (BOTTOMOFGRIDCOORD (SETQ YPIXEL
(fetch CURSORHOTSPOTY
of NOWCURSOR))
GRIDSPEC)
(IQUOTIENT (fetch (REGION HEIGHT) of GRIDSPEC)
2)))
DS)
(SHADEGRIDBOX XPIXEL YPIXEL NOTINUSEGRAY (QUOTE REPLACE)
GRIDSPEC
(QUOTE POINT)
DS)
(until (PROGN (GETMOUSESTATE)
(AND DOWNYET? (MOUSESTATE UP)))
when (INSIDE? GRIDINTERIOR (LASTMOUSEX DS)
(LASTMOUSEY DS))
do (OR DOWNYET? (SETQ DOWNYET? (NEQ LASTMOUSEBUTTONS 0)))
(COND
(XPIXEL (SHADEGRIDBOX XPIXEL YPIXEL (SELECTQ (BITMAPBIT BM XPIXEL YPIXEL)
(0 WHITESHADE)
(1 DARKBITSHADE)
(SHOULDNT))
(QUOTE REPLACE)
GRIDSPEC
(QUOTE POINT)
DS)))
(SHADEGRIDBOX (SETQ XPIXEL (GRIDXCOORD (LASTMOUSEX DS)
GRIDSPEC))
(SETQ YPIXEL (GRIDYCOORD (LASTMOUSEY DS)
GRIDSPEC))
NOTINUSEGRAY
(QUOTE REPLACE)
GRIDSPEC
(QUOTE POINT)
DS)
finally (CURSOR (CURSORCREATE BM XPIXEL YPIXEL])
(WBOX
[LAMBDA (REG THCK TEXT DS) (* rrb "19-MAR-82 09:38")
(* Draws a box around REG with bounding lines of
THCKness)
(OR THCK (SETQ THCK 2))
(BITBLT NIL NIL NIL DS NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE REG)
(BITBLT NIL NIL NIL DS (IPLUS (fetch (REGION LEFT) of REG)
THCK)
(IPLUS (fetch (REGION BOTTOM) of REG)
THCK)
(IDIFFERENCE (fetch (REGION WIDTH) of REG)
(ITIMES 2 THCK))
(IDIFFERENCE (fetch (REGION HEIGHT) of REG)
(ITIMES 2 THCK))
(QUOTE TEXTURE)
(QUOTE REPLACE)
(OR TEXT (DSPTEXTURE NIL DS])
(\CLEARBM
[LAMBDA (BM TXT REG) (* bas: "21-APR-81 15:39")
(BITBLT NIL NIL NIL BM NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
(OR TXT WHITESHADE)
REG])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD BUTTON (REGION LABEL HELP))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS BITMASK MACRO ((X)
(LLSH 1 (IDIFFERENCE 15 X))))
(PUTPROPS UPDATE/BM/DISPLAY MACRO ((BM W)
(BITBLT BM (WINDOWPROP W (QUOTE DXOFFSET))
(WINDOWPROP W (QUOTE DYOFFSET))
W 0 (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM))
(WINDOWPROP W (QUOTE BMDISPLAYWIDTH))
1000 NIL (QUOTE REPLACE))))
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ DARKBITSHADE 23130)
(RPAQQ NORMALGRIDSQUARE 16)
(RPAQQ NOTINUSEGRAY 42405)
(RPAQQ EDITBMMENU NIL)
(RPAQQ EDITBMWINDOWMENU NIL)
(RPAQQ GRIDSIZEMENU NIL)
(RPAQQ CLICKWAITTIME 250)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DARKBITSHADE NORMALGRIDSQUARE NOTINUSEGRAY EDITBMMENU CLICKWAITTIME)
)
)
(DECLARE: EVAL@COMPILE
(RPAQQ GRIDTHICKNESS 2)
(RPAQQ MINGRIDSQUARE 8)
(RPAQQ MAXGRIDWIDTH 199)
(RPAQQ MAXGRIDHEIGHT 175)
(RPAQQ BMWINDOWSHADE 33410)
(CONSTANTS (GRIDTHICKNESS 2)
(MINGRIDSQUARE 8)
(MAXGRIDWIDTH 199)
(MAXGRIDHEIGHT 175)
(BMWINDOWSHADE 33410))
)
(DEFINEQ
(EXPANDBITMAP
[LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR) (* rrb " 7-DEC-82 11:53")
(* (* bas: " 5-JUN-82 01:12") expands a bitmap
WIDTHFACTOR time in the width direction and HEIGHTFACTOR
times in the height direction.)
(DECLARE (GLOBALVARS \4BITEXPANSIONTABLE))
(OR WIDTHFACTOR (SETQ WIDTHFACTOR 4))
(OR HEIGHTFACTOR (SETQ HEIGHTFACTOR 1))
(PROG (NU SCR NUH NUW (BMH (fetch BITMAPHEIGHT of BITMAP))
(BMW (fetch BITMAPWIDTH of BITMAP)))
[SETQ NU (BITMAPCREATE (SETQ NUW (ITIMES WIDTHFACTOR BMW))
(SETQ NUH (ITIMES HEIGHTFACTOR BMH]
[COND
[(EQ WIDTHFACTOR 4)
(for I from 0 to (SUB1 BMH) as C from 0 by HEIGHTFACTOR
do (\FAST4BIT (\ADDBASE (fetch BITMAPBASE of BITMAP)
(ITIMES (IDIFFERENCE BMH (ADD1 I))
(fetch BITMAPRASTERWIDTH of BITMAP)))
(\ADDBASE (fetch BITMAPBASE of NU)
(ITIMES (IDIFFERENCE (fetch BITMAPHEIGHT of NU)
(ADD1 C))
(fetch BITMAPRASTERWIDTH of NU)))
(fetch BITMAPRASTERWIDTH of NU)
\4BITEXPANSIONTABLE)
(for I to (SUB1 HEIGHTFACTOR) do (BITBLT NU 0 C NU 0 (IPLUS C I)
NUW 1 (QUOTE INPUT)
(QUOTE REPLACE]
(T (SETQ SCR 0)
(for X from 0 to (SUB1 BMW)
do (for I to WIDTHFACTOR
do (BITBLT BITMAP X 0 NU SCR 0 1 BMH (QUOTE INPUT)
(QUOTE REPLACE))
(add SCR 1)))
(SETQ SCR NUH)
(for Y from (SUB1 BMH) to 0 by -1 do (for I from 0 to (SUB1 HEIGHTFACTOR)
do (BITBLT NU 0 Y NU 0 (SETQ SCR (SUB1 SCR))
NUW 1 (QUOTE INPUT)
(QUOTE REPLACE]
(RETURN NU])
(SHRINKBITMAP
[LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR DESTINATIONBITMAP)
(* hdj "23-Jan-85 19:14")
(LET* [(WFACTOR (OR WIDTHFACTOR 4))
(HFACTOR (OR HEIGHTFACTOR 1))
(HEIGHT (BITMAPHEIGHT BITMAP))
(WIDTH (BITMAPWIDTH BITMAP))
(SCRATCH (BITMAPCREATE WIDTH (IQUOTIENT HEIGHT HFACTOR)))
(DESTINATION (OR DESTINATIONBITMAP (BITMAPCREATE (IQUOTIENT WIDTH WFACTOR)
(IQUOTIENT HEIGHT HFACTOR]
(\CLEARBM DESTINATION 0)
(for Y from 0 to (SUB1 HEIGHT) do (BITBLT BITMAP 0 Y SCRATCH 0 (IQUOTIENT Y HFACTOR)
WIDTH 1 (QUOTE INPUT)
(QUOTE PAINT)))
(for X from 0 to (SUB1 WIDTH) do (BITBLT SCRATCH X 0 DESTINATION (IQUOTIENT X WFACTOR)
0 1 HEIGHT (QUOTE INPUT)
(QUOTE PAINT)))
DESTINATION])
(\FAST4BIT
[LAMBDA (A B N MAP) (* rrb "16-May-84 16:18")
(* DECLARATIONS: (BLOCKRECORD NIBBLE
((N1 BITS 4) (N2 BITS 4) (N3 BITS 4)
(N4 BITS 4))))
(bind AW I←0 for J from 0
do (SETQ AW (\ADDBASE A J))
(OR (IGREATERP N I)
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N1 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N2 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N3 of AW)))
(OR (IGREATERP N (add I 1))
(RETURN))
(\PUTBASE B I (ELT MAP (fetch N4 of AW)))
(add I 1])
)
(READVARS \4BITEXPANSIONTABLE)
({Y16 SMALLPOSP 0 0 15 240 255 3840 3855 4080 4095 61440 61455 61680 61695 65280 65295 65520 65535 })
(PUTPROPS HLDISPLAY COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2759 15138 (GRID 2769 . 5430) (GRIDXCOORD 5432 . 5945) (GRIDYCOORD 5947 . 6464) (
LEFTOFGRIDCOORD 6466 . 6813) (BOTTOMOFGRIDCOORD 6815 . 7052) (EDITBMSCROLLFN 7054 . 14270) (
SHADEGRIDBOX 14272 . 15136)) (15190 15535 (INSIDE? 15200 . 15533)) (15569 18858 (MOUSESTATE-EXPR 15579
. 18222) (MOUSESTATE-NAME 18224 . 18856)) (21268 22192 (DECODEBUTTONS 21278 . 22190)) (22193 23081 (
PTDIFFERENCE 22203 . 22648) (PTPLUS 22650 . 23079)) (23128 46797 (GETPOSITION 23138 . 23845) (
GETBOXPOSITION 23847 . 25789) (DSPYSCREENTOWINDOW 25791 . 26136) (DSPXSCREENTOWINDOW 26138 . 26483) (
GETREGION 26485 . 32572) (\GETREGION.PACKPTS 32574 . 33089) (\GETREGION.CHECKBASEPT 33091 . 34208) (
\GETREGION.CHECKOPPT 34210 . 36049) (\GETREGIONTRACKWITHBOX 36051 . 40256) (\UPDATEXYANDBOX 40258 .
41418) (GETBOXREGION 41420 . 41943) (\TRACKWITHBOX 41945 . 44693) (MOVEBOX 44695 . 45113) (DRAWGRAYBOX
45115 . 45505) (BLTHLINE 45507 . 45789) (BLTVLINE 45791 . 46073) (SETCORNER 46075 . 46795)) (46798
48237 (MOUSECONFIRM 46808 . 48235)) (48415 49618 (NEAREST/PT/ON/GRID 48425 . 48896) (PTON10GRID 48898
. 49217) (NEAREST/MULTIPLE 49219 . 49616)) (51712 54808 (\SW2BM 51722 . 53622) (COMPOSEREGS 53624 .
54183) (TRANSLATEREG 54185 . 54806)) (54846 93502 (EDITBM 54856 . 62072) (EDITBMCLOSEFN 62074 . 62409)
(TILEAREA 62411 . 63006) (EDITBMBUTTONFN 63008 . 72464) (\EDITBM/PUTUP/DISPLAY 72466 . 72990) (
\EDITBMHOWMUCH 72992 . 73825) (EDITBMRESHAPEFN 73827 . 78201) (EDITBMREPAINTFN 78203 . 79635) (
UPDATE/SHADE/DISPLAY 79637 . 80059) (UPDATE/BM/DISPLAY/SELECTED/REGION 80061 . 81065) (SHOWBUTTON
81067 . 81545) (RESETGRID 81547 . 82334) (\READBMDIMENSIONS 82336 . 83274) (EDITSHADE 83276 . 87395) (
\BITMAPFROMTEXTURE 87397 . 87963) (EDITSHADEREPAINTFN 87965 . 89066) (GRAYBOXAREA 89068 . 89754) (
\SHADEBITS 89756 . 90819) (READHOTSPOT 90821 . 92528) (WBOX 92530 . 93277) (\CLEARBM 93279 . 93500)) (
94718 98409 (EXPANDBITMAP 94728 . 96635) (SHRINKBITMAP 96637 . 97605) (\FAST4BIT 97607 . 98407)))))
STOP