(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "12-Jun-90 11:20:16" {DSK}local>lde>lispcore>library>SCALEBITMAP.;2 11772 changes to%: (VARS SCALEBITMAPCOMS) previous date%: " 1-Nov-85 17:51:44" {DSK}local>lde>lispcore>library>SCALEBITMAP.;1) (* ; " Copyright (c) 1985, 1990 by Venue & 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 . 0.81) MEANS 2.3 TIMES ORIGINAL X AXIS,  0.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 ("Venue & Xerox Corporation" 1985 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (476 11676 (SCALEBITMAP 486 . 11674))))) STOP