HARDCOPY and IMAGEIO: major architectural changes for imagefile types and printing
This commit is contained in:
rmkaplan
840
sources/HARDCOPY
840
sources/HARDCOPY
File diff suppressed because it is too large
Load Diff
Binary file not shown.
421
sources/IMAGEIO
421
sources/IMAGEIO
@@ -1,23 +1,36 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "12-Dec-2025 23:14:50" {WMEDLEY}<sources>IMAGEIO.;26 82764
|
||||
(FILECREATED "28-Dec-2025 17:57:56" {WMEDLEY}<sources>IMAGEIO.;36 97264
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS IMAGEIOCOMS)
|
||||
(FNS IMAGETYPE.BITMAPSCALE IMAGETYPE.BITMAPFILE)
|
||||
(FNS HTMLFILEP)
|
||||
|
||||
:PREVIOUS-DATE " 7-Dec-2025 16:27:20" {WMEDLEY}<sources>IMAGEIO.;25)
|
||||
:PREVIOUS-DATE "25-Dec-2025 09:09:03" {WMEDLEY}<sources>IMAGEIO.;34)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT IMAGEIOCOMS)
|
||||
|
||||
(RPAQQ IMAGEIOCOMS
|
||||
[(FNS OPENIMAGESTREAM)
|
||||
(FNS IMAGESTREAMP IMAGESTREAMTYPE IMAGESTREAMTYPEP IMAGEFILETYPE IMAGEFILEPROP)
|
||||
(FNS IMAGESTREAMP IMAGESTREAMTYPE IMAGESTREAMTYPEP IMAGEFILEPROP IMAGESOURCEFILEP
|
||||
IMAGESOURCETYPE)
|
||||
(FNS EXTENSIONS.FOR.IMAGEFILETYPE IMAGEFILETYPE.FROM.EXTENSION)
|
||||
(FNS CONVERT.TO.IMAGEFILE)
|
||||
(FNS IMAGETYPE.BITMAPSCALE IMAGETYPE.BITMAPFILE)
|
||||
(FNS BITMAPFILEP BITMAP.TO.BITMAPFILE BITMAPFILE.TO.BITMAP BITMAPFILE.TO.IMAGEFILE)
|
||||
(FNS BITMAP.TO.IMAGEFILE WINDOW.TO.IMAGEFILE SCREENREGION.TO.IMAGEFILE COPY.WINDOW.TO.BITMAP)
|
||||
(COMS (INITVARS (PRINTFILETYPES NIL))
|
||||
(GLOBALVARS PRINTFILETYPES)
|
||||
(FNS DEFAULT.IMAGETYPE.CONVERSIONS)
|
||||
[P (DEFAULT.IMAGETYPE.CONVERSIONS '(BITMAP BITMAP.TO.IMAGEFILE WINDOW
|
||||
WINDOW.TO.IMAGEFILE SCREENREGION
|
||||
SCREENREGION.TO.IMAGEFILE BITMAPFILE
|
||||
BITMAPFILE.TO.IMAGEFILE]
|
||||
(ALISTS (PRINTFILETYPES BITMAP WINDOW SCREENREGION BITMAPFILE)))
|
||||
(COMS (* ; "Until HTML streams")
|
||||
(ALISTS (PRINTFILETYPES HMTL))
|
||||
(FNS HTMLFILEP))
|
||||
(INITVARS (IMAGESTREAMTYPES NIL))
|
||||
(FNS \GOOD.DASHLST)
|
||||
(FNS DRAWDASHEDLINE)
|
||||
@@ -128,27 +141,42 @@
|
||||
of (fetch (STREAM IMAGEOPS)
|
||||
of S])
|
||||
|
||||
(IMAGEFILETYPE
|
||||
[LAMBDA (FILE) (* ; "Edited 28-Sep-2025 11:35 by rmk")
|
||||
(IMAGEFILEPROP
|
||||
[LAMBDA (IMAGEFILETYPE PROP) (* ; "Edited 19-Dec-2025 10:48 by rmk")
|
||||
(* ; "Edited 29-Oct-2025 13:32 by rmk")
|
||||
(LET [(VAL (CAR (GETMULTI PRINTFILETYPES IMAGEFILETYPE PROP]
|
||||
(if (NULL VAL)
|
||||
then (CAR (GETMULTI PRINTFILETYPES 'DEFAULT PROP))
|
||||
elseif (LISTP VAL)
|
||||
then (APPEND VAL (CAR (GETMULTI PRINTFILETYPES 'DEFAULT PROP)))
|
||||
else VAL])
|
||||
|
||||
(IMAGESOURCEFILEP
|
||||
[LAMBDA (IMAGESOURCE) (* ; "Edited 23-Dec-2025 15:38 by rmk")
|
||||
(AND IMAGESOURCE (OR (STRINGP IMAGESOURCE)
|
||||
(LITATOM IMAGESOURCE)
|
||||
(CL:PATHNAMEP IMAGESOURCE])
|
||||
|
||||
(IMAGESOURCETYPE
|
||||
[LAMBDA (X) (* ; "Edited 24-Dec-2025 14:38 by rmk")
|
||||
(* ; "Edited 20-Dec-2025 14:07 by rmk")
|
||||
(* ; "Edited 28-Sep-2025 11:35 by rmk")
|
||||
(* ; "Edited 18-Sep-2025 11:13 by rmk")
|
||||
(* ; "Edited 13-Sep-2025 23:36 by rmk")
|
||||
(* ; "Edited 3-Mar-93 14:34 by rmk:")
|
||||
(* ; "Edited 22-Aug-92 14:27 by jds")
|
||||
(* ; "Edited 26-Aug-87 14:22 by Snow")
|
||||
(if (IMAGESTREAMP FILE)
|
||||
then (IMAGESTREAMTYPE FILE)
|
||||
elseif (CAR (find ITYPE TESTFN in PRINTFILETYPES when [SETQ TESTFN (CAR (GETMULTI ITYPE
|
||||
(if (WINDOWP X)
|
||||
then (OR (WINDOWPROP X 'IMAGETYPE)
|
||||
'WINDOW)
|
||||
elseif [CAR (find ITYPE TESTFN in PRINTFILETYPES when [SETQ TESTFN (CAR (GETMULTI ITYPE
|
||||
'TEST]
|
||||
suchthat (APPLY* TESTFN FILE)))
|
||||
elseif (LISPSOURCEFILEP FILE)
|
||||
suchthat (CAR (NLSETQ (APPLY* TESTFN X]
|
||||
elseif (IMAGESTREAMP X)
|
||||
then (IMAGESTREAMTYPE X)
|
||||
elseif (LISPSOURCEFILEP X)
|
||||
then 'TEXT
|
||||
else (GETFILEINFO FILE 'TYPE])
|
||||
|
||||
(IMAGEFILEPROP
|
||||
[LAMBDA (IMAGEFILETYPE PROP) (* ; "Edited 29-Oct-2025 13:32 by rmk")
|
||||
(* ; "Edited 26-Aug-87 14:22 by Snow")
|
||||
(for X in PRINTFILETYPES when (EQMEMB IMAGEFILETYPE (CAR X))
|
||||
do (RETURN (CADR (ASSOC PROP (CDR X])
|
||||
else (GETFILEINFO X 'TYPE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -171,7 +199,11 @@
|
||||
(DEFINEQ
|
||||
|
||||
(CONVERT.TO.IMAGEFILE
|
||||
[LAMBDA (FILE IMAGEFILE IMAGETYPE OPTIONS NOERROR) (* ; "Edited 2-Nov-2025 08:53 by rmk")
|
||||
[LAMBDA (IMAGESOURCE IMAGEFILE IMAGEFILETYPE OPTIONS NOERROR)
|
||||
(* ; "Edited 25-Dec-2025 09:08 by rmk")
|
||||
(* ; "Edited 21-Dec-2025 09:02 by rmk")
|
||||
(* ; "Edited 13-Dec-2025 11:46 by rmk")
|
||||
(* ; "Edited 2-Nov-2025 08:53 by rmk")
|
||||
(* ; "Edited 29-Oct-2025 13:33 by rmk")
|
||||
(* ; "Edited 26-Sep-2025 23:46 by rmk")
|
||||
(* ; "Edited 20-Sep-2025 12:57 by rmk")
|
||||
@@ -183,50 +215,283 @@
|
||||
|
||||
(* ;; "If this is the result of (COPYFILE 'XXX {LPT}), then XXX (e.g. a Tedit file) has already been copied once, to the LPT device, where it has lost its original identity. PRINTERDEVICE.CLOSEFN calls SEND.FILE.TO.PRINTER, which calls this to apply the (e.g. Tedit) conversion method for the imagetype of this PRINTERTYPE. In that case there is no reason for the conversion function to print the name of its target image stream")
|
||||
|
||||
(CL:UNLESS (STREAMP FILE)
|
||||
(SETQ FILE (FINDFILE FILE T)))
|
||||
(CL:WHEN (IMAGESOURCEFILEP IMAGESOURCE)
|
||||
(SETQ IMAGESOURCE (FINDFILE IMAGESOURCE T)))
|
||||
[if NOERROR
|
||||
then (push OPTIONS 'NOERROR T)
|
||||
else (SETQ NOERROR (LISTGET OPTIONS 'NOERROR]
|
||||
(SETQ IMAGEFILE (if (STREAMP IMAGEFILE)
|
||||
elseif IMAGEFILE
|
||||
then (PACKFILENAME 'BODY IMAGEFILE 'EXTENSION IMAGETYPE)
|
||||
elseif (OR (NULL IMAGEFILE)
|
||||
(STREAMP (FULLNAME FILE)))
|
||||
then (OPENSTREAM '{NODIRCORE} 'OUTPUT)
|
||||
else (PACKFILENAME 'VERSION NIL 'EXTENSION IMAGETYPE 'BODY FILE)))
|
||||
(LET ((FILETYPE (IMAGEFILETYPE FILE))
|
||||
(CL:WHEN (AND (NULL IMAGEFILETYPE)
|
||||
(LISTP IMAGEFILE))
|
||||
(SETQ IMAGEFILETYPE (CDR IMAGEFILE))
|
||||
(SETQ IMAGEFILE (CAR IMAGEFILE)))
|
||||
(CL:UNLESS IMAGEFILETYPE (* ;
|
||||
"maybe we can get it from the filename")
|
||||
(SETQ IMAGEFILETYPE (IMAGESOURCETYPE IMAGEFILE)))
|
||||
(LET ((SOURCETYPE (IMAGESOURCETYPE IMAGESOURCE))
|
||||
CONVERTED CFN)
|
||||
|
||||
(* ;; "The conversion function may abandon the IMAGEFILE we provide and create its own.")
|
||||
|
||||
(if [AND (SETQ CFN (LISTGET (IMAGEFILEPROP IMAGETYPE 'CONVERSION)
|
||||
FILETYPE))
|
||||
(SETQ CONVERTED (CAR (NLSETQ (APPLY* CFN FILE IMAGEFILE IMAGETYPE OPTIONS]
|
||||
then (CLOSEF? CONVERTED)
|
||||
CONVERTED
|
||||
elseif NOERROR
|
||||
then NIL
|
||||
else (ERROR (CONCAT "Can't convert " FILETYPE " file to " IMAGETYPE)
|
||||
(FULLNAME FILE])
|
||||
(if (EQ IMAGEFILETYPE SOURCETYPE)
|
||||
then
|
||||
(* ;; "Already have what we want")
|
||||
|
||||
IMAGESOURCE
|
||||
else
|
||||
(* ;; "if IMAGEFILE is NIL, we don't necessarily want to construct a name instead of a stream from the IMAGESOURCE. foo.BM would give us foo.PDF instead of NODIRCORE.")
|
||||
|
||||
[SETQ IMAGEFILE (if (STREAMP IMAGEFILE)
|
||||
elseif IMAGEFILE
|
||||
then (PACKFILENAME 'BODY IMAGEFILE 'EXTENSION
|
||||
(OR (CAR (EXTENSIONS.FOR.IMAGEFILETYPE IMAGEFILETYPE)
|
||||
)
|
||||
IMAGEFILETYPE))
|
||||
else (OPENSTREAM '{NODIRCORE} 'OUTPUT]
|
||||
(if [AND (SETQ CFN (OR (LISTGET (IMAGEFILEPROP IMAGEFILETYPE 'CONVERSION)
|
||||
SOURCETYPE)
|
||||
(LISTGET (IMAGEFILEPROP 'DEFAULT 'CONVERSION)
|
||||
SOURCETYPE)))
|
||||
(SETQ CONVERTED (CAR (NLSETQ (APPLY* CFN IMAGESOURCE IMAGEFILE IMAGEFILETYPE
|
||||
OPTIONS]
|
||||
then (CL:WHEN (STREAMP CONVERTED) (* ; "Can't tell from the name")
|
||||
(STREAMPROP CONVERTED 'IMAGETYPE IMAGEFILETYPE))
|
||||
(CLOSEF? CONVERTED)
|
||||
CONVERTED
|
||||
elseif NOERROR
|
||||
then NIL
|
||||
else (ERROR (CONCAT "Can't convert " SOURCETYPE " file to " IMAGEFILETYPE)
|
||||
IMAGESOURCE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(IMAGETYPE.BITMAPSCALE
|
||||
[LAMBDA (WIDTH HEIGHT IMAGETYPE) (* ; "Edited 12-Dec-2025 23:06 by rmk")
|
||||
(* ; "Edited 26-Aug-87 14:19 by Snow")
|
||||
(LET [(FN (IMAGEFILEPROP IMAGETYPE 'BITMAPSCALE]
|
||||
(CL:IF FN
|
||||
(APPLY* FN WIDTH HEIGHT)
|
||||
1)])
|
||||
(BITMAPFILEP
|
||||
[LAMBDA (FILE) (* ; "Edited 23-Dec-2025 15:28 by rmk")
|
||||
(* ; "Edited 19-Dec-2025 10:56 by rmk")
|
||||
|
||||
(IMAGETYPE.BITMAPFILE
|
||||
[LAMBDA (FILE IMAGETYPE BITMAP SCALEFACTOR REGION ROTATION TITLE)
|
||||
(* ; "Edited 12-Dec-2025 23:04 by rmk")
|
||||
(* ; "Edited 26-Aug-87 14:19 by Snow")
|
||||
(* ; "convert a bitmap into a file")
|
||||
(DECLARE (SPECVARS . T))
|
||||
(EVAL (IMAGEFILEPROP IMAGETYPE 'BITMAPFILE])
|
||||
(* ;; "True if FILE is a file containing a single bitmap.")
|
||||
|
||||
(CL:WHEN
|
||||
[AND FILE
|
||||
(OR (EQ 'BITMAPFILE (IMAGEFILETYPE.FROM.EXTENSION FILE))
|
||||
(EQ 'BITMAP (OR (RESETLST
|
||||
[LET ((STREAM (GETSTREAM FILE 'INPUT T)))
|
||||
[if STREAM
|
||||
then [RESETSAVE (GETFILEPTR FILE)
|
||||
`(PROGN (SETFILEPTR ,FILE OLDVALUE]
|
||||
else (RESETSAVE (SETQ STREAM (OPENSTREAM (CL:IF
|
||||
(STREAMP FILE)
|
||||
(FULLNAME
|
||||
FILE)
|
||||
FILE)
|
||||
'INPUT))
|
||||
`(PROGN (CLOSEF? OLDVALUE]
|
||||
(CAR (NLSETQ (RATOM FILE (FIND-READTABLE "INTERLISP"])]
|
||||
'BITMAPFILE])
|
||||
|
||||
(BITMAP.TO.BITMAPFILE
|
||||
[LAMBDA (BITMAP IMAGEFILE REGION) (* ; "Edited 20-Dec-2025 23:29 by rmk")
|
||||
(* ; "Edited 19-Dec-2025 17:51 by rmk")
|
||||
(CL:WHEN (WINDOWP BITMAP)
|
||||
(SETQ BITMAP (COPY.WINDOW.TO.BITMAP BITMAP)))
|
||||
(CL:UNLESS IMAGEFILE
|
||||
(SETQ IMAGEFILE (OPENSTREAM '{NODIRCORE} 'OUTPUT)))
|
||||
(RESETLST
|
||||
(LET ((STREAM (GETSTREAM IMAGEFILE 'OUTPUT T))
|
||||
(*READTABLE* (FIND-READTABLE "INTERLISP"))
|
||||
SUBBITMAP)
|
||||
(CL:UNLESS STREAM
|
||||
[RESETSAVE (SETQ STREAM (OPENSTREAM [PACKFILENAME 'BODY IMAGEFILE 'EXTENSION
|
||||
(CAR (EXTENSIONS.FOR.IMAGEFILETYPE
|
||||
'BITMAPFILE]
|
||||
'OUTPUT))
|
||||
`(PROGN (CLOSEF? OLDVALUE])
|
||||
(CL:WHEN REGION
|
||||
(SETQ SUBBITMAP (BITMAPCREATE (fetch (REGION WIDTH) of REGION)
|
||||
(fetch (REGION HEIGHT) of REGION)
|
||||
(BITSPERPIXEL BITMAP)))
|
||||
(BITBLT BITMAP (fetch (REGION LEFT) of REGION)
|
||||
(fetch (REGION BOTTOM) of REGION)
|
||||
SUBBITMAP 0 0 (fetch (REGION WIDTH) of REGION)
|
||||
(fetch (REGION HEIGHT) of REGION)))
|
||||
(PRINT 'BITMAP STREAM)
|
||||
(\PRINTBINARYBITMAP (OR SUBBITMAP BITMAP)
|
||||
STREAM)
|
||||
(CLOSEF? STREAM)))])
|
||||
|
||||
(BITMAPFILE.TO.BITMAP
|
||||
[LAMBDA (FILE) (* ; "Edited 19-Dec-2025 11:00 by rmk")
|
||||
(CL:UNLESS (BITMAPFILEP FILE)
|
||||
(ERROR FILE "is not a bitmap file"))
|
||||
(RESETLST
|
||||
(LET ((STREAM (GETSTREAM FILE 'INPUT T))
|
||||
(*READTABLE* (FIND-READTABLE "INTERLISP")))
|
||||
(CL:UNLESS STREAM
|
||||
[RESETSAVE (SETQ STREAM (OPENSTREAM (FULLNAME FILE)
|
||||
'INPUT))
|
||||
`(PROGN (CLOSEF? OLDVALUE])
|
||||
(RATOM STREAM)
|
||||
(READCCODE STREAM)
|
||||
(\READBINARYBITMAP STREAM)))])
|
||||
|
||||
(BITMAPFILE.TO.IMAGEFILE
|
||||
[LAMBDA (BMFILE IMAGEFILE IMAGETYPE OPTIONS) (* ; "Edited 20-Dec-2025 23:18 by rmk")
|
||||
(BITMAP.TO.IMAGEFILE (BITMAPFILE.TO.BITMAP BMFILE)
|
||||
IMAGEFILE IMAGETYPE OPTIONS])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(BITMAP.TO.IMAGEFILE
|
||||
[LAMBDA (BITMAP IMAGEFILE IMAGEFILETYPE OPTIONS) (* ; "Edited 23-Dec-2025 15:40 by rmk")
|
||||
(* ; "Edited 18-Dec-2025 23:32 by rmk")
|
||||
|
||||
(* ;; "Render BITMAP in IMAGEFILE of type IMAGETYPE")
|
||||
|
||||
(DECLARE (SPECVARS T))
|
||||
(LET [(SCALEFACTOR (LISTGET OPTIONS 'SCALEFACTOR))
|
||||
(REGION (LISTGET OPTIONS 'REGION))
|
||||
(ROTATION (LISTGET OPTIONS 'ROTATION))
|
||||
(TITLE (LISTGET OPTIONS 'TITLE]
|
||||
(DECLARE (SPECVARS . T))
|
||||
(CL:UNLESS SCALEFACTOR
|
||||
[LET [(FN (IMAGEFILEPROP IMAGEFILETYPE 'BITMAPSCALE]
|
||||
(SETQ SCALEFACTOR (if (NOT FN)
|
||||
then 1
|
||||
elseif REGION
|
||||
then (APPLY* FN (fetch (REGION WIDTH) of REGION)
|
||||
(fetch (REGION HEIGHT) of REGION)
|
||||
IMAGEFILETYPE)
|
||||
else (APPLY* FN (fetch (BITMAP BITMAPWIDTH) of BITMAP)
|
||||
(fetch (BITMAP BITMAPHEIGHT) of BITMAP)
|
||||
IMAGEFILETYPE])
|
||||
(CL:WHEN (LISTP SCALEFACTOR)
|
||||
(SETQ ROTATION (CDR SCALEFACTOR))
|
||||
(SETQ SCALEFACTOR (CAR SCALEFACTOR)))
|
||||
(EVAL (IMAGEFILEPROP IMAGEFILETYPE 'BITMAPFILE])
|
||||
|
||||
(WINDOW.TO.IMAGEFILE
|
||||
[LAMBDA (WINDOW IMAGEFILE IMAGETYPE OPTIONS) (* ; "Edited 24-Dec-2025 07:57 by rmk")
|
||||
(* ; "Edited 19-Dec-2025 18:20 by rmk")
|
||||
(* ; "Edited 3-Nov-2025 16:10 by rmk")
|
||||
(* ; "Edited 29-Sep-2025 23:54 by rmk")
|
||||
(* ; "Edited 19-Sep-2025 17:09 by rmk")
|
||||
(* ; "Edited 26-Nov-96 15:59 by rmk:")
|
||||
(* ; "Edited 13-Nov-87 14:16 by Snow")
|
||||
|
||||
(* ;; "Either run window's HARDCOPYFN or produce a bitmap file. The HARDCOPYFN can be a list of the form (fn heading) where heading=TITLE means use the window's title, otherwise using the non-nil heading.")
|
||||
|
||||
(* ;; "If there is a hardcopy")
|
||||
|
||||
(* ;;
|
||||
"The information put in IMAGEFILE comes from WINDOW via the HARDCOPYFN, or the bitmap if no fn. ")
|
||||
|
||||
(* ;; "Value is the completed IMAGEFILE.")
|
||||
|
||||
(* ;; "Note: if the window has an IMAGETYPE property (e.g. TEDIT), then conversion to IMAGETYPE is handled by the appropriate entry on PRINTFILETYPES.")
|
||||
|
||||
(CL:WHEN IMAGEFILE
|
||||
(CL:WHEN (AND (LISTP IMAGEFILE)
|
||||
(NULL IMAGETYPE))
|
||||
(SETQ IMAGETYPE (CDR IMAGEFILE))
|
||||
(SETQ IMAGEFILE (CAR IMAGEFILE)))
|
||||
(LET ((HARDCOPYFN (WINDOWPROP WINDOW 'HARDCOPYFN))
|
||||
HEADING)
|
||||
(if (NULL HARDCOPYFN)
|
||||
then (* ; "knows how to default")
|
||||
(CL:WHEN (EQ 'TITLE (LISTGET OPTIONS 'HEADING))
|
||||
[SETQ OPTIONS `(HEADING ,(WINDOWPROP WINDOW 'TITLE)
|
||||
,@OPTIONS])
|
||||
(CONVERT.TO.IMAGEFILE (COPY.WINDOW.TO.BITMAP WINDOW)
|
||||
IMAGEFILE IMAGETYPE OPTIONS)
|
||||
else (CL:WHEN (AND (LISTP HARDCOPYFN)
|
||||
(FNTYP (CAR HARDCOPYFN)))
|
||||
(SETQ HEADING (CADR HARDCOPYFN))
|
||||
(CL:WHEN (EQ HEADING 'TITLE)
|
||||
(SETQ HEADING (WINDOWPROP WINDOW 'TITLE)))
|
||||
(SETQ HARDCOPYFN (CAR HARDCOPYFN)))
|
||||
(CL:WHEN HEADING
|
||||
[SETQ OPTIONS `(HEADING ,HEADING ,@OPTIONS])
|
||||
(CL:WITH-OPEN-STREAM (IMAGESTREAM (OPENIMAGESTREAM IMAGEFILE IMAGETYPE OPTIONS))
|
||||
(APPLY* HARDCOPYFN WINDOW IMAGESTREAM IMAGETYPE OPTIONS))
|
||||
IMAGEFILE)))])
|
||||
|
||||
(SCREENREGION.TO.IMAGEFILE
|
||||
[LAMBDA (REGION IMAGEFILE IMAGETYPE OPTIONS) (* ; "Edited 23-Dec-2025 20:13 by rmk")
|
||||
(* ; "Edited 19-Dec-2025 15:24 by rmk")
|
||||
(CL:UNLESS REGION
|
||||
(PROMPTPRINT "Select a region")
|
||||
(SETQ REGION (GETREGION))
|
||||
(CLRPROMPT))
|
||||
(LET [(BITMAP (BITMAPCREATE (fetch (REGION WIDTH) of REGION)
|
||||
(fetch (REGION HEIGHT) of REGION)
|
||||
(BITSPERPIXEL (SCREENBITMAP]
|
||||
(BITBLT (SCREENBITMAP)
|
||||
(fetch (REGION LEFT) of REGION)
|
||||
(fetch (REGION BOTTOM) of REGION)
|
||||
BITMAP 0 0 (fetch (REGION WIDTH) of REGION)
|
||||
(fetch (REGION HEIGHT) of REGION))
|
||||
(CONVERT.TO.IMAGEFILE BITMAP IMAGEFILE IMAGETYPE OPTIONS])
|
||||
|
||||
(COPY.WINDOW.TO.BITMAP
|
||||
[LAMBDA (WINDOW) (* ; "Edited 26-Aug-87 14:09 by Snow")
|
||||
|
||||
(* ;;; "copies contents of window (including title and border) into a bitmap")
|
||||
|
||||
(COND
|
||||
((OPENWP WINDOW)
|
||||
(PROG (REGION SCREEN LEFT BOTTOM WIDTH HEIGHT BITMAP)
|
||||
(SETQ REGION (WINDOWPROP WINDOW 'REGION))
|
||||
(SETQ SCREEN (WINDOWPROP WINDOW 'SCREEN))
|
||||
(SETQ LEFT (fetch (REGION LEFT) of REGION))
|
||||
(SETQ BOTTOM (fetch (REGION BOTTOM) of REGION))
|
||||
(SETQ WIDTH (fetch (REGION WIDTH) of REGION))
|
||||
(SETQ HEIGHT (fetch (REGION HEIGHT) of REGION))
|
||||
(SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT (BITSPERPIXEL WINDOW)))
|
||||
(.WHILE.TOP.DS. WINDOW (BITBLT (SCREENBITMAP SCREEN)
|
||||
LEFT BOTTOM BITMAP 0 0 WIDTH HEIGHT))
|
||||
(RETURN BITMAP)))
|
||||
(T (BITMAPCOPY (WINDOWPROP WINDOW 'IMAGECOVERED])
|
||||
)
|
||||
|
||||
(RPAQ? PRINTFILETYPES NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS PRINTFILETYPES)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS
|
||||
[LAMBDA (CONVERSIONS) (* ; "Edited 24-Dec-2025 22:42 by rmk")
|
||||
(CL:UNLESS (EQ 0 (IMOD (LENGTH CONVERSIONS)
|
||||
2))
|
||||
(ERROR "CONVERSIONS is not a property list"))
|
||||
(PUTMULTI PRINTFILETYPES 'DEFAULT 'CONVERSION (CONS (APPEND (CAR (GETMULTI PRINTFILETYPES
|
||||
'DEFAULT
|
||||
'CONVERSION))
|
||||
CONVERSIONS])
|
||||
)
|
||||
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS '(BITMAP BITMAP.TO.IMAGEFILE WINDOW WINDOW.TO.IMAGEFILE SCREENREGION
|
||||
SCREENREGION.TO.IMAGEFILE BITMAPFILE BITMAPFILE.TO.IMAGEFILE))
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES (BITMAP (TEST BITMAPP))
|
||||
(WINDOW (TEST WINDOWP))
|
||||
(SCREENREGION (TEST REGIONP))
|
||||
(BITMAPFILE (TEST BITMAPFILEP)
|
||||
(EXTENSION (BM BITMAP))
|
||||
(CONVERSION (BITMAP BITMAP.TO.BITMAPFILE))))
|
||||
|
||||
|
||||
|
||||
(* ; "Until HTML streams")
|
||||
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES )
|
||||
(DEFINEQ
|
||||
|
||||
(HTMLFILEP
|
||||
[LAMBDA (X) (* ; "Edited 28-Dec-2025 17:53 by rmk")
|
||||
(MEMB (FILENAMEFIELD X 'EXTENSION)
|
||||
(EXTENSIONS.FOR.IMAGEFILETYPE 'HTML])
|
||||
)
|
||||
|
||||
(RPAQ? IMAGESTREAMTYPES NIL)
|
||||
@@ -1576,27 +1841,31 @@
|
||||
(ADDTOVAR LAMA IMAGESTREAMP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3486 5127 (OPENIMAGESTREAM 3496 . 5125)) (5128 8304 (IMAGESTREAMP 5138 . 5970) (
|
||||
IMAGESTREAMTYPE 5972 . 6185) (IMAGESTREAMTYPEP 6187 . 6822) (IMAGEFILETYPE 6824 . 7935) (IMAGEFILEPROP
|
||||
7937 . 8302)) (8305 9310 (EXTENSIONS.FOR.IMAGEFILETYPE 8315 . 8671) (IMAGEFILETYPE.FROM.EXTENSION
|
||||
8673 . 9308)) (9311 12063 (CONVERT.TO.IMAGEFILE 9321 . 12061)) (12064 12951 (IMAGETYPE.BITMAPSCALE
|
||||
12074 . 12449) (IMAGETYPE.BITMAPFILE 12451 . 12949)) (12986 15101 (\GOOD.DASHLST 12996 . 15099)) (
|
||||
15102 17399 (DRAWDASHEDLINE 15112 . 17397)) (17400 24740 (DSPBACKCOLOR 17410 . 17782) (DSPBOTTOMMARGIN
|
||||
17784 . 18169) (DSPCOLOR 18171 . 18535) (DSPCLIPPINGREGION 18537 . 19242) (DSPRESET 19244 . 19524) (
|
||||
DSPFONT 19526 . 19890) (DSPLEFTMARGIN 19892 . 20273) (DSPLINEFEED 20275 . 20575) (DSPOPERATION 20577
|
||||
. 20954) (DSPRIGHTMARGIN 20956 . 21339) (DSPTOPMARGIN 21341 . 21720) (DSPSCALE 21722 . 22089) (
|
||||
DSPSPACEFACTOR 22091 . 22484) (DSPXPOSITION 22486 . 22791) (DSPYPOSITION 22793 . 23098) (DSPROTATE
|
||||
23100 . 23395) (DSPPUSHSTATE 23397 . 23643) (DSPPOPSTATE 23645 . 23888) (DSPDEFAULTSTATE 23890 . 24142
|
||||
) (DSPSCALE2 24144 . 24435) (DSPTRANSLATE 24437 . 24738)) (24741 33542 (DSPNEWPAGE 24751 . 25443) (
|
||||
DRAWBETWEEN 25445 . 26147) (DRAWCIRCLE 26149 . 26645) (DRAWARC 26647 . 27164) (DRAWCURVE 27166 . 27843
|
||||
) (DRAWELLIPSE 27845 . 28631) (DRAWLINE 28633 . 29023) (DRAWPOLYGON 29025 . 29480) (DRAWPOINT 29482 .
|
||||
29901) (FILLPOLYGON 29903 . 30469) (DRAWTO 30471 . 30889) (FILLCIRCLE 30891 . 31114) (MOVETO 31116 .
|
||||
31480) (RELDRAWTO 31482 . 32399) (BITMAPIMAGESIZE 32401 . 32572) (SCALEDBITBLT 32574 . 33540)) (33543
|
||||
40582 (\DRAWPOINT.GENERIC 33553 . 33900) (\DRAWPOLYGON.GENERIC 33902 . 36210) (\DRAWCIRCLE.GENERIC
|
||||
36212 . 37870) (\DRAWELLIPSE.GENERIC 37872 . 40580)) (40583 45527 (\IMAGEIOINIT 40593 . 43873) (
|
||||
\NOIMAGE.DSPFONT 43875 . 45361) (\UNIMPIMAGEOP 45363 . 45525)) (45650 48774 (INSURE.BRUSH 45660 .
|
||||
47034) (BRUSHP 47036 . 47826) (\POSSIBLECOLOR 47828 . 48379) (NEGSHADE 48381 . 48772)) (49330 50014 (
|
||||
DASHINGP 49340 . 49670) (INSURE.DASHING 49672 . 50012)) (60752 81298 (\DisplayEventFn 60762 . 61272) (
|
||||
\DISPLAYINIT 61274 . 66857) (\4DISPLAYINIT 66859 . 71560) (\8DISPLAYINIT 71562 . 76265) (
|
||||
\24DISPLAYINIT 76267 . 81039) (\DISPLAYSTREAMTYPEBPP 81041 . 81296)))))
|
||||
(FILEMAP (NIL (4358 5999 (OPENIMAGESTREAM 4368 . 5997)) (6000 9946 (IMAGESTREAMP 6010 . 6842) (
|
||||
IMAGESTREAMTYPE 6844 . 7057) (IMAGESTREAMTYPEP 7059 . 7694) (IMAGEFILEPROP 7696 . 8234) (
|
||||
IMAGESOURCEFILEP 8236 . 8513) (IMAGESOURCETYPE 8515 . 9944)) (9947 10952 (EXTENSIONS.FOR.IMAGEFILETYPE
|
||||
9957 . 10313) (IMAGEFILETYPE.FROM.EXTENSION 10315 . 10950)) (10953 15448 (CONVERT.TO.IMAGEFILE 10963
|
||||
. 15446)) (15449 19540 (BITMAPFILEP 15459 . 16960) (BITMAP.TO.BITMAPFILE 16962 . 18639) (
|
||||
BITMAPFILE.TO.BITMAP 18641 . 19295) (BITMAPFILE.TO.IMAGEFILE 19297 . 19538)) (19541 25866 (
|
||||
BITMAP.TO.IMAGEFILE 19551 . 21108) (WINDOW.TO.IMAGEFILE 21110 . 23939) (SCREENREGION.TO.IMAGEFILE
|
||||
23941 . 24845) (COPY.WINDOW.TO.BITMAP 24847 . 25864)) (25965 26602 (DEFAULT.IMAGETYPE.CONVERSIONS
|
||||
25975 . 26600)) (27225 27451 (HTMLFILEP 27235 . 27449)) (27486 29601 (\GOOD.DASHLST 27496 . 29599)) (
|
||||
29602 31899 (DRAWDASHEDLINE 29612 . 31897)) (31900 39240 (DSPBACKCOLOR 31910 . 32282) (DSPBOTTOMMARGIN
|
||||
32284 . 32669) (DSPCOLOR 32671 . 33035) (DSPCLIPPINGREGION 33037 . 33742) (DSPRESET 33744 . 34024) (
|
||||
DSPFONT 34026 . 34390) (DSPLEFTMARGIN 34392 . 34773) (DSPLINEFEED 34775 . 35075) (DSPOPERATION 35077
|
||||
. 35454) (DSPRIGHTMARGIN 35456 . 35839) (DSPTOPMARGIN 35841 . 36220) (DSPSCALE 36222 . 36589) (
|
||||
DSPSPACEFACTOR 36591 . 36984) (DSPXPOSITION 36986 . 37291) (DSPYPOSITION 37293 . 37598) (DSPROTATE
|
||||
37600 . 37895) (DSPPUSHSTATE 37897 . 38143) (DSPPOPSTATE 38145 . 38388) (DSPDEFAULTSTATE 38390 . 38642
|
||||
) (DSPSCALE2 38644 . 38935) (DSPTRANSLATE 38937 . 39238)) (39241 48042 (DSPNEWPAGE 39251 . 39943) (
|
||||
DRAWBETWEEN 39945 . 40647) (DRAWCIRCLE 40649 . 41145) (DRAWARC 41147 . 41664) (DRAWCURVE 41666 . 42343
|
||||
) (DRAWELLIPSE 42345 . 43131) (DRAWLINE 43133 . 43523) (DRAWPOLYGON 43525 . 43980) (DRAWPOINT 43982 .
|
||||
44401) (FILLPOLYGON 44403 . 44969) (DRAWTO 44971 . 45389) (FILLCIRCLE 45391 . 45614) (MOVETO 45616 .
|
||||
45980) (RELDRAWTO 45982 . 46899) (BITMAPIMAGESIZE 46901 . 47072) (SCALEDBITBLT 47074 . 48040)) (48043
|
||||
55082 (\DRAWPOINT.GENERIC 48053 . 48400) (\DRAWPOLYGON.GENERIC 48402 . 50710) (\DRAWCIRCLE.GENERIC
|
||||
50712 . 52370) (\DRAWELLIPSE.GENERIC 52372 . 55080)) (55083 60027 (\IMAGEIOINIT 55093 . 58373) (
|
||||
\NOIMAGE.DSPFONT 58375 . 59861) (\UNIMPIMAGEOP 59863 . 60025)) (60150 63274 (INSURE.BRUSH 60160 .
|
||||
61534) (BRUSHP 61536 . 62326) (\POSSIBLECOLOR 62328 . 62879) (NEGSHADE 62881 . 63272)) (63830 64514 (
|
||||
DASHINGP 63840 . 64170) (INSURE.DASHING 64172 . 64512)) (75252 95798 (\DisplayEventFn 75262 . 75772) (
|
||||
\DISPLAYINIT 75774 . 81357) (\4DISPLAYINIT 81359 . 86060) (\8DISPLAYINIT 86062 . 90765) (
|
||||
\24DISPLAYINIT 90767 . 95539) (\DISPLAYSTREAMTYPEBPP 95541 . 95796)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user