moving obsolete lispusers; delete some junk files (#730)
* lispusers [HIJK]* sort out * lispusers [LM]* sort out * more cleanup
This commit is contained in:
Larry Masinter
GitHub
223
obsolete/lispusers/LISPNERD
Normal file
223
obsolete/lispusers/LISPNERD
Normal file
@@ -0,0 +1,223 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "30-Aug-2020 20:52:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>LISPNERD.;2 10365
|
||||
|
||||
changes to%: (VARS LISPNERDCOMS LISPNERDDEPENDENCIES)
|
||||
(PROPS (LISPNERD DEPENDENCIES))
|
||||
|
||||
previous date%: " 3-Aug-88 16:16:39"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>LISPNERD.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LISPNERDCOMS)
|
||||
|
||||
(RPAQQ LISPNERDCOMS
|
||||
((COMS * LISPNERDDEPENDENCIES)
|
||||
(* must come before any FILES)
|
||||
(FILES ANALYZER DINFO HELPSYS DICTCLIENT)
|
||||
(FNS LISPNERD.INIT IRMNERD.PRINTSEARCH)
|
||||
(INITVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST (IRMNERD.MAXWORDS 50))
|
||||
(GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS)
|
||||
(FNS IRMDICT.PRINTENTRY)
|
||||
(P (LISPNERD.INIT))))
|
||||
|
||||
(RPAQQ LISPNERDDEPENDENCIES
|
||||
[(* * code to make sure that the right versions of everything are loaded. The P must be
|
||||
executed before any FILES commands.)
|
||||
[E (PUTPROP 'LISPNERD 'DEPENDENCIES (for FILE in (FILECOMSLST 'LISPNERD 'FILES)
|
||||
collect
|
||||
(CONS FILE (CAAR (GETPROP FILE 'FILEDATES]
|
||||
(PROP DEPENDENCIES LISPNERD)
|
||||
(P (for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES)
|
||||
do
|
||||
[SETQ FILEDATE (CAAR (GETPROP (CAR FILE)
|
||||
'FILEDATES]
|
||||
(COND ([AND FILEDATE (CDR FILE)
|
||||
(ILESSP (IDATE FILEDATE)
|
||||
(IDATE (CDR FILE]
|
||||
(* clear FILEDATES to force FILESLOAD to reload the file.)
|
||||
(PUTPROP (CAR FILE)
|
||||
'FILEDATES NIL])
|
||||
(* * code to make sure that the right versions of everything are loaded. The P must be executed
|
||||
before any FILES commands.)
|
||||
|
||||
|
||||
(PUTPROPS LISPNERD DEPENDENCIES ((ANALYZER . " 9-Mar-89 15:24:58")
|
||||
(DINFO . " 1-Oct-87 10:11:04")
|
||||
(HELPSYS . " 1-Oct-87 13:40:16")
|
||||
(DICTCLIENT)))
|
||||
|
||||
[for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES)
|
||||
do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE)
|
||||
'FILEDATES]
|
||||
(COND
|
||||
([AND FILEDATE (CDR FILE)
|
||||
(ILESSP (IDATE FILEDATE)
|
||||
(IDATE (CDR FILE] (* clear FILEDATES to force
|
||||
FILESLOAD to reload the file.)
|
||||
(PUTPROP (CAR FILE)
|
||||
'FILEDATES NIL]
|
||||
|
||||
|
||||
|
||||
(* must come before any FILES)
|
||||
|
||||
|
||||
(FILESLOAD ANALYZER DINFO HELPSYS DICTCLIENT)
|
||||
(DEFINEQ
|
||||
|
||||
(LISPNERD.INIT
|
||||
[LAMBDA NIL (* jtm%: "18-Nov-87 14:36")
|
||||
(COND
|
||||
((NULL IRMDICT)
|
||||
[Dict.Establish (SETQ IRMDICT (create Dict
|
||||
dictName _ 'IRMDict
|
||||
printEntryFn _ (FUNCTION IRMDICT.PRINTENTRY]
|
||||
(PUTASSOC 'Search% IRM '((IRMNERD.PRINTSEARCH)
|
||||
|
||||
"Searches the Interlisp Reference Manual for entries given a list of keywords."
|
||||
) BackgroundMenuCommands)
|
||||
(SETQ BackgroundMenu NIL])
|
||||
|
||||
(IRMNERD.PRINTSEARCH
|
||||
[LAMBDA (SYNONYMCLASSES) (* jtm%: " 7-Apr-87 12:33")
|
||||
(PROG (VENNDIAGRAM SELECTION MENUITEMS (MINWORD 0)
|
||||
(MAXWORD IRMNERD.MAXWORDS))
|
||||
[COND
|
||||
((NULL SYNONYMCLASSES)
|
||||
(CLRPROMPT)
|
||||
(PROMPTPRINT (CHARACTER (CHARCODE CR)))
|
||||
(SETQ SYNONYMCLASSES (PROMPTFORWORD "keywords to search on:" IRMNERD.LASTREQUEST NIL
|
||||
PROMPTWINDOW NIL NIL (CHARCODE EOL ESCAPE LF)))
|
||||
(COND
|
||||
((NULL SYNONYMCLASSES)
|
||||
(PROMPTPRINT "Aborted")
|
||||
(RETURN))
|
||||
(T (CLRPROMPT)))
|
||||
(COND
|
||||
((NOT (STREQUAL SYNONYMCLASSES IRMNERD.LASTREQUEST))
|
||||
(SETQ IRMNERD.LASTREQUEST SYNONYMCLASSES)
|
||||
(SETQ IRMNERD.LASTSEARCH NIL]
|
||||
[do [SETQ VENNDIAGRAM (COND
|
||||
((AND IRMNERD.LASTSEARCH (EQ MINWORD 0))
|
||||
IRMNERD.LASTSEARCH)
|
||||
(T (PROMPTPRINT "
|
||||
Searching . . . ")
|
||||
(DICTCLIENT.SEARCHFORWORD SYNONYMCLASSES 2 MINWORD MAXWORD
|
||||
'IRMNerd]
|
||||
(COND
|
||||
((EQ MINWORD 0) (* cache the results in case the use
|
||||
calls again.)
|
||||
(SETQ IRMNERD.LASTSEARCH VENNDIAGRAM)))
|
||||
[COND
|
||||
((NULL VENNDIAGRAM)
|
||||
(PROMPTPRINT "Sorry, no results.")
|
||||
(FLASHWINDOW PROMPTWINDOW)
|
||||
(RETURN))
|
||||
((NULL (CDR VENNDIAGRAM))
|
||||
(SETQ MENUITEMS (CADAR VENNDIAGRAM)))
|
||||
(T (SETQ MENUITEMS (for SET in VENNDIAGRAM
|
||||
collect (LIST [CONCATLIST (for ELEMENT
|
||||
on (CAR SET)
|
||||
collect (COND
|
||||
((CDR ELEMENT)
|
||||
(CONCAT (CAR ELEMENT)
|
||||
" "))
|
||||
(T (CAR ELEMENT]
|
||||
(LIST 'QUOTE (CAR SET))
|
||||
NIL
|
||||
(CONS 'SUBITEMS (CADR SET]
|
||||
(CLRPROMPT)
|
||||
(SETQ SELECTION (MENU (create MENU
|
||||
TITLE _ "IRM Entries"
|
||||
ITEMS _ MENUITEMS
|
||||
CENTERFLG _ T)))
|
||||
(COND
|
||||
((NULL SELECTION)
|
||||
(PROMPTPRINT "
|
||||
No selection made.")
|
||||
(RETURN))
|
||||
((LISTP SELECTION)
|
||||
[for TAIL CLASSNAME on SELECTION
|
||||
do (COND
|
||||
((EQ (NTHCHARCODE (CAR TAIL)
|
||||
-1)
|
||||
(CHARCODE +))
|
||||
(SETQ CLASSNAME (SUBSTRING (CAR TAIL)
|
||||
1 -2))
|
||||
(RPLACA TAIL (for CLASS in SYNONYMCLASSES
|
||||
thereis (STREQUAL (CAR CLASS)
|
||||
CLASSNAME]
|
||||
(SETQ SYNONYMCLASSES SELECTION)
|
||||
(PROMPTPRINT "Seaching for: " SYNONYMCLASSES)
|
||||
(SETQ MINWORD 0)
|
||||
(SETQ MAXWORD IRMNERD.MAXWORDS))
|
||||
((AND (EQ 1 (STRPOS ". . .+" SELECTION))
|
||||
(STRPOS "more" SELECTION)) (* the user asked for the next chunk.)
|
||||
(SETQ MINWORD (ADD1 MAXWORD))
|
||||
(SETQ MAXWORD (IPLUS MAXWORD IRMNERD.MAXWORDS)))
|
||||
((EQ 1 (STRPOS "No more" SELECTION))
|
||||
(RETURN))
|
||||
(T (PROMPTPRINT "
|
||||
Fetching definition . . . ")
|
||||
(IRMDICT.PRINTENTRY NIL SELECTION)
|
||||
(CLRPROMPT)
|
||||
(RETURN]
|
||||
(RETURN T])
|
||||
)
|
||||
|
||||
(RPAQ? IRMDICT NIL)
|
||||
|
||||
(RPAQ? IRMNERD.LASTSEARCH NIL)
|
||||
|
||||
(RPAQ? IRMNERD.LASTREQUEST NIL)
|
||||
|
||||
(RPAQ? IRMNERD.MAXWORDS 50)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(IRMDICT.PRINTENTRY
|
||||
[LAMBDA (DICT LEMMA) (* ; "Edited 25-Jan-88 11:10 by jtm:")
|
||||
|
||||
(LET (FIRSTCHAR SECTION# GRAPH NODE)
|
||||
(SETQ FIRSTCHAR (NTHCHAR LEMMA 1))
|
||||
[COND
|
||||
((NUMBERP FIRSTCHAR)
|
||||
[SETQ SECTION# (SUBSTRING LEMMA 1 (SUB1 (OR (STRPOS " " LEMMA)
|
||||
0]
|
||||
[COND
|
||||
((EQ (NTHCHARCODE SECTION# -1)
|
||||
(CHARCODE %.)) (* sometimes there is a trailing
|
||||
period.)
|
||||
(SETQ SECTION# (SUBSTRING SECTION# 1 -2]
|
||||
[for I from 1 to (NCHARS SECTION#) do (COND
|
||||
((EQ (NTHCHARCODE SECTION# I)
|
||||
(CHARCODE %.))
|
||||
(* DINFO uses dashes instead of
|
||||
periods)
|
||||
(RPLCHARCODE SECTION# I (CHARCODE -]
|
||||
(SETQ SECTION# (MKATOM SECTION#))
|
||||
(SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH))
|
||||
[COND
|
||||
((NULL GRAPH)
|
||||
(DINFO.INIT)
|
||||
(SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH]
|
||||
(SETQ NODE (FASSOC SECTION# (fetch (DINFOGRAPH NODELST) of GRAPH)))
|
||||
(AND NODE (DINFO.UPDATE NODE)))
|
||||
(T (IRM.SMART.LOOKUP (SUBSTRING LEMMA (COND
|
||||
((EQ FIRSTCHAR '%()
|
||||
2)
|
||||
(T 1))
|
||||
(SUB1 (OR (STRPOS " " LEMMA)
|
||||
0]
|
||||
T])
|
||||
)
|
||||
|
||||
(LISPNERD.INIT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2864 8085 (LISPNERD.INIT 2874 . 3521) (IRMNERD.PRINTSEARCH 3523 . 8083)) (8332 10321 (
|
||||
IRMDICT.PRINTENTRY 8342 . 10319)))))
|
||||
STOP
|
||||
BIN
obsolete/lispusers/LISPNERD.TEDIT
Normal file
BIN
obsolete/lispusers/LISPNERD.TEDIT
Normal file
Binary file not shown.
52
obsolete/lispusers/PLOTANDNC-PATCH
Normal file
52
obsolete/lispusers/PLOTANDNC-PATCH
Normal file
@@ -0,0 +1,52 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(filecreated "22-Jan-88 15:45:26" {indigo}<gslws>lyric>library>plotandnc-patch.\;1 1853
|
||||
|
||||
|changes| |to:| (vars plotandnc-patchcoms)
|
||||
(fns read.fontintodescriptor))
|
||||
|
||||
|
||||
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(prettycomprint plotandnc-patchcoms)
|
||||
|
||||
(rpaqq plotandnc-patchcoms (
|
||||
|
||||
(* |;;| "define font read fns used by plot and notecards so system can read either kind")
|
||||
|
||||
(fns readfont read.fontintodescriptor)
|
||||
(p
|
||||
|
||||
(* |;;| "make sure these read fns are registered to avoid messages when reading")
|
||||
|
||||
(pushnew hprintreadfns 'readfont)
|
||||
(pushnew hprintreadfns 'read.fontintodescriptor))))
|
||||
|
||||
|
||||
|
||||
(* |;;| "define font read fns used by plot and notecards so system can read either kind")
|
||||
|
||||
(defineq
|
||||
|
||||
(readfont
|
||||
(lambda (stream) (* |jop:| "27-Aug-85 13:34")
|
||||
(prog ((proplist (read stream)))
|
||||
(return (fontcreate (listget proplist 'family)
|
||||
(listget proplist 'size)
|
||||
(listget proplist 'face)
|
||||
(listget proplist 'rotation)
|
||||
(listget proplist 'device))))))
|
||||
|
||||
(read.fontintodescriptor
|
||||
(lambda (stream) (* \; "Edited 22-Jan-88 15:36 by thh:")
|
||||
|
||||
(apply 'fontcreate (read stream))))
|
||||
)
|
||||
|
||||
(* |;;| "make sure these read fns are registered to avoid messages when reading")
|
||||
|
||||
(pushnew hprintreadfns 'readfont)
|
||||
(pushnew hprintreadfns 'read.fontintodescriptor)
|
||||
(putprops plotandnc-patch copyright ("Xerox Corporation" 1988))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil (967 1575 (readfont 977 . 1393) (read.fontintodescriptor 1395 . 1573)))))
|
||||
stop
|
||||
434
obsolete/lispusers/PS-PATCH
Normal file
434
obsolete/lispusers/PS-PATCH
Normal file
@@ -0,0 +1,434 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 8-Nov-90 18:53:15" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>POSTSCRIPT>PS-PATCH.;2| 24907
|
||||
|
||||
changes to%: (VARS PS-PATCHCOMS)
|
||||
(PROPS (PS-PATCH MAKEFILE-ENVIRONMENT))
|
||||
(FNS FIX-SKETCH)
|
||||
|
||||
previous date%: "22-Feb-89 14:11:29" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>POSTSCRIPT>PS-PATCH.;1|
|
||||
)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT PS-PATCHCOMS)
|
||||
|
||||
(RPAQQ PS-PATCHCOMS
|
||||
((PROP (MAKEFILE-ENVIRONMENT FILETYPE)
|
||||
PS-PATCH)
|
||||
(FNS ADD.KNOWN.SKETCH.FONT NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST
|
||||
NEW-SKETCHW-HARDCOPYFN FIX-SKETCH)
|
||||
[VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT)
|
||||
(NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
|
||||
(NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN]
|
||||
|
||||
(* ;;
|
||||
"NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded.")
|
||||
|
||||
(FNS \BUILDSLUGCSINFO \CREATECHARSET)
|
||||
(ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
|
||||
(TIMESROMAND . TIMESROMAN)
|
||||
(COURIER . COURIER)
|
||||
(GACHA . COURIER)
|
||||
(CLASSIC . TIMESROMAN)
|
||||
(MODERN . HELVETICA)
|
||||
(CREAM . HELVETICA)
|
||||
(TERMINAL . COURIER)
|
||||
(LOGO . HELVETICA)
|
||||
(MODERN . HELVETICA)))
|
||||
(VARS (\KNOWN.SKETCH.FONTSIZES))
|
||||
(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
|
||||
POSTSCRIPT.FONT.CONVERSIONS)
|
||||
|
||||
(* ;; "finally actually do the patching of sketch.")
|
||||
|
||||
(P (FIX-SKETCH))))
|
||||
|
||||
(PUTPROPS PS-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10
|
||||
))
|
||||
|
||||
(PUTPROPS PS-PATCH FILETYPE :TCOMPL)
|
||||
(DEFINEQ
|
||||
|
||||
(ADD.KNOWN.SKETCH.FONT
|
||||
[LAMBDA (FAMILY WID DEVICE FONT) (* ; "Edited 21-Feb-89 15:06 by snow")
|
||||
|
||||
(* ;; "add to the globally cached font list")
|
||||
|
||||
(DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
|
||||
(LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES))
|
||||
(CACHED))
|
||||
(COND
|
||||
[(NULL CACHE)
|
||||
(if \KNOWN.SKETCH.FONTSIZES
|
||||
then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT]
|
||||
else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE
|
||||
(CONS WID FONT]
|
||||
(T (COND
|
||||
((SETQ CACHED (ASSOC DEVICE CACHE))
|
||||
(NCONC1 CACHED (CONS WID FONT)))
|
||||
(T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT])
|
||||
|
||||
(NEW-SK-PICK-FONT
|
||||
[LAMBDA (WID STRING DEVICE FAMILY) (* ; "Edited 22-Feb-89 07:53 by snow")
|
||||
|
||||
(* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide")
|
||||
|
||||
(DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
|
||||
(PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT)
|
||||
(IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES]
|
||||
THEN (RETURN (CDR CACHEDFONT)))
|
||||
(RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE)
|
||||
when (NOT (GREATERP [SETQ LASTSIZE (COND
|
||||
((SETQ SCALE (FONTPROP FONT
|
||||
'SCALE))
|
||||
|
||||
(* ;;
|
||||
"IF THERE IS A SCALE, YOU MUST SCALE THE FONT.")
|
||||
|
||||
(QUOTIENT (STRINGWIDTH STRING FONT)
|
||||
SCALE))
|
||||
((SETQ DISPLAYFONT (FONTCOPY
|
||||
(SETQ LASTFONT
|
||||
FONT)
|
||||
'DEVICE
|
||||
'DISPLAY
|
||||
'NOERROR T))
|
||||
(* ; "use display if it exists.")
|
||||
(STRINGWIDTH STRING DISPLAYFONT))
|
||||
(T
|
||||
(* ;
|
||||
"in some cases, font exists for devices other than display.")
|
||||
(QUOTIENT (STRINGWIDTH STRING FONT)
|
||||
(FONTPROP FONT 'SCALE]
|
||||
WID)) do (* ;
|
||||
"return a font for the proper device even though the display fonts are used to pick a size.")
|
||||
(ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE
|
||||
(FONTCOPY FONT 'DEVICE DEVICE))
|
||||
(RETURN (FONTCOPY FONT 'DEVICE DEVICE))
|
||||
finally (RETURN (COND
|
||||
((OR (NULL LASTFONT)
|
||||
(GREATERP LASTSIZE (TIMES 1.5 WID)))
|
||||
'SHADE)
|
||||
(T (* ;
|
||||
"use the smallest if it isn't too large.")
|
||||
(FONTCOPY LASTFONT 'DEVICE DEVICE])
|
||||
|
||||
(NEW-SK-DECREASING-FONT-LIST
|
||||
[LAMBDA (FAMILY DEVICETYPE) (* ; "Edited 21-Feb-89 11:26 by snow")
|
||||
|
||||
(* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE")
|
||||
|
||||
[COND
|
||||
((NULL FAMILY)
|
||||
(SETQ FAMILY 'MODERN]
|
||||
|
||||
(* ;; "convert to families that exist on the known devices.")
|
||||
|
||||
(* ;;; "NOTE: this is a very bad way to convert the family. It HARDCODES in the conversions for PRESS and INTERPRESS and does nothing for new device types. I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.) --was 2/19/89")
|
||||
|
||||
(LET ((CONVERSION))
|
||||
[COND
|
||||
[(EQ DEVICETYPE 'PRESS)
|
||||
(COND
|
||||
((EQ FAMILY 'MODERN)
|
||||
(SETQ FAMILY 'HELVETICA))
|
||||
((EQ FAMILY 'CLASSIC)
|
||||
(SETQ FAMILY 'TIMESROMAN))
|
||||
((EQ FAMILY 'TERMINAL)
|
||||
(SETQ FAMILY 'GACHA]
|
||||
[(EQ DEVICETYPE 'INTERPRESS)
|
||||
(COND
|
||||
((EQ FAMILY 'HELVETICA)
|
||||
(SETQ FAMILY 'MODERN))
|
||||
((EQ FAMILY 'TIMESROMAN)
|
||||
(SETQ FAMILY 'CLASSIC))
|
||||
((EQ FAMILY 'GACHA)
|
||||
(SETQ FAMILY 'TERMINAL]
|
||||
((EQ DEVICETYPE 'POSTSCRIPT)
|
||||
(if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS))
|
||||
then
|
||||
|
||||
(* ;;
|
||||
"convert the family here for postscript as well as the other well known devices.")
|
||||
|
||||
(SETQ FAMILY (CDR CONVERSION]
|
||||
(for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE)
|
||||
collect (FONTCOPY FONT 'DEVICE DEVICETYPE])
|
||||
|
||||
(NEW-SKETCHW-HARDCOPYFN
|
||||
[LAMBDA (SKETCHW OPENIMAGESTREAM) (* ; "Edited 22-Feb-89 13:34 by snow")
|
||||
(* ;
|
||||
"dumps the sketch onto OPENIMAGESTREAM.")
|
||||
(* ;
|
||||
"centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM")
|
||||
(PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW)))
|
||||
(PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM))
|
||||
(SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW))
|
||||
(SCALE (VIEWER.SCALE SKETCHW))
|
||||
SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX)
|
||||
(OR SKETCH (RETURN))
|
||||
(SPAWN.MOUSE)
|
||||
|
||||
(* ;; "move the margins out of the way")
|
||||
|
||||
(* ;;
|
||||
"smallp is to maintain compatibility with koto. For Lute release, this could be increased.")
|
||||
|
||||
(DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION))
|
||||
OPENIMAGESTREAM)
|
||||
(DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION))
|
||||
OPENIMAGESTREAM)
|
||||
(DSPTOPMARGIN (MAX MAX.SMALLP (fetch (REGION TOP) of PAGEREGION))
|
||||
OPENIMAGESTREAM)
|
||||
(DSPRIGHTMARGIN (MAX MAX.SMALLP (fetch (REGION RIGHT) of PAGEREGION))
|
||||
OPENIMAGESTREAM)
|
||||
|
||||
(* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.")
|
||||
|
||||
(STATUSPRINT SKETCHW "Hardcopying ...")
|
||||
[STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE
|
||||
SKETCHW)
|
||||
"A Sketch"))
|
||||
(STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS]
|
||||
(SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM)))
|
||||
(SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR))
|
||||
(COND
|
||||
((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
|
||||
'PRESS))
|
||||
(NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS)
|
||||
OF OPENIMAGESTREAM))
|
||||
'NILL))
|
||||
(GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
|
||||
(fetch WIDTH of PAGEREGION))
|
||||
(GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
|
||||
(fetch HEIGHT of SKETCHREGIONINPAGECOORDS)))
|
||||
|
||||
(* ;; "we ;have a stream that supports rotation, use it!")
|
||||
|
||||
(DSPROTATE 90 OPENIMAGESTREAM)
|
||||
(DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION))
|
||||
OPENIMAGESTREAM)
|
||||
(DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION))
|
||||
OPENIMAGESTREAM)
|
||||
|
||||
(* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)")
|
||||
|
||||
(* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big. Now it tries to do it on any stream that has a dsprotate function.")
|
||||
|
||||
))
|
||||
(SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION)
|
||||
(fetch (REGION WIDTH) of
|
||||
SKETCHREGIONINPAGECOORDS
|
||||
))
|
||||
2))
|
||||
(SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION)
|
||||
(fetch (REGION HEIGHT) of
|
||||
SKETCHREGIONINPAGECOORDS
|
||||
))
|
||||
2))
|
||||
|
||||
(* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.")
|
||||
|
||||
[SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE
|
||||
(SETQ PAGELEFTSPACE
|
||||
(PLUS (fetch (REGION LEFT)
|
||||
of PAGEREGION)
|
||||
PAGELEFTSPACE))
|
||||
(fetch (REGION LEFT) of
|
||||
|
||||
SKETCHREGIONINPAGECOORDS
|
||||
))
|
||||
PAGETOSKETCHFACTOR))
|
||||
(MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE
|
||||
(PLUS (fetch (REGION BOTTOM)
|
||||
of PAGEREGION)
|
||||
PAGEBOTTOMSPACE))
|
||||
(fetch (REGION BOTTOM) of
|
||||
SKETCHREGIONINPAGECOORDS
|
||||
))
|
||||
PAGETOSKETCHFACTOR]
|
||||
(* ;
|
||||
"calculate the local parts for the interpress sketch.")
|
||||
(SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE
|
||||
PAGETOSKETCHFACTOR)
|
||||
(TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR)
|
||||
(fetch (REGION WIDTH) of
|
||||
SKETCHREGION
|
||||
)
|
||||
(fetch (REGION HEIGHT) of
|
||||
SKETCHREGION
|
||||
))
|
||||
PAGETOSKETCHFACTOR OPENIMAGESTREAM))
|
||||
(DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE
|
||||
(fetch (REGION WIDTH) of
|
||||
SKETCHREGIONINPAGECOORDS
|
||||
)
|
||||
(fetch (REGION HEIGHT) of
|
||||
SKETCHREGIONINPAGECOORDS
|
||||
)))
|
||||
(STATUSPRINT SKETCHW " done.")
|
||||
(RETURN OPENIMAGESTREAM])
|
||||
|
||||
(FIX-SKETCH
|
||||
[LAMBDA NIL (* ; "Edited 8-Nov-90 16:32 by jds")
|
||||
(COND
|
||||
((BOUNDP 'ALL.SKETCHES)
|
||||
|
||||
(* ;; "sketch is loaded")
|
||||
|
||||
(for PATCHED-FN in '(NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST
|
||||
NEW-SKETCHW-HARDCOPYFN) as ORIGINAL-FN
|
||||
in '(SK.PICK.FONT SK.DECREASING.FONT.LIST SKETCHW.HARDCOPYFN)
|
||||
do (MOVD PATCHED-FN ORIGINAL-FN NIL T))
|
||||
(PROMPTPRINT "Sketch has been patched!")
|
||||
T)
|
||||
(T (PROMPTPRINT "Sketch doesn't seem to be loaded!")
|
||||
(PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!")
|
||||
NIL])
|
||||
)
|
||||
|
||||
(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT)
|
||||
(NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
|
||||
(NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN)))
|
||||
|
||||
|
||||
|
||||
(* ;; "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded."
|
||||
)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\BUILDSLUGCSINFO
|
||||
[LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 14-Feb-89 16:46 by snow")
|
||||
|
||||
(* ;;; "builds a csinfo which contains only the slug (black rectangle) character")
|
||||
|
||||
(SETQ SCALE (OR SCALE 1))
|
||||
(PROG ((CSINFO (create CHARSETINFO
|
||||
CHARSETASCENT _ ASCENT
|
||||
CHARSETDESCENT _ DESCENT
|
||||
IMAGEWIDTHS _ (\CREATECSINFOELEMENT)))
|
||||
WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
|
||||
(SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
|
||||
[SELECTQ DEVICE
|
||||
(INTERPRESS (* ;
|
||||
"don't need offsets in INTERPRESS fonts")
|
||||
NIL)
|
||||
(PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
|
||||
\CREATECSINFOELEMENT
|
||||
)))
|
||||
(for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
|
||||
[replace (CHARSETINFO CHARSETBITMAP) of CSINFO
|
||||
with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
|
||||
(ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
|
||||
SCALE]
|
||||
(BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
|
||||
(RETURN CSINFO])
|
||||
|
||||
(\CREATECHARSET
|
||||
[LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 14-Feb-89 16:29 by snow")
|
||||
|
||||
(* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
|
||||
(* ;
|
||||
"NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
|
||||
(DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
|
||||
(AND (IGREATERP CHARSET \MAXCHARSET)
|
||||
(\ILLEGAL.ARG CHARSET))
|
||||
(PROG (CSINFO CREATEFN)
|
||||
|
||||
(* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.")
|
||||
|
||||
(if (OR (AND (IGEQ CHARSET 1)
|
||||
(ILEQ CHARSET 32))
|
||||
(AND (IGEQ CHARSET 127)
|
||||
(ILEQ CHARSET 160)))
|
||||
then
|
||||
|
||||
(* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG? is T)")
|
||||
|
||||
[if NOSLUG?
|
||||
then (RETURN NIL)
|
||||
else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
|
||||
FONTAVGCHARWIDTH)
|
||||
of FONT)
|
||||
(FONTPROP FONT 'ASCENT)
|
||||
(FONTPROP FONT 'DESCENT)
|
||||
(FONTPROP FONT 'DEVICE)
|
||||
(FONTPROP FONT 'SCALE]
|
||||
else [SETQ CREATEFN (COND
|
||||
((FMEMB (FONTPROP FONT 'DEVICE)
|
||||
\DISPLAYSTREAMTYPES)
|
||||
(FUNCTION \CREATECHARSET.DISPLAY))
|
||||
(T (CADR (ASSOC 'CREATECHARSET
|
||||
(CDR (ASSOC (FONTPROP FONT 'DEVICE)
|
||||
IMAGESTREAMTYPES]
|
||||
[if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
|
||||
(LIST CHARSET FONT NOSLUG?]
|
||||
then (* ;
|
||||
"the create method returned NIL. so if NOSLUG? return NIL else build a slug charsetinfo")
|
||||
(RETURN (if NOSLUG?
|
||||
then (* ;
|
||||
"the caller just wants NIL back to signal that nothing was found")
|
||||
NIL
|
||||
else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
|
||||
FONTAVGCHARWIDTH)
|
||||
of FONT)
|
||||
(FONTPROP FONT 'ASCENT)
|
||||
(FONTPROP FONT 'HEIGHT)
|
||||
(FONTPROP FONT 'DEVICE)
|
||||
(FONTPROP FONT 'SCALE]
|
||||
(replace \SFAscent of FONT with (IMAX (fetch \SFAscent of
|
||||
FONT)
|
||||
(fetch CHARSETASCENT
|
||||
of CSINFO)))
|
||||
(replace \SFDescent of FONT with (IMAX (fetch \SFDescent
|
||||
of FONT)
|
||||
(ffetch CHARSETDESCENT
|
||||
of CSINFO)))
|
||||
(replace \SFHeight of FONT with (IPLUS (fetch \SFAscent
|
||||
of FONT)
|
||||
(ffetch \SFDescent
|
||||
of FONT)))
|
||||
(* ;
|
||||
"jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
|
||||
)
|
||||
(RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
|
||||
CHARSET CSINFO])
|
||||
)
|
||||
|
||||
(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
|
||||
(TIMESROMAND . TIMESROMAN)
|
||||
(COURIER . COURIER)
|
||||
(GACHA . COURIER)
|
||||
(CLASSIC . TIMESROMAN)
|
||||
(MODERN . HELVETICA)
|
||||
(CREAM . HELVETICA)
|
||||
(TERMINAL . COURIER)
|
||||
(LOGO . HELVETICA)
|
||||
(MODERN . HELVETICA))
|
||||
|
||||
(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
|
||||
POSTSCRIPT.FONT.CONVERSIONS)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "finally actually do the patching of sketch.")
|
||||
|
||||
|
||||
(FIX-SKETCH)
|
||||
(PUTPROPS PS-PATCH COPYRIGHT ("ENVOS Corporation" 1989 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2086 16850 (ADD.KNOWN.SKETCH.FONT 2096 . 2973) (NEW-SK-PICK-FONT 2975 . 6357) (
|
||||
NEW-SK-DECREASING-FONT-LIST 6359 . 8183) (NEW-SKETCHW-HARDCOPYFN 8185 . 16115) (FIX-SKETCH 16117 .
|
||||
16848)) (17182 23954 (\BUILDSLUGCSINFO 17192 . 19090) (\CREATECHARSET 19092 . 23952)))))
|
||||
STOP
|
||||
BIN
obsolete/lispusers/microtek.tedit
Normal file
BIN
obsolete/lispusers/microtek.tedit
Normal file
Binary file not shown.
Reference in New Issue
Block a user