(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED " 9-May-88 11:50:18" {ERINYES}<LISPUSERS>LYRIC>TEDIT-LINE-NUMBERING.;1 14383
changes to%: (VARS TEDIT-LINE-NUMBERINGCOMS)
(FNS MAKE-LINE-BREAKS))
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TEDIT-LINE-NUMBERINGCOMS)
(RPAQQ TEDIT-LINE-NUMBERINGCOMS ((DECLARE%: DONTCOPY (PROPS (TEDIT-LINE-NUMBERING
MAKEFILE-ENVIRONMENT)
(TEDIT-LINE-NUMBERING FILETYPE)))
(* ;; "Hack for putting line breaks and line numbers into a transcript.")
(FNS MAKE-LINE-BREAKS)
(GLOBALVARS INTERPRESS-DSPSCALE PRESS-DSPSCALE DISPLAY-DSPSCALE
END-MARKER-CHAR WHITE-SPACE-CHARS)
[VARS (INTERPRESS-DSPSCALE 35.27778)
(PRESS-DSPSCALE 35.27778)
(DISPLAY-DSPSCALE 1)
(END-MARKER-CHAR (CHARACTER 2))
(WHITE-SPACE-CHARS (LIST (CHARACTER 32)
(CHARACTER 9]
(* ;; "Internal functions")
(FNS MAKE-LINE-PREFIX-STRING DEL-CHARS READ-AND-SUM-CHARWIDTHS
SELECTION-WIDTH GET-NEXT-CHAR SKIP-CHAR WHITE-SPACE-P
NONWHITE-SPACE-P)))
(DECLARE%: DONTCOPY
(PUTPROPS TEDIT-LINE-NUMBERING MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
(PUTPROPS TEDIT-LINE-NUMBERING FILETYPE :TCOMPL)
)
(* ;; "Hack for putting line breaks and line numbers into a transcript.")
(DEFINEQ
(MAKE-LINE-BREAKS
[LAMBDA (TextStream WidthInInches Device StartLineNum LineNumDigits FirstLineParaLooks
OtherLineParaLooks InsertExtraTabFlg InsertExtraCRFlg)
(* ; "Edited 9-May-88 11:46 by Trigg")
(* ;; "Adds line breaks and prefix line numbers to the current selection in TextStream. ")
(DECLARE (GLOBALVARS INTERPRESS-DSPSCALE PRESS-DSPSCALE DISPLAY-DSPSCALE END-MARKER-CHAR))
(OR (NUMBERP LineNumDigits)
(SETQ LineNumDigits 3))
(OR (NUMBERP StartLineNum)
(SETQ StartLineNum 1))
(LET ((Selection (TEDIT.GETSEL TextStream))
(Scale (SELECTQ Device
(DISPLAY DISPLAY-DSPSCALE)
(PRESS PRESS-DSPSCALE)
(INTERPRESS INTERPRESS-DSPSCALE)
(HELP "Unknown device type " Device)))
(LineNumTemplateString (CONCATLIST (for i from 1 to LineNumDigits collect 0)))
WidthInDeviceUnits StartLoc EndLoc OrigParaLooks Tabs TabStops DefaultTabWidth)
(SETQ WidthInDeviceUnits (FTIMES WidthInInches 72 Scale))
(SETQ StartLoc (fetch (SELECTION CH#) of Selection))
(SETQ EndLoc (SUB1 (fetch (SELECTION CHLIM) of Selection)))
(if (LEQ EndLoc StartLoc)
then (ERROR "*** Error in MAKE-LINE-BREAKS ***" "Current selection is empty."))
(* ;
"Stuff a marker into the text to mark the end of the selection.")
(TEDIT.INSERT TextStream END-MARKER-CHAR EndLoc)
(TEDIT.SETSEL TextStream StartLoc 0 'LEFT)
(SETQ OrigParaLooks (TEDIT.GET.PARALOOKS TextStream Selection))
(SETQ Tabs (LISTGET OrigParaLooks 'TABS))
[SETQ TabStops (for Stop in (CDR Tabs) collect (if (EQ (CDR Stop)
'LEFT)
then (FTIMES Scale (CAR Stop))
else (ERROR
"Can't handle tabs not of type LEFT"
]
(SETQ DefaultTabWidth (FTIMES Scale (OR (CAR Tabs)
36))) (* ;
"stuff a bunch of default tabs on the end of the list of real tabs.")
[SETQ TabStops (NCONC TabStops
(LET ((LastTab (OR (CAR (LAST TabStops))
0)))
(for TabStop from (PLUS LastTab DefaultTabWidth) by
DefaultTabWidth
as i from 1 to 10 collect TabStop]
(for bind (LineNum ← StartLineNum)
(CurLoc ← StartLoc)
FirstLineFlg NewWidthOrChar
do (* ; "Starting a new paragraph")
(SETQ FirstLineFlg T)
(TEDIT.INSERT TextStream (MAKE-LINE-PREFIX-STRING LineNum LineNumTemplateString))
(SETQ LineNum (ADD1 LineNum))
(for bind (CurWidth ← (CAR TabStops))
do (SETQ CurLoc (TEDIT.GETPOINT TextStream))
(if [AND (NUMBERP (SETQ NewWidthOrChar (READ-AND-SUM-CHARWIDTHS
TextStream Device (FUNCTION
WHITE-SPACE-P)
TabStops DefaultTabWidth CurWidth)))
(NUMBERP (SETQ NewWidthOrChar (READ-AND-SUM-CHARWIDTHS
TextStream Device (FUNCTION
NONWHITE-SPACE-P)
TabStops DefaultTabWidth NewWidthOrChar]
then (if (LEQ NewWidthOrChar WidthInDeviceUnits)
then (SETQ CurWidth NewWidthOrChar)
else (TEDIT.PARALOOKS TextStream (if FirstLineFlg
then FirstLineParaLooks
else OtherLineParaLooks))
(TEDIT.INSERT TextStream (CHARACTER 13)
CurLoc)
(TEDIT.INSERT TextStream (MAKE-LINE-PREFIX-STRING LineNum
LineNumTemplateString))
(SETQ CurWidth (CAR TabStops))
(* ;
"Add extra tab on non-first lines if caller desired.")
[if InsertExtraTabFlg
then (TEDIT.INSERT TextStream (CHARACTER 9))
(SETQ CurWidth (OR (CADR TabStops)
(PLUS CurWidth DefaultTabWidth]
(DEL-CHARS TextStream (FUNCTION WHITE-SPACE-P))
(SETQ LineNum (ADD1 LineNum))
(SETQ FirstLineFlg NIL) (* ;
"The width of the prefix string is just the first tab stop.")
)
else (RETURN)))
(* ;; "We must be at the end of the paragraph.")
(TEDIT.PARALOOKS TextStream (if FirstLineFlg
then FirstLineParaLooks
else OtherLineParaLooks))
(if (EQ NewWidthOrChar (CHARACTER 13))
then (DEL-CHARS TextStream (FUNCTION WHITE-SPACE-P))
(* ; "Skip past the CR")
(SKIP-CHAR TextStream) (* ; "Add an extra CR if caller wants")
(if InsertExtraCRFlg
then (TEDIT.INSERT TextStream (CHARACTER 13)))
else (if (EQ NewWidthOrChar END-MARKER-CHAR)
then (* ; "Delete the end marker")
(TEDIT.DELETE TextStream (TEDIT.GETPOINT TextStream)
1))
(RETURN])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS INTERPRESS-DSPSCALE PRESS-DSPSCALE DISPLAY-DSPSCALE END-MARKER-CHAR WHITE-SPACE-CHARS)
)
(RPAQQ INTERPRESS-DSPSCALE 35.27778)
(RPAQQ PRESS-DSPSCALE 35.27778)
(RPAQQ DISPLAY-DSPSCALE 1)
(RPAQ END-MARKER-CHAR (CHARACTER 2))
(RPAQ WHITE-SPACE-CHARS (LIST (CHARACTER 32)
(CHARACTER 9)))
(* ;; "Internal functions")
(DEFINEQ
(MAKE-LINE-PREFIX-STRING
[LAMBDA (LineNum TemplateString) (* ; "Edited 21-Apr-88 16:23 by Trigg")
(* ;; "The prefix consists of LineNum embedded in TemplateString followed by a tab.")
(CONCAT (RPLSTRING TemplateString (MINUS (NCHARS LineNum))
(MKSTRING LineNum))
(CHARACTER 9])
(DEL-CHARS
[LAMBDA (TextStream TestFn) (* ; "Edited 21-Apr-88 21:58 by Trigg")
(* ;; "Keep deleting characters while TestFn is true.")
(for while (APPLY* TestFn (GET-NEXT-CHAR TextStream)) do (TEDIT.DELETE TextStream (TEDIT.GETPOINT
TextStream)
1])
(READ-AND-SUM-CHARWIDTHS
[LAMBDA (TextStream Device TestFn TabStops DefaultTabWidth StartingWidth)
(* ; "Edited 21-Apr-88 22:05 by Trigg")
(* ;; "Read characters from TextStream as long as TestFn is true of the character. Return the sum of the stringwidths of the characters read. However, if very first char is CR or end-marker, bail out returning the character read.")
(DECLARE (GLOBALVARS END-MARKER-CHAR))
(LET ((NextChar (GET-NEXT-CHAR TextStream))
(Width StartingWidth))
(if (OR (EQ NextChar (CHARACTER 13))
(EQ NextChar END-MARKER-CHAR))
then (* ;
"If we're looking at a CR or special end-marker, bail out.")
NextChar
else (* ;
"else keep summing stringwidths while TestFn is true.")
(for while (APPLY* TestFn NextChar)
do [SETQ Width (if (EQ NextChar (CHARACTER 9))
then (* ; "tabs have to be handled special")
(if (for TabStop in TabStops thereis (GREATERP TabStop
Width))
else (PLUS Width DefaultTabWidth))
else (PLUS Width (SELECTION-WIDTH TextStream Device]
(SKIP-CHAR TextStream)
(SETQ NextChar (GET-NEXT-CHAR TextStream)))
Width])
(SELECTION-WIDTH
[LAMBDA (TextStream Device) (* ; "Edited 21-Apr-88 21:11 by Trigg")
(* ;;
"Return the stringwidth that the current selection has assuming it's printed to Device.")
(LET ((Looks (TEDIT.GET.LOOKS TextStream)))
(STRINGWIDTH (TEDIT.SEL.AS.STRING TextStream (TEDIT.GETSEL TextStream))
(FONTCREATE (LISTGET Looks 'FAMILY)
(LISTGET Looks 'SIZE)
[OR (LISTGET Looks 'FACE)
(LIST (LISTGET Looks 'WEIGHT)
(LISTGET Looks 'SLOPE)
(LISTGET Looks 'EXPANSION]
0 Device])
(GET-NEXT-CHAR
[LAMBDA (TextStream) (* ; "Edited 21-Apr-88 21:21 by Trigg")
(* ;; "Return the next character in the textstream as an atom, i.e. the character just to the right of the current typein point.")
(NTHCHAR (TEDIT.SEL.AS.STRING TextStream (TEDIT.SETSEL TextStream (TEDIT.GETPOINT TextStream)
1))
1])
(SKIP-CHAR
[LAMBDA (TextStream) (* ; "Edited 21-Apr-88 22:04 by Trigg")
(TEDIT.SETSEL TextStream (ADD1 (TEDIT.GETPOINT TextStream))
0])
(WHITE-SPACE-P
[LAMBDA (Char)
(DECLARE (GLOBALVARS WHITE-SPACE-CHARS)) (* ; "Edited 21-Apr-88 21:43 by Trigg")
(FMEMB Char WHITE-SPACE-CHARS])
(NONWHITE-SPACE-P
[LAMBDA (Char)
(DECLARE (GLOBALVARS WHITE-SPACE-CHARS END-MARKER-CHAR)) (* ; "Edited 21-Apr-88 22:27 by Trigg")
(AND (NOT (FMEMB Char WHITE-SPACE-CHARS))
(NEQ Char END-MARKER-CHAR)
(NEQ Char (CHARACTER 13])
)
(PUTPROPS TEDIT-LINE-NUMBERING COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2030 9239 (MAKE-LINE-BREAKS 2040 . 9237)) (9662 14291 (MAKE-LINE-PREFIX-STRING 9672 .
10049) (DEL-CHARS 10051 . 10545) (READ-AND-SUM-CHARWIDTHS 10547 . 12421) (SELECTION-WIDTH 12423 .
13171) (GET-NEXT-CHAR 13173 . 13626) (SKIP-CHAR 13628 . 13831) (WHITE-SPACE-P 13833 . 14018) (
NONWHITE-SPACE-P 14020 . 14289)))))
STOP