(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")

(FILECREATED "13-Oct-87 16:32:42" |{ABLAGE2:49/89/636/13:SIEMENS AG}<DVSLISP>TOOLS>CANVASCONVERTER.;4|
        

      |previous| |date:| " 7-Sep-87 11:16:38" 
|{ABLAGE2:49/89/636/13:SIEMENS AG}<DVSLISP>TOOLS>CANVASCONVERTER.;2|)


; Copyright (c) 1987 by Steve Knowles.  All rights reserved.

(PRETTYCOMPRINT CANVASCONVERTERCOMS)

(RPAQQ CANVASCONVERTERCOMS
 ((FNS FETCHCANVAS VECLENGTH CALCULATEBYTES CALCULATEWIDTHBYTES 
                                 CANVAS-FROM-WINDOW CALCULATEHEIGHTFACTOR1 CALCULATEHEIGHTFACTOR2 
                                 CALCULATEWIDTHFACTOR1 CALCULATEWIDTHFACTOR2 WRITECANVAS SNAPBM)
                            (VARS BYTESPERWORD)
                            (FILES BITMAPFNS)))
(DEFINEQ

(FETCHCANVAS

  (LAMBDA (|file|)
                                           (* |edited:| " 9-Dec-86 17:59")

                                                             (* |created| |by:| |Giselbert| 

                                                             |Schramm|)

                                                             (* |Departement:| ZT ZTI SOF 232)

                                                             (* |Creation| |Date:| "20-Jun-86 20:16")

          
          (* * |Reads| |the| |width| |and| |heigth| |of| |the| |bitmap| |in| \a |given| 

          |Canvas-file,| |extracts| |the| |bitmap| |using| |the| READBINARYBITMAP 

          |function| |and| |returns| |the| |bitmap| |as| \a |result|)


    (PROG (|saveinput| |bmwidth| |bmhigth| |result|)
          (SETQ |saveinput| (INFILE |file|))
          (SETFILEPTR |file| 56)
          (PRINT (CONCAT "FILEPTR >  " (GETFILEPTR |file|))
                 PROMPTWINDOW)
          (SETQ |bmwidth| (IDIFFERENCE (IPLUS (ITIMES (BIN)
                                                     256)
                                              (BIN))
                                 4000))
          (PRINT (CONCAT "FILEPTR >  " (GETFILEPTR |file|))
                 PROMPTWINDOW)
          (SETQ |bmhigth| (IDIFFERENCE (IPLUS (ITIMES (BIN)
                                                     256)
                                              (BIN))
                                 4000))
          (PRINT (CONCAT "FILEPTR >  " (GETFILEPTR |file|))
                 PROMPTWINDOW)
          (PRINT (CONCAT "width: " |bmwidth| " heigth: " |bmhigth|)
                 PROMPTWINDOW)
          (SETFILEPTR |file| (IPLUS (GETFILEPTR |file|)
                                    32))
          (PRINT (CONCAT "FILEPTR >  " (GETFILEPTR |file|))
                 PROMPTWINDOW)
          (SETQ |result| (READBINARYBITMAP |bmwidth| |bmhigth|))
          (INPUT |saveinput|)
          (CLOSEF |file|)
          (RETURN |result|))))

(VECLENGTH

  (LAMBDA (WIDTH HEIGHT)                                     (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:38")

                                                             (* (VECLENGTH 192 174) |edited:| 

                                                             "13-Aug-87 14:28")

    (IPLUS 4 (IQUOTIENT (ITIMES HEIGHT (ITIMES (IQUOTIENT (IPLUS WIDTH 31)
                                                      32)
                                              32))
                    8))))

(CALCULATEBYTES

  (LAMBDA (N)                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:38")

    (SETQ FIRSTBYTE (IQUOTIENT N 65536))
    (SETQ SECONDBYTE (IQUOTIENT (IMOD N 65536)
                            256))
    (SETQ THIRDBYTE (IMOD N 256))))

(CALCULATEWIDTHBYTES

  (LAMBDA NIL                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:38")

    (SETQ FIRSTWIDTHBYTE (IQUOTIENT BMWIDTH 256))
    (SETQ SECONDWIDTHBYTE (IMOD BMWIDTH 256))))

(CANVAS-FROM-WINDOW

  (LAMBDA (WINDOW FILE)
                                      (* |edited:| "26-Aug-87 12:02")

    (LET* ((WINDOWREGION (WINDOWPROP WINDOW 'REGION))
           (HEIGHT (CADDDR WINDOWREGION))
           (WIDTH (CADDR WINDOWREGION))
           (COPYBITMAP (BITMAPCREATE WIDTH HEIGHT)))
          (BITBLT WINDOW 0 0 COPYBITMAP)
          (WRITECANVAS
 COPYBITMAP FILE))))

(CALCULATEHEIGHTFACTOR1

  (LAMBDA NIL                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:37")

    (QUOTIENT (PLUS BMHEIGHT 4000)
           256)))

(CALCULATEHEIGHTFACTOR2

  (LAMBDA NIL                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:37")

    (DIFFERENCE (PLUS BMHEIGHT 4000)
           (TIMES (QUOTIENT (PLUS BMHEIGHT 4000)
                         256)
                  256))))

(CALCULATEWIDTHFACTOR1

  (LAMBDA NIL                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:37")

    (QUOTIENT (PLUS BMWIDTH 4000)
           256)))

(CALCULATEWIDTHFACTOR2

  (LAMBDA NIL                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:37")

    (DIFFERENCE (PLUS BMWIDTH 4000)
           (TIMES (QUOTIENT (PLUS BMWIDTH 4000)
                         256)
                  256))))

(WRITECANVAS

  (LAMBDA (BITMAP FILE)                                      (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 11:13")

                                                             (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:35")

    (PROG (COPYBITMAP BMHEIGHT BMWIDTH HEIGHTFACTOR1 HEIGHTFACTOR2 WIDTHFACTOR1 WIDTHFACTOR2 OUTFILE 
                 FIRSTBYTE SECONDBYTE THIRDBYTE FIRSTWIDTHBYTE SECONDWIDTHBYTE)
          (SETQ BMHEIGHT (BITMAPHEIGHT BITMAP))
          (SETQ BMWIDTH (BITMAPWIDTH BITMAP))
          (SETQ COPYBITMAP (BITMAPCREATE (ITIMES (IQUOTIENT (IPLUS BMWIDTH 31)
                                                        32)
                                                32)
                                  BMHEIGHT))
          (BITBLT BITMAP 0 0 COPYBITMAP)
          (SETQ HEIGHTFACTOR1 (CALCULATEHEIGHTFACTOR1
))
          (SETQ HEIGHTFACTOR2 (CALCULATEHEIGHTFACTOR2
))
          (SETQ WIDTHFACTOR1 (CALCULATEWIDTHFACTOR1
))
          (SETQ WIDTHFACTOR2 (CALCULATEWIDTHFACTOR2
))
          (CALCULATEBYTES
 (VECLENGTH
 BMWIDTH BMHEIGHT))
          (CALCULATEWIDTHBYTES
)
          (SETQ OUTFILE (OPENSTREAM FILE 'OUTPUT))
          (|for|
 I
             |in|
 '(73 110 116 101 114 112 114 101 115 115 47 88 101 114 111 120 47 50 46 49 47 82 97 
                       115 116 101 114 69 110 99 111 100 105 110 103 47 49 46 48 32 160 102 196 6 0 0 
                       254 10 252 128 160 181 15 162 161 27) |do|
 (BOUT OUTFILE I))
          (BOUT OUTFILE WIDTHFACTOR1)
          (BOUT OUTFILE WIDTHFACTOR2)
          (BOUT OUTFILE HEIGHTFACTOR1)
          (BOUT OUTFILE HEIGHTFACTOR2)
          (BOUT OUTFILE 15)
          (BOUT OUTFILE 160)
          (BOUT OUTFILE HEIGHTFACTOR1)
          (BOUT OUTFILE HEIGHTFACTOR2)
          (BOUT OUTFILE WIDTHFACTOR1)
          (BOUT OUTFILE WIDTHFACTOR2)
          (|for|
 I |in|
 '(15 161 15 161 15 160 15 70 160 163 15 160) |do|
 (BOUT OUTFILE I))
          (BOUT OUTFILE HEIGHTFACTOR1)
          (BOUT OUTFILE HEIGHTFACTOR2)
          (|for|
 I |in|
 '(160 162 160 165 233) |do|
 (BOUT OUTFILE I))
          (BOUT OUTFILE FIRSTBYTE)
          (BOUT OUTFILE SECONDBYTE)
          (BOUT OUTFILE THIRDBYTE)
          (BOUT OUTFILE 0)
          (BOUT OUTFILE 1)
          (BOUT OUTFILE FIRSTWIDTHBYTE)
          (BOUT OUTFILE SECONDWIDTHBYTE)
          (WRITEBINARYBITMAP COPYBITMAP OUTFILE)
          (|for|
 I
             |in|
 '(161 194 15 160 15 161 15 160 15 163 161 27 197 5 120 101 114 111 120 197 10 71 
                        114 97 121 76 105 110 101 97 114 15 162 161 27 161 166 160 231 197 4 110 97 
                        109 101 193 10 66 105 103 65 80 83 73 99 111 110 197 12 99 114 101 97 116 105 
                        111 110 84 105 109 101 193 25 49 57 56 55 32 48 56 32 48 51 32 49 53 58 52 55 
                        58 50 51 45 48 53 58 48 48 15 164 161 27 66 190 160 103)
             |do|
 (BOUT OUTFILE I))
          (CLOSEF OUTFILE)
          (SETFILEINFO FILE 'TYPE 4428)
          (RETURN "Canvas has been written."))))

(SNAPBM

  (LAMBDA NIL                                                (* 

                                                             "edited by Steve Knowles, Siemens AG:" 

                                                             " 7-Sep-87 10:36")

    (PROG (BM REG)
          (SETQ REG (GETREGION))
          (SETQ BM (BITMAPCREATE (|fetch|
 WIDTH |of|
 REG)
                          (|fetch|
 HEIGHT |of|
 REG)))
          (BITBLT (SCREENBITMAP)
                 (|fetch|
 LEFT |of|
 REG)
                 (|fetch|
 BOTTOM |of|
 REG)
                 BM)
          (RETURN BM))))
)

(RPAQQ BYTESPERWORD
 2)
(FILESLOAD BITMAPFNS)
(PUTPROPS CANVASCONVERTER COPYRIGHT ("Steve Knowles" 1987))
STOP