;;;-*- Mode: Lisp; Base: 10.; Fonts: CPTFONT; Package: USER -*- ;;; ;;; $Header: /ct/browser/newview.l,v 1.15 84/08/17 00:09:53 jmiller Exp $ ;;; ;;; Hacked 16 August 1985 Richard Mark Soley for Lambda port ;;; **************************************************************** ;;; ;;; John L. Shelton ;;; ;;; New View ;;; ;;; New configuration: JRM, 4/4/84 ;;; ;;; This file is part of a proprietary software project. Source ;;; code and documentation describing implementation details are ;;; available on a confidential, non-disclosure basis only. These ;;; materials, including this file in particular, are trade secrets ;;; of Computer * Thought Corporation. ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; All Rights Reserved. ;;; ;;; Reference materials: ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; The following code assumes familiarity with these materials. ;;; Ensure presence of needed files. (comment Assumes ct_load and some suitable file_map are present) (eval-when (compile load eval) (ct_load 'aip)) ;AIP macros pkg. (eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg. #-LMI ; for now (eval-when (compile load eval) (ct_load 'bufship)) ;editor interface (eval-when (compile load eval) (ct_load 'percent)) ;different border (ct_load 'moby100) ;Fonts (ct_load 'cttr18) ;Fonts (ct_load 'brchars) ;Fonts for view window side menu #| New View is issued to replace the old view, which was cumbersome and slow. New View reads and displays files, with fonts, in a pleasing manner for the user. When in user interaction mode, multiple page files are scrollable; the user can go forward or backward by pages, half pages, quarter pages, or the whole file. This is controlled by a menu at the top of the view window. Other menu items may be added. When not in user interaction mode, there is no menu at the top of the screen. Files can be viewed with or without comments. If viewed without comments, the comments may be used as TAGS to delimit locations in the file. Internally, files are stored as arrays of arrays of characters. There is one 120 element array for each line displayed; the entire file is stored in a large array of line arrays. |# ;;; Flavor definitions ;;;New debugger-like viewing frame -- jrm & sr, 4/4/84 (defflavor viewing_frame ((filename "") (first-displayed-line 0) (last-displayed-line 0) (number-of-lines-read 0) (first-line 0) (last-line nil) (intervals nil) (commented-p nil) (curr-font 0) (font-names '(fonts:cptfont)) line-arrays old-item-list ) (tv:pop-up-notification-mixin tv:bordered-constraint-frame-with-shared-io-buffer #+(or LMI TI) tv:select-mixin) (:default-init-plist :panes '((menu_pane tv:command-menu-pane :item-list (("" :no-select t))) (text_pane truncating-mousing-window-pane-with-percent :more-p nil :blinker-p nil)) :constraints '((menu . ((dummy-pane) ((dummy-pane :horizontal (1.0) (menu_pane text_pane) ((menu_pane 75. #| #+3600 0.06 #+cadr 0.08 |#)) ((text_pane :even)))))) (no-menu . ((text_pane) ((text_pane :even))))) :save-bits t) :gettable-instance-variables :initable-instance-variables) ;;; A special kind of window that is a pane (pain) and also lets mouse ;;; clicks get into the input stream in list format. (defflavor truncating-mousing-window-pane-with-percent () (#+(or LMI TI) tv:select-mixin tv:list-mouse-buttons-mixin tv:pane-mixin tv:percent-mixin tv:truncating-window) (:default-init-plist :label '(:string "" :font fonts:hl12b) :font-map '(fonts:cptfont fonts:cptfontb fonts:tr12i))) ;;; Externally callable stuff. ;;; SET_FILE is the way to tell a viewing window what file to look at. You have ;;; the option of specifying the file name (or ct_load name), whether or not there ;;; are comments, an optional label, and whether or not to reload the file despite ;;; all else. (If you ask to set a file to what it already is, no action is taken unless ;;; you ask to FORCE the operation.) (defmethod (viewing_frame :set_file) (file &optional (comments nil) (label nil) (force-p nil)) (if (symbolp file) (setq file (ct_load_get file))) (cond ((and file ;New, existing file. (or force-p (not (string-equal file filename))) (probef file)) (send self ':int-set-file file comments) (send self ':send-pane 'text_pane ':set-label `(:string ,(or label (format nil "Viewing ~A" file)) :font fonts:tr12b)) (setq filename file first-displayed-line 0) (send self ':send-pane 'text_pane ':set-percent 0)) ((not (probef file)) ;New file, doesn't exist. (send self ':int-set-no-file) (send self ':send-pane ':text_pane ':set-label "File not found.")) (file ;Same old file (setq first-displayed-line 0) (send self ':send-pane 'text_pane ':set-percent 0) (send self ':send-pane 'text_pane ':set-label `(:string ,(or label (format nil "Viewing ~A" file)) :font fonts:tr12b))))) ;;; Allows the selection of a tagged-interval from the file. This adjusts ;;; the FIRST-LINE and LAST-LINE variables, which control what portion of ;;; the file the user can look at. This expects a tag which is looked up in the ;;; list of known intervals. If the file is not commented, or the interval does ;;; not exist, we beep the window, and make no changes. ;;; ;;; If the tag is ':ALL, this is a special case. We allow display of the entire ;;; file by setting first line to 0, and last-line to nil. (defmethod (viewing_frame :set_interval) (tag) (cond ((eq tag ':all) ;Special case (setq first-line 0 last-line nil first-displayed-line 0) (send self ':display-page)) ((not commented-p) (beep)) ;no comments. (t (let ((range (cdr (assoc tag intervals)))) (cond ((not range) (beep)) ;no range. (t (setq first-line (first range) last-line (second range) first-displayed-line first-line) (send self ':display-page))))))) ;;;GET_FILE_SEGMENT reads the portion of the file between STARTING_BYTE and ;;;ENDING_BYTE, setting that file segment up in LINE-ARRAYS. The real reading ;;;work is done by INT-GET-FILE-SEGMENT, which receives GET_FILE_SEGMENT's ;;;optional argument specifying whether ^Z markers should be ignored (see the ;;;revised version of the browser). GET_FILE_SEGMENT also gives the user the ;;;option of specifying the file name (or ct_load name), whether or not there ;;;are comments, an optional label, and whether or not to reload the file ;;;despite all else. (If you ask to set a file to what it already is, no ;;;action is taken unless you ask to FORCE the operation.) If IGNORE-C-Z-MARKERS ;;;is non-null, INT-GET-FILE-SEGMENT will watch out for special markers of ;;;the form " ", and not incorporate them into the display -- these markers ;;;are used in the new Browser to mark the beginnings of sections, subsections, ;;;and the like. ;;; ;;;This is a modified version of JLS's SET_FILE method -- JRM, 5/6/84 (defmethod (viewing_frame :get_file_segment) (file startingbyte endingbyte &optional (comments nil) (label nil) (force-p nil) (ignore-c-z-markers nil)) (if (symbolp file) (setq file (ct_load_get file))) (cond ((and file ;New, existing file. (or force-p (not (string-equal file filename))) (probef file)) (send self ':int-get-file-segment file startingbyte endingbyte comments ignore-c-z-markers) (send self ':send-pane 'text_pane ':set-label `(:string ,(or label (format nil "Viewing ~A" file)) :font fonts:tr12b)) (setq filename file first-displayed-line 0) (send self ':send-pane 'text_pane ':set-percent 0)) ((not (probef file)) ;New file, doesn't exist. (send self ':int-set-no-file) (send self ':send-pane ':text_pane ':set-label "File not found.")) (file ;Same old file (setq first-displayed-line 0) (send self ':send-pane 'text_pane ':set-percent 0) (send self ':send-pane 'text_pane ':set-label `(:string ,(or label (format nil "Viewing ~A" file)) :font fonts:tr12b))))) ;;; ;;; INT-GET-FILE-SEGMENT ;;; (defmethod (viewing_frame :int-get-file-segment) (file starting_byte ending_byte comments ignore-c-z-markers) (setq line-arrays (make-array 25. ':type 'art-q ':leader-list (list 0)) intervals nil commented-p comments) (setq curr-font 0) (with-open-file (foo file ':IN) (send self ':parse-mode-line foo) ;possibly read modeline ;;Set the file pointer to STARTING_BYTE to begin reading. (send foo ':set-pointer starting_byte) ;;If there are c-z markers, it's the first line from this point -- read it and ;;skip it. (when ignore-c-z-markers (readline foo)) ;;Read the file... (loop with string and i = 0 do (setq string (readline foo 'EOF)) ;;Stop at EOF or when the current file position is >= ENDING_BYTE until (or (eq string 'EOF) (>= (send foo ':read-pointer) ending_byte)) ;;If IGNORE-C-Z-MARKERS is on and the current string is a marker, ;;ignore it. unless (and ignore-c-z-markers (marker-line-p string)) ;;Finally -- accumulate the string do (cond ((and comments (commented-p string)) ;If TAG comment, look (send self ':maybe-accumulate-tag string)) ;for a tag. ((and (> (string-length string) 2) ;If ADA comment, NEVER (string-equal "--;" string 0 0 3 3)) t) ;display it. (t (send self ':add-new-line string))) ;Else, display. (setq i (add1 i)) finally (setq number-of-lines-read i)))) ;;;MARKER-LINE-P: ************************************************************ ;;;T if the line begins with " " (i.e., 5 spaces and a C-Z). (defun marker-line-p (string) (and (> (string-length string) 6) (equal (substring string 0 6) " "))) ;;; A no-op. (defmethod (viewing_frame :restrict_range) (&rest ignore) nil) ;;; *** Soley added 23 March 84 --------- (defvar *redisplay-on-refresh* nil) (defmethod (viewing_frame :after :refresh) (&rest ignore) (if *redisplay-on-refresh* (send self ':display-page))) ;;; *** END Soley added 23 March 84 ----- ;;; *** Nick added 2 Feb 86 ----- #+LMI (defmethod (viewing_frame :io-buffer) () tv:io-buffer) ;;; *** END Nick added 2 Feb 86 ----- ;;; Allow the user to move around a document. An extra menu item can be supplied, ;;; if desired. The item MUST have a value of :extra to be detected. If the user ;;; clicks on this item, this method will return ':extra. ;;;New debugger-like window -- jrm, 4/4/84 #| NOTE -- This version uses the new BRCHARS font characters: A: Active end-of-file a: Inactive end-of-file B: Active beginning-of-file b: Inactive beginning-of-file C: Active next page c: Inactive next page D: Active previous page d: Inactive previous page E: Active NEXT e: Inactive NEXT F: Active PREV f: Inactive PREV G: Active EXIT g: Inactive EXIT H: Active XREF h: Inactive XREF |# (defmethod (viewing_frame :let_user_scroll) (doc-file &optional extra-item &aux mp tp lines itemlist) (unless (eq (send self ':configuration) 'menu) (send self ':set-configuration 'menu)) (send self ':display-page) (setq mp (send self ':get-pane 'menu_pane)) (setq tp (send self ':get-pane 'text_pane)) (setq lines (- (multiple-value-bind (nil h) (send tp ':size-in-characters) h) 1)) (let-globally ((*redisplay-on-refresh* 't)) ;;; *** Soley added 23 March 84 (loop for input = (send tp ':any-tyi) with xref-return = nil ;; First, update menu at top. initially (setq itemlist `( ;;If this file's document node has a PRIORNODE, ;;put up an active PREV item; otherwise, an inactive one. ,(cond ((first (send doc-file ':priornode)) '("F" :value :previous :font fonts:brchars :documentation "Go to the previous document")) (t '("f" :no-select t :font fonts:brchars))) ("" :no-select t) ("" :no-select t) ;;If we're at the top of the file, put up an inactive ;;beginning-of-file marker; otherwise, an active one. ,(cond ((= first-line first-displayed-line) '("b" :no-select t :font fonts:brchars)) (t '("B" :value :top-of-file :font fonts:brchars :documentation "Go to the top of this window"))) ("" :no-select t) ;;If we're at the top of the file, put up an inactive ;;previous-page marker; otherwise, an active one. ,(cond ((= first-line first-displayed-line) '("d" :no-select t :font fonts:brchars)) (t '("D" :value :previous-page :font fonts:brchars :documentation "Move backward: L,M: one page, R: one line"))) ("" :no-select t) ("" :no-select t) ;;If we're not at the bottom of the file, put up an active next-page ;;marker; otherwise, an inactive one. ,(cond ((>= (+ first-displayed-line lines) (or last-line (1- (array-active-length line-arrays)))) '("c" :no-select t :font fonts:brchars)) (t '("C" :value :next-page :font fonts:brchars :documentation "Move forward: L,M: one page, R: one line"))) ("" :no-select t) ;;If we're not at the bottom of the file, put up an active ;;end-of-file marker; otherwise, an inactive one. ,(cond ((>= (+ first-displayed-line lines) (or last-line (1- (array-active-length line-arrays)))) '("a" :no-select t :font fonts:brchars)) (t '("A" :value :bottom-of-file :font fonts:brchars :documentation "Go to the bottom of this window"))) ("" :no-select t) ("" :no-select t) ;;If this file's document node has a NEXTNODE, ;;put up an active NEXT item; otherwise, an inactive one. ,(cond ((first (send doc-file ':nextnode)) '("E" :value :next :font fonts:brchars :documentation "Go to the next document")) (t '("e" :no-select t :font fonts:brchars))) ("" :no-select t) ("" :no-select t) ;;If there are cross-references in this node, put up an active ;;XREFS item; otherwise an inactive one. ,(cond ((send doc-file ':xrefs) `("H" :value :xrefs :font fonts:brchars :documentation "Jump to one of this document's cross references")) (t `("h" :no-select t :font fonts:brchars))) ("" :no-select t) ("" :no-select t) ("G" :value :exit :font fonts:brchars :documentation "Stop looking at this document") ,@(if extra-item '(extra-item ("" :no-select t)) '(("" :no-select t))))) (send mp ':set-item-list itemlist) (setq old-item-list itemlist) do ;;Get and process an item (cond ((and (listp input) (eq (car input) ':menu) (selectq (cheap-mouse-button-translation input) ((:left :middle) (cond ((eq (third (second input)) ':top-of-file) (send self ':back-page 2 lines) t) ((eq (third (second input)) ':previous-page) (send self ':back-page 1 lines) t) ((eq (third (second input)) ':next-page) (send self ':forward-page 1 lines) t) ((eq (third (second input)) ':bottom-of-file) (send self ':forward-page 2 lines) t) ((eq (third (second input)) ':exit) (return t)) ((eq (third (second input)) ':previous) (return 'previous)) ((eq (third (second input)) ':next) (return 'next)) ((eq (third (second input)) ':xrefs) (setq xref-return (send doc-file ':select-xref)) (cond (xref-return (return `(xref ,xref-return))) (t t))) (t (beep)))) (:right (cond ((eq (third (second input)) ':top-of-file) ;same (send self ':back-page 2 lines) t) ((eq (third (second input)) ':previous-page) ;up 1 line (send self ':backup-one-line) t) ((eq (third (second input)) ':next-page) ;down 1 line (send self ':advance-one-line) t) ((eq (third (second input)) ':bottom-of-file) ;same (send self ':forward-page 2 lines) t) ((eq (third (second input)) ':exit) ;same (return t)) ((eq (third (second input)) ':previous) ;same (return 'previous)) ((eq (third (second input)) ':next) ;same (return 'next)) ((eq (third (second input)) ':xrefs) ;same (setq xref-return (send doc-file ':select-xref)) (cond (xref-return (return `(xref ,xref-return))) (t t))) (t (beep))))))) ((listp input) (beep)) ((= input #\m-<) (send self ':back-page 2 lines) t) ((= input #\c-V) (send self ':forward-page 1 lines) t) ((= input #\c-n) (send self ':advance-one-line) t) ((= input #\c-p) (send self ':backup-one-line) t) ((= input #\m-V) (send self ':back-page 1 lines) t) ((= input #\m->) (send self ':forward-page 2 lines) t) ((= input #\end) (return t)) ((memq input '(#\clear-screen #\c-L)) (send (send self ':superior) ':refresh)) (t (beep))) ;;Re-compute the menu... (setq itemlist `( ;;If this file's document node has a PRIORNODE, ;;put up an active PREV item; otherwise, an inactive one. ,(cond ((first (send doc-file ':priornode)) '("F" :value :previous :font fonts:brchars :documentation "Go to the previous document")) (t '("f" :no-select t :font fonts:brchars))) ("" :no-select t) ("" :no-select t) ;;If we're at the top of the file, put up an inactive ;;beginning-of-file marker; otherwise, an active one. ,(cond ((= first-line first-displayed-line) '("b" :no-select t :font fonts:brchars)) (t '("B" :value :top-of-file :font fonts:brchars :documentation "Go to the top of this window"))) ("" :no-select t) ;;If we're at the top of the file, put up an inactive ;;previous-page marker; otherwise, an active one. ,(cond ((= first-line first-displayed-line) '("d" :no-select t :font fonts:brchars)) (t '("D" :value :previous-page :font fonts:brchars :documentation "Move backward: L,M: one page, R: one line"))) ("" :no-select t) ("" :no-select t) ;;If we're not at the bottom of the file, put up an active next-page ;;marker; otherwise, an inactive one. ,(cond ((>= (+ first-displayed-line lines) (or last-line (1- (array-active-length line-arrays)))) '("c" :no-select t :font fonts:brchars)) (t '("C" :value :next-page :font fonts:brchars :documentation "Move forward: L,M: one page, R: one line"))) ("" :no-select t) ;;If we're not at the bottom of the file, put up an active ;;end-of-file marker; otherwise, an inactive one. ,(cond ((>= (+ first-displayed-line lines) (or last-line (1- (array-active-length line-arrays)))) '("a" :no-select t :font fonts:brchars)) (t '("A" :value :bottom-of-file :font fonts:brchars :documentation "Go to the bottom of this window"))) ("" :no-select t) ("" :no-select t) ;;If this file's document node has a NEXTNODE, ;;put up an active NEXT item; otherwise, an inactive one. ,(cond ((first (send doc-file ':nextnode)) '("E" :value :next :font fonts:brchars :documentation "Go to the next document")) (t '("e" :no-select t :font fonts:brchars))) ("" :no-select t) ("" :no-select t) ;;If there are cross-references in this node, put up an active ;;XREFS item; otherwise an inactive one. ,(cond ((send doc-file ':xrefs) `("H" :value :xrefs :font fonts:brchars :documentation "Jump to one of this document's cross references")) (t `("h" :no-select t :font fonts:brchars))) ("" :no-select t) ("" :no-select t) ("G" :value :exit :font fonts:brchars :documentation "Stop looking at this document") ,@(if extra-item '(extra-item ("" :no-select t)) '(("" :no-select t))))) ;;;but only re-draw it if its contents have changed. (unless (equal itemlist old-item-list) (send mp ':set-item-list itemlist) (setq old-item-list itemlist))))) (defun cheap-mouse-button-translation (menu-blip) (selectq (third menu-blip) (1 ':left) (2 ':middle) (4 ':right) (otherwise (ferror "Illegal blip passed to CHEAP-MOUSE-BUTTON-TRANSLATION: ~%~a" menu-blip)))) (defmethod (viewing_frame :let_user_send_to_editor) (buffername &optional make-buffer-current-p) (let ((buffer (get-zmacs-buffer buffername)) (val (send self ':let_user_scroll '("Send to editor" :value :extra :font fonts:cttr18 :documentation "Send this to the editor")))) (when (eq val ':extra) (editor-set-string (send self ':whole-file) buffer) (font-other-buffer buffer font-names) (if make-buffer-current-p (make-buffer-current-buffer buffer))))) ;;; Clears the text pane (defmethod (viewing_frame :clear_screen) () (send self ':send-pane 'text_pane ':clear-screen) (send self ':send-pane 'text_pane ':set-label "")) ;;; Internal stuff ;;; Returns a fat-string that is the entire file. (defmethod (viewing_frame :whole-file) () (loop for i from 0 to (1- (array-active-length line-arrays)) for str = (aref line-arrays i) with string = (make-array 100. ':type 'art-fat-string ':leader-list (list 0)) do (if str (setq string (string-append string str #\return))) finally (return string))) ;;; Returns a fat-string that is the region specified (defmethod (viewing_frame :tagged-region) (start end) (loop for i from start to end with string = (make-array 100. ':type 'art-fat-string ':leader-list (list 0)) do (if (aref line-arrays i) (setq string (string-append string (aref line-arrays i) #\return))) finally (return string))) ;;; Removes all CTRL-F stuff from a string. (defun remove-fonts (string) (loop for i from 0 to (1- (string-length string)) with out-string = "" do (if (= (aref string i) 6.) (setq i (1+ i)) (setq out-string (string-append out-string (aref string i)))) finally (return out-string))) (defmethod (viewing_frame :back-page) (button lines) (setq first-displayed-line (max first-line (selectq button (2 first-line) (4 (- first-displayed-line (// lines 2.))) (1 (- first-displayed-line lines))))) (send self ':display-page)) (defmethod (viewing_frame :backup-one-line) nil (let ((text-pane (send self ':get-pane 'text_pane)) (page-lines (- last-displayed-line first-displayed-line -1)) (pc)) (cond ((> first-displayed-line 0) (setq first-displayed-line (sub1 first-displayed-line) last-displayed-line (sub1 last-displayed-line)) (send text-pane ':home-cursor) (send text-pane ':insert-line) (send-line-out (aref line-arrays first-displayed-line) text-pane) (setq pc (list (percent first-displayed-line (list first-line (or last-line (1- (array-active-length line-arrays))))) (percent (+ first-displayed-line (1- page-lines)) (list first-line (or last-line (1- (array-active-length line-arrays))))))) (if (zerop (- first-line (or last-line (1- (array-active-length line-arrays))))) (setq pc (list 0. 100.))) (send text-pane ':set-percent pc)) (t (beep))))) #+(or LMI TI) (defun window-current-font-number (window) (loop with current-font = (send window :current-font) for font being the array-elements of (send window :font-map) using (index index) when (eq font current-font) return index finally (return 0))) (defun send-line-out (line stream) #+Symbolics (send stream :editor-line-out line stream) #+(or LMI TI) (loop with current-font = (window-current-font-number stream) for ch being the array-elements of line doing (let ((font (ldb (byte 8 8) ch)) (char (ldb (byte 8 0) ch))) (unless (= font current-font) (setq current-font font) (send stream :set-current-font font)) (send stream :tyo char)))) (defmethod (viewing_frame :forward-page) (button lines) (setq first-displayed-line (min (- (or last-line (array-active-length line-arrays)) 3) (selectq button (2 (- (or last-line (array-active-length line-arrays)) lines -2)) (4 (+ first-displayed-line (// lines 2.))) (1 (+ first-displayed-line lines))))) (send self ':display-page)) (defmethod (viewing_frame :advance-one-line) nil (let ((text-pane (send self ':get-pane 'text_pane)) (page-lines (- last-displayed-line first-displayed-line -1)) (pc)) (cond ((< last-displayed-line (sub1 number-of-lines-read)) (setq first-displayed-line (add1 first-displayed-line) last-displayed-line (add1 last-displayed-line)) (send text-pane ':home-cursor) (send text-pane ':delete-line) (send text-pane ':home-down) (send-line-out (aref line-arrays last-displayed-line) text-pane) (setq pc (list (percent first-displayed-line (list first-line (or last-line (1- (array-active-length line-arrays))))) (percent (+ first-displayed-line (1- page-lines)) (list first-line (or last-line (1- (array-active-length line-arrays))))))) (if (zerop (- first-line (or last-line (1- (array-active-length line-arrays))))) (setq pc (list 0. 100.))) (send text-pane ':set-percent pc)) (t (beep))))) (defmethod (viewing_frame :forward-page) (button lines) (setq first-displayed-line (min (- (or last-line (array-active-length line-arrays)) 3) (selectq button (-1 (add1 first-displayed-line)) (2 (- (or last-line (array-active-length line-arrays)) lines -2)) (4 (+ first-displayed-line (// lines 2.))) (1 (+ first-displayed-line lines))))) (send self ':display-page)) ;;; INT-SET-FILE ;;; ;;; SOON, WE WANT TO ADD A FEATURE TO SAVE AWAY OLD LINE ARRAYS FOR INSTANT ;;; RECALL. ;;; (defmethod (viewing_frame :int-set-file) (file comments) (setq line-arrays (make-array 25. ':type 'art-q ':leader-list (list 0)) intervals nil commented-p comments) (setq curr-font 0) (with-open-file (foo file ':IN) (send self ':parse-mode-line foo) ;possibly read modeline (loop with string for i = 0 then (add1 i) do (setq string (readline foo 'EOF)) until (eq string 'EOF) do (cond ((and comments (commented-p string)) ;If TAG comment, look (send self ':maybe-accumulate-tag string)) ;for a tag. ((and (> (string-length string) 2) ;If ADA comment, NEVER (string-equal "--;" string 0 0 3 3)) t) ;display it. (t (send self ':add-new-line string))) ;Else, display. finally (setq number-of-lines-read i)))) ;;; To set up a view window to display nothing interesting. (defmethod (viewing_frame :int-set-no-file) () (setq line-arrays (make-array 1. ':type 'art-q ':leader-list (list 0)) intervals nil commented-p nil) (setq curr-font 0) (send self ':add-new-line " ")) ;Put a single space in. ;;; Adds a line of text to the master array. The first element in each line array ;;; is an integer indicating the current font. As we read in the line-array, we ;;; keep track fo the current font to do the next line correctly. When printing a ;;; file, we can always use the correct font because each line knows what font it ;;; starts in. ;;; We build a line of 16-bit characters which include font chars. (defmethod (viewing_frame :add-new-line) (string &aux (line-array (make-array 10. ':type art-fat-string ':leader-list (list 0)))) (loop for i from 0 to (1- (string-length string)) with l = (1- (string-length string)) with font = curr-font do (if (and (= (aref string i) 6.) ;If font change char. (not (= i l))) ;& not @ eol. (setq font (- (aref string (1+ i)) #/0) ;update font i (1+ i)) (array-push-extend ;else keep char. line-array (dpb font %%ch-font (aref string i)))) finally (setq curr-font font)) ;update current font ;for next time (array-push-extend line-arrays line-array)) ;Add new line. ;;; Reads in the first line, and checks to see if it is an attribute line. If so, ;;; update the font map for the text pane. If not, add this line to the list of lines. (defmethod (viewing_frame :parse-mode-line) (stream &aux (string (readline stream))) (cond ((and (string-search "-*-" string) (string-search "onts:" string)) (send self ':send-pane 'text_pane ':set-font-map (setq font-names (get_fonts (substring string (+ 5 (string-search "onts:" string))))))) ((and (> (string-length string) 2) ;If a special ADA comment, (string-equal "--;" string 0 0 3 3)) t) ;never display it. (t (setq font-names (list 'fonts:cptfont)) (send self ':add-new-line string)))) ;;; creates a list of fonts by scanning a string, discarding ;;; spaces, parens, commas, and terminating at a semicolon. Uses ;;; font_patch. (defun get_fonts (string) (loop with begin = (string-search-not-set '(#/) #/- #/; #\space #/, #/( #/*) string) and answer = nil as search = (string-search-set '(#/) #/- #/; #\space #/, #/( #/*) string begin) doing (push (intern (string-upcase (nsubstring string begin search)) 'fonts) answer) (if (or (null search) (memq (aref string search) '(#/) #/- #/;)) (null (setq begin (string-search-not-set '(#/) #/- #/; #\space #/, #/( #/*) string search)))) (return (nreverse answer))))) #| Took it back to old Virginny -- 14 August 83 RMSoley (defun get_fonts (string) (loop for char being the array-elements of string with word with list do (cond ((or (eq char #/)) (eq char #/-) (eq char #/;)) (return (font_patch (append list (list word))))) ((eq char #/()) ;if a paren, ignore ((or (eq char #\space) (eq char #/,)) ;if space or comma, (setq list (append list (list word)) ;start new word. word nil)) (t (setq word (append word (list char))))))) ;;; Takes a list of lists of fixnums and returns a list of atoms ;;; interned in the fonts: package. Removes any null items. (defun font_patch (list) (loop for item in list unless (null (car item)) collect (intern (string-upcase (maknam item)) 'fonts))) |# ;;; Definition of a commented string. Either it begins with a semi-colon, or ;;; a font-change followed by a semi-colon. (defun commented-p (string) (or (and (> (string-length string) 0) (= (ct_nth_char string 0) #/;)) (and (> (string-length string) 2) ;If long enough (= (ct_nth_char string 0) 6.) ;If first char is ctrl-f (= (ct_nth_char string 2) #/;)))) ;;; We know this line is a comment. Check for BEGIN or END tag, and if ;;; so, record on the list of intervals. (defmethod (viewing_frame :maybe-accumulate-tag) (string) (setq string (remove-fonts string)) ;get rid of font-changes (cond ((eq (marked_p string) 'begin) (push (list (marker_name string) (array-active-length line-arrays) nil) intervals)) ((eq (marked_p string) 'end) (cond ((assoc (marker_name string) intervals) (rplaca (cddr (assoc (marker_name string) intervals)) (1- (array-active-length line-arrays)))))))) ;;; Returns 'BEGIN or 'END if a comment line has a begin or end marker ;;; in it; nil otherwise. (defun marked_p (string) (cond ((string-search "begin" string) 'begin) ((string-search "end" string) 'end) (t nil))) ;;; Given that there is a marker here, find it. (defun marker_name (string &aux p1 p2) (cond ((eq (marked_p string) 'begin) (setq p1 (+ 5 (string-search "begin" string))) (setq p1 (loop for i from p1 until (neq #\space (ct_nth_char string i)) finally (return i))) (setq p2 (string-search-char #\space string p1)) (substring string p1 p2)) ((eq (marked_p string) 'end) (setq p1 (+ 3 (string-search "end" string))) (setq p1 (loop for i from p1 until (neq #\space (ct_nth_char string i)) finally (return i))) (setq p2 (string-search-char #\space string p1)) (substring string p1 p2)))) ;;; Displays a page of text in the text pane. If the first-displayed-line is out of ;;; range, set it to be the first displayable line of the document. (defmethod (viewing_frame :display-page) (&aux pc (tp (send self ':get-pane 'text_pane))) (unless (<= first-line first-displayed-line (or last-line 9999999999.)) (setq first-displayed-line first-line)) (let ((page-lines (- (multiple-value-bind (nil h) ;get right number of lines. (send tp ':size-in-characters) h) 1))) (loop for i from first-displayed-line to (setq last-displayed-line (min (+ first-displayed-line page-lines) (or last-line (1- (array-active-length line-arrays))))) initially (send tp ':clear-screen) unless (= i first-displayed-line) do (send tp ':tyo #\return) do (send-line-out (aref line-arrays i) tp)) (setq pc (list (percent first-displayed-line (list first-line (or last-line (1- (array-active-length line-arrays))))) (percent (+ first-displayed-line (1- page-lines)) (list first-line (or last-line (1- (array-active-length line-arrays))))))) (if (zerop (- first-line (or last-line (1- (array-active-length line-arrays))))) (setq pc (list 0. 100.))) (send tp ':set-percent pc) )) ;;; Calculates what percent numb1 is in the range. For example, ;;;(percent 140 '(100 200)) --> 40, since 140 is 40% of the way from 100 to 200. (defun percent (numb1 range) (if (zerop (- (cadr range) (car range))) 0. (fix (min 100. (max 0. (// (* (- numb1 (car range)) 100.) (- (cadr range) (car range)))))))) ;;; **************************************************************** ;;; Interface to editor. ;;; **************************************************************** (defvar *attr-line* "-- -*- Mode: Ada; Fonts: cptfontb,hl12bi,cptfontb,tr12b -*- ") ;;; You can supply a filename or an instance of a view window. Either ;;; will be searched for the tagged region. Said tagged region will be ;;; inserted into the buffer named by BUFFER. (That can be either a name ;;; or a buffer itself. The insertion is done either at the END or the ;;; BEGINning of the buffer, or at the CURRENT point, or it can REPLACE ;;; the contents of the buffer. ;;; ;;; The specified text will be placed in the buffer fonted correctly, ;;; but you will need to tell the buffer the correct fonts (defun tagged-region-to-buffer (tag file buffer &optional (buffer-pos ':end) (dont-add-attr-line nil) &aux temp-vu intervals (string "") (null (make-array 1 ':type 'art-fat-string ':leader-list (list 0)))) (if (stringp buffer) (setq buffer (get-zmacs-buffer buffer))) (cond ((stringp file) (setq temp-vu (tv:make-window 'viewing_frame)) (send temp-vu ':set_file file t)) (t (setq temp-vu file))) (setq intervals (send temp-vu ':intervals)) (if (assoc tag intervals) (setq string (send temp-vu ':tagged-region (cadr (assoc tag intervals)) (caddr (assoc tag intervals))))) (unless dont-add-attr-line (setq string (string-append null *attr-line* string))) (selectq buffer-pos (:replace (editor-set-string string buffer)) (:end (editor-append-string string buffer)) (:begin (editor-set-string (string-append string (editor-get-string buffer)) buffer)) (:current (lose 'not-yet-implemented 'tagged-region-to-buffer)))) (compile-flavor-methods viewing_frame truncating-mousing-window-pane-with-percent)