(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