(FILECREATED " 1-Nov-85 17:51:44" {ERIS}<LISP>KOTO>LISPUSERS>SCALEBITMAP.;2 8104
changes to: (FNS SCALEBITMAP)
previous date: "18-Mar-85 14:34:44" {PHYLUM}<PAPERWORKS>SCALEBITMAP.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SCALEBITMAPCOMS)
(RPAQQ SCALEBITMAPCOMS ((FNS SCALEBITMAP)))
(DEFINEQ
(SCALEBITMAP
[LAMBDA (BITMAP FACTOR) (* rrb " 1-Nov-85 17:50")
(* SCALES BITMAPS BY AN ARBITRARY AMOUNT OF 2 DECIMAL PLACES. FACTOR CAN BE OF THE FOLLOWING FORMS: I
(AN INTEGER REPRESENTING A PERCENTAGE AMOUNT; E.G. I=67 MEANS REDUCE THE X AND Y AXIS TO 67% OF THEIR ORIGINAL); R
(A REAL; E.G. R=1.3 MEANS INCREASE THE X AND Y AXIS BY A FACTOR OF 1.3); (IX . IY) (A DOTTED PAIR OF INTEGERS;
E.G. (75 . 125) MEANS REDUCE THE X AXIS TO 75% OF ORIGINAL; INCREASE Y TO 125% OF ORIGINAL);
(RX . RY) (A DOTTED PAIR OF REALS; E.G. (2.3 . .81) MEANS 2.3 TIMES ORIGINAL X AXIS, .81 TIMES ORIGINAL Y))
(PROG (XFACTOR YFACTOR DELTAX DELTAY XROUND YROUND BITMAPWIDTH BITMAPHEIGHT HEIGHT-1
RASTERWIDTH BITMAPBASE NEWBITMAP NEWHEIGHT-1 NEWBITMAPWIDTH NEWBITMAPBASE
NEWRASTERWIDTH ORIGBASE NEWBASE ORIGWORD NEWWORD XSTART YSTART ENDX ENDY ONLINE)
(OR (type? BITMAP BITMAP)
(\ILLEGAL.ARG BITMAP))
(SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP))
(SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
(COND
((NUMBERP FACTOR)
(SETQ XFACTOR FACTOR)
(SETQ YFACTOR FACTOR))
((POSITIONP FACTOR)
(SETQ XFACTOR (CAR FACTOR))
(SETQ YFACTOR (CDR FACTOR)))
(T (\ILLEGAL.ARG FACTOR)))
[AND (FLOATP XFACTOR)
(SETQ XFACTOR (FIX (FTIMES XFACTOR 100]
[AND (FLOATP YFACTOR)
(SETQ YFACTOR (FIX (FTIMES YFACTOR 100]
(* I don't know why this code was in here but it causes the bitmap to scale incorrectly if it clips Y but not X;
e.g. (BITMAPHEIGHT (SCALEBITMAP (BITMAPCREATE 3 3) 10.0)) was 24 not 30.0 Therefore, I commented it out.
rrb -
1-nov-85 (PROGN (SETQ XFACTOR (IMIN SCREENWIDTH XFACTOR)) (SETQ YFACTOR (IMIN SCREENHEIGHT YFACTOR))))
(COND
((ILESSP XFACTOR 101)
(SETQ DELTAX 100)
(SETQ XROUND (IQUOTIENT XFACTOR 2)))
(T (SETQ DELTAX XFACTOR)
(SETQ XROUND 50)))
(COND
((ILESSP YFACTOR 101)
(SETQ DELTAY 100)
(SETQ YROUND (IQUOTIENT YFACTOR 2)))
(T (SETQ DELTAY YFACTOR)
(SETQ YROUND 50)))
(SETQ NEWBITMAP (BITMAPCREATE (SETQ NEWBITMAPWIDTH
(IQUOTIENT (IPLUS XROUND DELTAX
(ITIMES (SUB1 BITMAPWIDTH)
XFACTOR))
100))
(IQUOTIENT (IPLUS YROUND DELTAY
(ITIMES (SUB1 BITMAPHEIGHT)
YFACTOR))
100)
1)) (* MAKE ALL VALUES QUICKLY AVAILABLE)
(SETQ HEIGHT-1 (SUB1 BITMAPHEIGHT))
(SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))
(SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of BITMAP))
(* AND THE NEW BITMAP VALUES)
(SETQ NEWHEIGHT-1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of NEWBITMAP)))
(SETQ NEWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of NEWBITMAP))
(SETQ NEWBITMAPBASE (fetch (BITMAP BITMAPBASE) of NEWBITMAP))
(* OK, CRANK IT OUT)
(* ORIGWORD AND NEWWORD ARE SORTA CACHED FOR SPEED
PURPOSES)
[for Y from 0 to HEIGHT-1
do [SETQ ORIGBASE (\ADDBASE BITMAPBASE (ITIMES RASTERWIDTH (IDIFFERENCE
HEIGHT-1 Y]
(SETQ ONLINE NIL)
[for X from 0 to (SUB1 BITMAPWIDTH)
do [AND (ZEROP (IMOD X 16))
(SETQ ORIGWORD (\GETBASE ORIGBASE (LRSH X 4]
(* LOOK FOR STRINGS OF "ON" BITS;
THEN TREAT AS A LINE FOR TRANSLATIONAL PURPOSES)
(COND
[(BITTEST ORIGWORD (\WORDELT BITMASKARRAY (IMOD X 16)))
(OR ONLINE (AND (SETQ ONLINE T)
(SETQ XSTART X)
(SETQ YSTART Y]
((NULL ONLINE) (* JUST SKIP OVER BLANKS)
)
(T (* SPELL THIS ALL OUT SO I CAN SEE WHAT'S GOIN' ON
HERE)
(SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR)
)
100))
(SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR)
YROUND DELTAY)
100))
(SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR)
)
100))
[SETQ ENDX (COND
((GREATERP XFACTOR 100)
(* Subtract the 1 differently depending on whether the
size is going up or down.)
(SUB1 (IQUOTIENT (IPLUS XROUND (ITIMES X XFACTOR))
100)))
(T (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 X)
XFACTOR))
100]
(for NY from YSTART to (SUB1 ENDY)
do (SETQ NEWWORD (\GETBASE [SETQ NEWBASE
(\ADDBASE
NEWBITMAPBASE
(ITIMES NEWRASTERWIDTH
(IDIFFERENCE
NEWHEIGHT-1 NY]
(LRSH XSTART 4)))
(for NX from XSTART to ENDX
do [AND (ZEROP (IMOD NX 16))
(SETQ NEWWORD (\GETBASE NEWBASE
(LRSH NX 4]
[SETQ NEWWORD (LOGOR NEWWORD
(\WORDELT BITMASKARRAY
(IMOD NX 16]
(AND (ZEROP (IMOD (ADD1 NX)
16))
(\PUTBASE NEWBASE (LRSH NX 4)
NEWWORD)))
(\PUTBASE NEWBASE (LRSH ENDX 4)
NEWWORD))
(SETQ ONLINE NIL]
(COND
(ONLINE (* GOTTA CLEANUP AFTER THE LAST CASE)
(* THIS IN CASE WORKING ON A LINE THAT GOES TO END OF
BITMAP)
(* GAWD! WHAT A WASTE O SPACE THIS IS.
FIX LATER)
(SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR))
100))
(SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR)
YROUND DELTAY)
100))
(SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR))
100))
(SETQ ENDX (SUB1 NEWBITMAPWIDTH))
(for NY from YSTART to (SUB1 ENDY)
do (SETQ NEWWORD (\GETBASE [SETQ NEWBASE
(\ADDBASE NEWBITMAPBASE
(ITIMES
NEWRASTERWIDTH
(IDIFFERENCE
NEWHEIGHT-1 NY]
(LRSH XSTART 4)))
(for NX from XSTART to ENDX
do [AND (ZEROP (IMOD NX 16))
(SETQ NEWWORD (\GETBASE NEWBASE
(LRSH NX 4]
[SETQ NEWWORD (LOGOR NEWWORD
(\WORDELT BITMASKARRAY
(IMOD NX 16]
(AND (ZEROP (IMOD (ADD1 NX)
16))
(\PUTBASE NEWBASE (LRSH NX 4)
NEWWORD)))
(\PUTBASE NEWBASE (LRSH ENDX 4)
NEWWORD]
(RETURN NEWBITMAP])
)
(PUTPROPS SCALEBITMAP COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (358 8022 (SCALEBITMAP 368 . 8020)))))
STOP