(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