(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:06:11" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LINEAR.;2| 73213 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-LINEARCOMS) IL:|previous| IL:|date:| "13-Apr-88 11:51:14" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LINEAR.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-LINEARCOMS) (IL:RPAQQ IL:SEDIT-LINEARCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-LINEAR) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-LINEAR) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:FUNCTIONS CLEAR-ALL-LINEAR-FORMS CLEAR-LINEAR-FORM RELINEARIZE-PRELINEARIZED-NODE) (IL:FNS CLEAN-UP-AFTER-RELINEARIZATION FIRST-LINE-LINEAR GENERATE-LINEAR-FORM LAST-LINE-LINEAR LINE-FINISHED LINEAR-ITEM-WIDTH LINEARIZE NEW-BLOCK NEXT-LINEAR-ITEM OUTPUT-BITMAP OUTPUT-CONSTANT-STRING OUTPUT-CR OUTPUT-SPACE OUTPUT-STRING PAINT-TO-END-OF-LINE RECOMPUTE-FORMAT-VALUES RELINEARIZE REPAINT REUSE-LINEAR-FORM SHIFT-BLOCK TRY-REUSING-BITS))) (IL:PUTPROPS IL:SEDIT-LINEAR IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-LINEAR IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (DEFUN CLEAR-ALL-LINEAR-FORMS (CONTEXT) (WALK-UP-TREE (SUBNODE 1 (IL:|fetch| ROOT IL:|of| CONTEXT)) CONTEXT #'CLEAR-LINEAR-FORM)) (DEFUN CLEAR-LINEAR-FORM (NODE) (IL:* IL:|;;;| "throw away old linear form (and create new one if a prelinearized node)") (COND ((IL:|fetch| LINEARIZE IL:|of| (IL:|fetch| NODE-TYPE IL:|of| NODE)) (IL:|replace| START-X IL:|of| NODE IL:|with| 0) (IL:|replace| LINEAR-FORM IL:|of| NODE IL:|with| (CREATE-WEAK-LINK NODE))) (T (RELINEARIZE-PRELINEARIZED-NODE NODE))) (IL:|replace| LINEAR-THREAD IL:|of| NODE IL:|with| NIL)) (DEFUN RELINEARIZE-PRELINEARIZED-NODE (NODE) (IL:* IL:|;;;| "we've changed a prelinearized node. fix up the width estimates") (LET ((LITEM (CAR (IL:|fetch| LINEAR-FORM IL:|of| NODE)))) (WHEN (TYPEP LITEM 'STRING-ITEM) (LET ((NEW-WIDTH (STRINGWIDTH (IL:|fetch| STRING IL:|of| LITEM) (IL:|fetch| FONT IL:|of| LITEM) (IL:|fetch| PRIN-2? IL:|of| LITEM)))) (IL:|replace| WIDTH IL:|of| LITEM IL:|with| NEW-WIDTH) (IL:|replace| INLINE-WIDTH IL:|of| NODE IL:|with| NEW-WIDTH) (IL:|replace| PREFERRED-WIDTH IL:|of| NODE IL:|with| NEW-WIDTH) (IL:|replace| ACTUAL-WIDTH IL:|of| NODE IL:|with| NEW-WIDTH) (IL:|replace| ACTUAL-LLENGTH IL:|of| NODE IL:|with| NEW-WIDTH))))) (IL:DEFINEQ (clean-up-after-relinearization (il:lambda (context node following-line y-1 y-2) (il:* il:\; "Edited 17-Nov-87 11:37 by DCB") (il:* il:|;;;| "we've just finished relinearizing this node. adjust the y coordinates of everything that follows, and fix up the rest of the window. y1 and y2 record where the following lines start and how far they must be shifted") (let* ((window (il:fetch display-window il:of context)) (extent (il:windowprop window (quote il:extent))) (bottom (il:fetch window-bottom il:of context)) (left (il:fetch window-left il:of context)) (window-width (il:add1 (il:idifference (il:fetch window-right il:of context) left))) delta ry-1 ry-2) (cond (following-line (il:* il:|;;| "there are lines after this node. fix up the links, adjust their y coordinates, and fix the window's extent") (il:* il:|;;| "used to be replace PrevLine of following.line with (fetch LastLineLinear of node)") (il:replace prev-line il:of following-line il:with (last-line-linear node context)) (il:setq delta (il:idifference (il:fetch next-line-y il:of (il:fetch last-line il:of node)) (il:fetch ycoord il:of following-line))) (when (not (eq 0 delta)) (il:bind (line il:_ following-line) il:do (il:add (il:fetch ycoord il:of line) delta) il:repeatwhile (il:setq line (car (il:fetch next-line il:of line)))) (il:add (il:fetch (il:region il:bottom) il:of extent) delta) (il:add (il:fetch (il:region il:height) il:of extent) (il:iminus delta))) (il:* il:|;;| "if the following stuff isn't off the bottom of the window, we'll have to fix it up") (when (and y-2 (il:igeq y-2 bottom)) (cond ((il:igeq y-2 (il:fetch window-top il:of context)) (il:* il:|;;| "none of the changes were visible, so we just have to twiddle the coordinate system") (il:wyoffset (il:idifference y-1 y-2) window)) ((il:neq y-1 y-2) (cond ((il:igreaterp y-1 y-2) (il:* il:|;;| "bitblt the following lines up, and repaint below them") (il:setq ry-1 y-2) (il:setq ry-2 (il:iplus y-2 1 (il:idifference y-2 y-1))) (if (il:igreaterp ry-2 bottom) (il:bitblt window left (il:iplus (il:idifference y-1 y-2) bottom) window left bottom window-width (il:idifference ry-2 bottom)) (il:setq ry-2 bottom))) (t (il:* il:|;;| "the following stuff moves down, if it hasn't already been overwritten") (cond ((il:igeq y-1 bottom) (il:setq ry-1 (il:fetch ycoord il:of following-line)) (il:setq ry-2 (il:iplus (il:sub1 bottom) (il:idifference y-2 y-1))) (il:bind (next-line il:_ following-line) next-line-y il:while (and next-line (il:igeq (il:setq next-line-y (if (il:setq next-line (car (il:fetch next-line il:of next-line))) (il:fetch ycoord il:of next-line) (il:fetch next-line-y il:of following-line))) ry-2)) il:do (il:setq following-line next-line) (il:setq ry-1 next-line-y)) (il:setq ry-2 (il:iplus ry-1 (il:idifference y-1 y-2))) (il:bitblt window left (il:add1 ry-2) window left (il:add1 ry-1) window-width (il:idifference y-1 ry-2))) (t (il:setq ry-1 y-2))) (il:setq ry-2 bottom))) (il:* il:|;;| "now that we've figured out what needs to be repainted, blank the area and repaint it") (il:bltshade il:whiteshade window left ry-2 window-width (il:add1 (il:idifference ry-1 ry-2))) (when following-line (repaint context (il:fetch indent il:of following-line) (il:fetch base-line-y il:of following-line) (cdr (il:fetch next-line il:of (car (il:fetch prev-line il:of following-line)))) ry-2)))))) (t (il:* il:|;;| "there's nothing after the relinearized material -- blank anything after it on the window and adjust the extent") (when (and y-2 (il:igreaterp y-2 y-1)) (il:bltshade il:whiteshade window left y-1 window-width (il:idifference y-2 y-1))) (il:setq delta (il:fetch next-line-y il:of (il:fetch last-line il:of node))) (il:replace (il:region il:bottom) il:of extent il:with (il:add1 delta)) (il:replace (il:region il:height) il:of extent il:with (il:iminus delta)))))) ) (first-line-linear (il:lambda (node context) (il:* il:\; "Edited 17-Nov-87 11:38 by DCB") (il:* il:|;;;| "find the info which used to be stored in FirstLineLinear (i.e. the tail of the linear form beginning with the first line of this node). we try to step back one more line and then forward; if this is the first line we know it must be the beginning of the root's linear form") (and (il:setq node (il:fetch first-line il:of node)) (if (il:fetch prev-line il:of node) (il:fetch next-line il:of (car (il:fetch prev-line il:of node))) (il:fetch linear-form il:of (il:fetch root il:of context))))) ) (generate-linear-form (il:lambda (node context right-margin) (il:* il:\; "Edited 7-Apr-88 11:02 by woz") (il:* il:|;;;| "we need to compute the linear form of this node. if there's a previously computed linear form and it fits the constraints, we can just reuse it; otherwise call the Linearize method for the node") (let ((current-x (il:|fetch| current-x il:|of| context)) (linearize (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)))) (il:* il:|;;| "this next IF test is ugly. want to reuse the LF if we can. Don't try to reuse the root's LF, becuase it starts with a line start which messes up scan.for.bounds, and the root has no bits on the screen so there's no savings in reusing it. Otherwise check if it has changed, and if it will fit is the new space provided (we might be reshaping), and if all those pass, then reuse the LF.") (cond ((or (null linearize) (and (il:neq node (il:|fetch| root il:|of| context)) (il:neq (il:|fetch| start-x il:|of| node) 0) (not (il:|fetch| changed? il:|of| node)) (or (il:ileq (il:iplus current-x (il:|fetch| actual-width il:|of| node)) right-margin) (il:ileq (il:idifference (il:|fetch| right-margin il:|of| node) (il:|fetch| start-x il:|of| node)) (il:idifference right-margin current-x))) (or (il:|fetch| inline? il:|of| node) (il:igeq (il:idifference (il:|fetch| right-margin il:|of| node) (il:|fetch| start-x il:|of| node)) (il:idifference right-margin current-x))))) (il:* il:|;;| "the old linear form will do") (il:|replace| right-margin il:|of| node il:|with| right-margin) (reuse-linear-form node context)) (t (il:* il:\; "we've got to call the Linearize method. initialize various random fields and do it") (il:|replace| start-x il:|of| node il:|with| current-x) (il:|replace| right-margin il:|of| node il:|with| right-margin) (il:|replace| actual-width il:|of| node il:|with| 0) (il:|replace| first-line il:|of| node il:|with| (car (il:|fetch| current-line il:|of| context))) (il:|replace| current-node il:|of| context il:|with| node) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| 0) (cond ((il:|fetch| super-node il:|of| node) (il:* il:\; "setup pointers to start at the beginning of this nodes linear form.") (il:|replace| linear-pointer il:|of| context il:|with| (il:|fetch| linear-form il:|of| node)) (il:|replace| linear-prev il:|of| context il:|with| node)) (t (il:* il:|;;| "(hack) the linear form of the root doesn't correspond to what linearize.root will produce, since it has the initial line start as its first element. this should be fixed, but in the meantime we'll just skip over it") (il:* il:|;;| "SO: here the linear form of the root is alread set to a list of the first line start and a weak-link. make the linear-pointer point into the list at the weak-link.") (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-form il:|of| node)))))) (il:|replace| actual-llength il:|of| node il:|with| nil) (funcall linearize node context) (il:* il:|;;| "now we're done with this node (and thus its subnodes), so move back to its super.") (il:|replace| current-node il:|of| context il:|with| (il:|fetch| super-node il:|of| node)) (when (not (and (il:|type?| weak-link (il:|fetch| linear-pointer il:|of| context)) (eq (il:fetch destination il:of (il:|fetch| linear-pointer il:|of| context)) node))) (il:* il:|;;| "we should have finished linearizing the node, and so linear-pointer will be at the weak-link. if not, (i guess it didn't need to be relinearized? and thus the matching? test below?) set it there so we can go on.") (set-linear context (cdr (last (il:fetch linear-form il:of node)))) (when (il:|fetch| matching? il:|of| context) (new-block context) (il:|replace| matching? il:|of| context il:|with| nil))) (il:* il:\; "used to be replace LastLineLinear of x with (fetch CurrentLine of context)") (il:|replace| last-line il:|of| node il:|with| (car (il:|fetch| current-line il:|of| context))) (il:|replace| actual-width il:|of| node il:|with| (il:idifference (il:imax (il:|fetch| actual-width il:|of| node) (il:|fetch| current-x il:|of| context)) current-x)) (il:|replace| actual-llength il:|of| node il:|with| (il:idifference (il:|fetch| current-x il:|of| context) current-x))))) (il:|replace| changed? il:|of| node il:|with| nil)) ) (last-line-linear (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 12:47 by DCB") (il:* il:|;;| "find the info which used to be stored in LastLineLinear (i.e. the tail of the linear form beginning with the last line of this node). we try to step back one more line and then forward; if there is no previous line then the whole linear form must be on one line, and thus the last line is simply the root's linear form") (and (il:setq node (il:fetch last-line il:of node)) (if (il:fetch prev-line il:of node) (il:fetch next-line il:of (car (il:fetch prev-line il:of node))) (il:fetch linear-form il:of (il:fetch root il:of context))))) ) (line-finished (il:lambda (context x linear force) (il:* il:\; "Edited 17-Nov-87 11:38 by DCB") (il:* il:|;;;| "we've finished a line which is visible (or above the window) we only flush it if it reuses bits or we're forced") (when (il:fetch below? il:of context) (il:shouldnt "tried to flush a line off the bottom of the screen")) (let ((this-line (car (il:fetch current-line il:of context)))) (when (il:ilessp (il:fetch next-line-y il:of this-line) (il:fetch window-bottom il:of context)) (il:* il:|;;| "this is the last line visible in the window. force it and don't come back") (il:replace below? il:of context il:with t) (il:setq force t)) (cond ((il:ilessp (il:fetch next-line-y il:of this-line) (il:fetch window-top il:of context)) (il:* il:|;;| "it's visible. fix up the block list, and then check if any of them can reuse bits visible in the window") (il:replace block-width il:of (il:fetch current-block il:of context) il:with (il:idifference x (il:fetch block-new-x il:of (il:fetch current-block il:of context)))) (il:replace block-start il:of (or (il:fetch next-block il:of (il:fetch current-block il:of context)) (il:replace next-block il:of (il:fetch current-block il:of context) il:with (il:create line-block))) il:with linear) (when (il:type? line-start (car (il:fetch block-start il:of (il:fetch first-block il:of context)))) (il:replace block-start il:of (il:fetch first-block il:of context) il:with (cdr (il:fetch block-start il:of (il:fetch first-block il:of context))))) (il:for (block il:_ (il:fetch first-block il:of context)) il:by (il:fetch next-block il:of block) il:do (when (and (il:fetch bits? il:of block) (try-reusing-bits context block)) (il:* il:|;;| "found some bits we can reuse, so paint up to this point and make sure we dump the rest of this line") (il:setq force t)) il:repeatuntil (eq block (il:fetch current-block il:of context)) il:finally (when force (il:* il:|;;| "display the rest") (paint-to-end-of-line context linear) (when linear (il:* il:|;;| "that wasn't the last line, so set up for the next") (il:replace repaint-start il:of context il:with linear) (il:replace repaint-line il:of context il:with (car linear)) (il:replace repaint-x il:of context il:with (il:fetch indent il:of (car linear))) (when (and (il:fetch matching? il:of context) (not (il:fetch visible? il:of context)) (il:ileq (il:fetch old-bottom il:of (car linear)) (il:fetch window-top il:of context))) (il:* il:|;;| "we were off the top of the screen, but now we're on") (il:replace visible? il:of context il:with t)))))) (linear (il:* il:|;;| "when it's off the top of the window, we just have to reset things (unless it was the last)") (il:replace repaint-start il:of context il:with linear) (il:replace repaint-line il:of context il:with (car linear)) (il:replace repaint-x il:of context il:with (il:fetch indent il:of (car linear))) (when (and (il:fetch matching? il:of context) (not (il:fetch visible? il:of context)) (il:ileq (il:fetch old-bottom il:of (car linear)) (il:fetch window-top il:of context))) (il:replace visible? il:of context il:with t)))))) ) (linear-item-width (il:lambda (item) (il:* il:\; "Edited 17-Nov-87 11:39 by DCB") (il:* il:|;;;| "determine the amount of horizontal space taken up by this linear form item") (cond ((il:fixp item) item) ((il:type? string-item item) (il:fetch width il:of item)) ((il:listp item) (il:bitmapwidth (cdr item))) (t (il:shouldnt "this doesn't have a linear width")))) ) (linearize (il:lambda (node context right-margin) (il:* il:\; "Edited 13-Apr-88 10:38 by woz") (il:* il:|;;| "fill in the linear form of this node. make sure that we're actually running as an editor (not just a pretty printer)") (cond ((il:|fetch| relinearization-time-stamp il:|of| context) (il:* il:\; "we're actually editing") (prog ((super-node (il:|fetch| current-node il:|of| context))) (when (or (il:neq super-node (il:|fetch| super-node il:|of| node)) (il:ileq (il:|fetch| sub-node-index il:|of| node) (il:|fetch| last-linearized-sub-node-index il:|of| context))) (il:shouldnt "this node shouldn't be linearized now")) (when (and (il:|fetch| matching? il:|of| context) (next-linear context node)) (il:* il:\;  "we're already matching -- all's cool. fix up the LinearThread in case it's been smashed.") (il:|replace| linear-thread il:|of| node il:|with| (il:|fetch| linear-pointer il:|of| context)) (go ok)) (cond ((il:|fetch| linear-thread il:|of| node) (il:* il:\;  "was already linearized -- skip to the appropriate point in the super's linear form") (set-linear context (il:|fetch| linear-thread il:|of| node))) (t (il:* il:\;  "insert this node in the super's linear form") (set-linear context (cons (create-weak-link node) (il:|fetch| linear-pointer il:|of| context))) (il:|replace| linear-thread il:|of| node il:|with| (il:|fetch| linear-pointer il:|of| context)))) (when (il:|fetch| matching? il:|of| context) (il:* il:\;  "we were matching, but lost -- start a new block") (new-block context) (il:|replace| matching? il:|of| context il:|with| nil)) (when (and (not (il:|fetch| below? il:|of| context)) (il:neq (il:|fetch| start-x il:|of| node) 0) (il:igeq (il:|fetch| old-top il:|of| (il:|fetch| first-line il:|of| node)) (il:|fetch| window-bottom il:|of| context)) (or (not (il:|fetch| changed? il:|of| node)) (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)))) (il:* il:\; "we can start matching") (il:|replace| matching? il:|of| context il:|with| t) (when (or (il:|replace| visible? il:|of| context il:|with| (and (il:ileq (il:|fetch| start-x il:|of| node) (il:|fetch| window-right il:|of| context)) (il:ileq (il:|fetch| old-bottom il:|of| (il:|fetch| first-line il:|of| node)) (il:|fetch| window-top il:|of| context)))) t) (il:* il:\;  "the stuff we're matching is visible, so build a block describing it") (new-block context) (let ((block (il:|fetch| current-block il:|of| context)) (line (il:|fetch| first-line il:|of| node))) (il:|replace| bits? il:|of| block il:|with| t) (il:|replace| block-x il:|of| block il:|with| (il:|fetch| start-x il:|of| node)) (cond ((eq (il:|fetch| cache-time il:|of| line) (il:|fetch| relinearization-time-stamp il:|of| context )) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| cached-y il:|of| line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| cached-ascent il:|of| line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| cached-descent il:|of| line)) ) (t (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| line)) ))))) ok (il:* il:\;  "we're ready to actually construct/check the linear form") (generate-linear-form node context (or right-margin (il:|fetch| right-margin il:|of| super-node))) (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|fetch| linear-prev il:|of| context))) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| (il:|fetch| sub-node-index il:|of| node)) (il:|replace| actual-width il:|of| super-node il:|with| (il:imax (il:|fetch| actual-width il:|of| super-node) (il:iplus (il:|fetch| start-x il:|of| node) (il:|fetch| actual-width il:|of| node)))) (return (il:|fetch| inline? il:|of| node)))) (t (il:* il:\;  "we're pretty printing -- just call the Linearize method, or use the fixed linear form") (il:|replace| right-margin il:|of| node il:|with| (or right-margin (il:|fetch| right-margin il:|of| (il:|fetch| super-node il:|of| node))) ) (il:|replace| start-x il:|of| node il:|with| (il:|fetch| current-x il:|of| context)) (cond ((il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)) (let ((me (il:|fetch| current-node il:|of| context))) (il:|replace| current-node il:|of| context il:|with| node) (funcall (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)) node context) (il:|replace| current-node il:|of| context il:|with| me))) (t (il:* il:\;  "this node has a fix linear form (i.e. it's been prelinearized) so just output it") (output-constant-string context (car (il:|fetch| linear-form il:|of| node))))))))) (new-block (il:lambda (context) (il:* il:\; "Edited 8-Jul-87 17:36 by DCB") (il:* il:|;;;| "start a new block in the block list describing this line (we've started or stopped matching)") (let ((block (il:fetch current-block il:of context)) (x (il:fetch current-x il:of context))) (when (il:neq x (il:fetch block-new-x il:of block)) (il:* il:|;;| "the current one is non empty, so we need a new one. fill in the width of the current one before we move on. if there isn't already a next block we'll have to create one") (il:replace block-width il:of block il:with (il:idifference x (il:fetch block-new-x il:of block))) (il:replace current-block il:of context il:with (il:setq block (or (il:fetch next-block il:of block) (il:replace next-block il:of block il:with (il:create line-block))))) (il:replace block-new-x il:of block il:with x)) (il:replace block-start il:of block il:with (il:fetch linear-pointer il:of context)) (il:replace bits? il:of block il:with nil))) ) (next-linear-item (il:lambda (linear) (il:* il:\; "Edited 13-Apr-88 11:46 by woz") (il:* il:|;;;| "find the first linear item starting from this point, expanding subnodes") (il:|do| (cond ((not (il:listp linear)) (il:* il:|;;|  "we're at the end of this node's linear form -- continue from where it appeared in its super") (il:setq linear (cdr (il:|fetch| linear-thread il:|of| (il:|fetch| destination il:|of| linear))))) ((il:|type?| weak-link (car linear)) (il:* il:|;;| "it's a subnode -- examine its linear form") (il:setq linear (il:|fetch| linear-form il:|of| (il:fetch destination il:of (car linear))))) (t (return linear)))))) (output-bitmap (il:lambda (context bitmap) (il:* il:\; "Edited 17-Nov-87 11:39 by DCB") (il:* il:|;;;| "insert a bitmap at this point in the linear form") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:|;;| "we're editing. if this bitmap wasn't already there, insert it (this means we're no longer matching)") (when (not (next-linear context bitmap)) (set-linear context (cons bitmap (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (new-block context) (il:replace matching? il:of context il:with nil))) (step-linear context) (il:change (il:fetch line-ascent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:idifference (il:bitmapheight (cdr bitmap)) (car bitmap)))) (il:change (il:fetch line-descent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:iminus (car bitmap)))) (advance (il:bitmapwidth (cdr bitmap)))) (t (il:* il:|;;| "we're pretty printing. we haven't implemented bitmaps here. there's no real problem, but we do have to fix linear.item.width") (il:shouldnt "the pretty printer doesn't like bitmaps")))) ) (output-constant-string (il:lambda (context stringitem) (il:* il:\; "Edited 7-Jul-87 12:48 by DCB") (il:* il:|;;| "insert a fixed string in the linear form. fixed strings are previously generated stringitems (improves efficiency)") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:|;;| "we're editing. if this stringitem wasn't already there, insert it (this means we're no longer matching)") (cond ((next-linear context stringitem) (step-linear context)) (t (il:* il:|;;| "this is gratuitously complicated. it could be like output.bitmap (except that this is marginally faster)") (let ((linear (cons stringitem (il:fetch linear-pointer il:of context)))) (if (il:listp (il:fetch linear-prev il:of context)) (rplacd (il:fetch linear-prev il:of context) linear) (il:replace linear-form il:of (il:fetch linear-prev il:of context) il:with linear)) (il:replace linear-prev il:of context il:with linear) (when (il:fetch matching? il:of context) (new-block context) (il:replace block-start il:of (il:fetch current-block il:of context) il:with linear) (il:replace matching? il:of context il:with nil))))) (advance (il:fetch width il:of stringitem)) (il:change (il:fetch line-ascent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop (il:fetch font il:of stringitem) (quote il:ascent)))) (il:change (il:fetch line-descent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop (il:fetch font il:of stringitem) (quote il:descent))))) (t (il:* il:|;;| "we're pretty printing. we have to map the font because TEDIT.INSERT does weird things with interpress fonts") (il:tedit.insert (il:fetch display-window il:of context) (cond ((il:fetch prin-2? il:of stringitem) (il:* il:\; "read table specific") (il:mkstring (il:fetch string il:of stringitem) t)) (t (il:fetch string il:of stringitem))) nil (map-font (il:fetch font il:of stringitem) (il:fetch environment il:of context)) t) (il:add (il:fetch current-x il:of context) (il:fetch width il:of stringitem))))) ) (output-cr (il:lambda (context indent lineskip) (il:* il:\; "Edited 8-Jul-87 17:21 by DCB") (il:* il:|;;| "insert a line start in the linear form. this is rather tricky because we need to update the window as we go") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:|;;| "we're editing. compute various dimensions") (let ((last-line (car (il:fetch current-line il:of context))) (current-node (il:fetch current-node il:of context)) y this-line match-x match-baseline match-ascent match-descent) (when (null lineskip) (il:setq lineskip (il:fetch default-line-skip il:of (il:fetch environment il:of context)))) (il:setq y (il:idifference (il:fetch ycoord il:of last-line) (il:fetch line-height il:of last-line))) (il:replace actual-width il:of current-node il:with (il:imax (il:fetch actual-width il:of current-node) (il:fetch current-x il:of context))) (il:* il:|;;| "if there's already a line start at this point, we can smash it, but we have to cache its old values for use when fixing up the screen") (cond ((and (il:listp (il:fetch linear-pointer il:of context)) (il:type? line-start (il:setq this-line (car (il:fetch linear-pointer il:of context))))) (when (not (il:fetch below? il:of context)) (il:replace cached-ascent il:of this-line il:with (il:setq match-ascent (il:fetch line-ascent il:of this-line))) (il:replace cached-descent il:of this-line il:with (il:setq match-descent (il:fetch line-descent il:of this-line))) (il:replace cached-y il:of this-line il:with (il:setq match-baseline (il:fetch base-line-y il:of this-line))) (il:replace cache-time il:of this-line il:with (il:fetch relinearization-time-stamp il:of context)) (il:setq match-x (il:fetch indent il:of this-line))) (il:replace prev-line il:of this-line il:with (il:fetch current-line il:of context)) (il:replace line-skip il:of this-line il:with lineskip) (il:replace line-ascent il:of this-line il:with 0) (il:replace line-descent il:of this-line il:with 0) (il:replace indent il:of this-line il:with indent) (il:replace ycoord il:of this-line il:with y)) (t (il:* il:|;;| "there was no line start here before. create one") (set-linear context (cons (il:setq this-line (il:create line-start prev-line il:_ (il:fetch current-line il:of context) node il:_ (il:fetch current-node il:of context) line-skip il:_ lineskip line-ascent il:_ 0 line-descent il:_ 0 indent il:_ indent ycoord il:_ y)) (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (il:setq match-x (il:fetch current-block il:of context)) (il:setq match-ascent (il:fetch block-ascent il:of match-x)) (il:setq match-descent (il:fetch block-descent il:of match-x)) (il:setq match-baseline (il:fetch block-base-line il:of match-x)) (il:setq match-x (il:iplus (il:fetch current-x il:of context) (il:idifference (il:fetch block-x il:of match-x) (il:fetch block-new-x il:of match-x))))))) (il:replace line-length il:of last-line il:with (il:fetch current-x il:of context)) (il:selectq (il:fetch below? il:of context) (nil (il:* il:\; "this line might be visible. flush it and reset the block list") (line-finished context (il:fetch current-x il:of context) (il:fetch linear-pointer il:of context)) (il:replace shift-y il:of context il:with nil) (let ((block (il:fetch first-block il:of context))) (il:replace current-block il:of context il:with block) (il:replace block-new-x il:of block il:with indent) (il:replace block-start il:of block il:with (il:fetch linear-pointer il:of context)) (when (il:replace bits? il:of block il:with (il:fetch matching? il:of context)) (il:replace block-x il:of block il:with match-x) (il:replace block-base-line il:of block il:with match-baseline) (il:replace block-ascent il:of block il:with match-ascent) (il:replace block-descent il:of block il:with match-descent)))) (new (il:* il:\; "we're repainting this window from the top. nothing should be reused") (repaint-new-line (il:fetch current-line il:of context))) nil) (il:replace current-line il:of context il:with (il:fetch linear-pointer il:of context)) (il:replace next-line il:of last-line il:with (il:fetch current-line il:of context)) (il:replace current-x il:of context il:with indent) (step-linear context))) (t (il:* il:|;;| "we're pretty printing") (il:tedit.insert (il:fetch display-window il:of context) (il:fcharacter (il:charcode il:cr)) nil nil t) (il:tedit.paralooks (il:fetch display-window il:of context) (list (quote -1-stleftmargin) (il:fixr (il:quotient indent il:micasperpt)) (quote paraleading) (or lineskip (il:fetch default-line-skip il:of (il:fetch environment il:of context))))) (il:replace current-x il:of context il:with indent)))) ) (output-space (il:lambda (context x) (il:* il:\; "Edited 17-Nov-87 11:40 by DCB") (il:* il:|;;;| "insert horizontal space at this point in the linear form") (cond ((eq 0 x) (il:* il:\; "insert no space; that's easy!") nil) ((il:fetch relinearization-time-stamp il:of context) (il:* il:\; "we're editing") (cond ((and (il:listp (il:fetch linear-pointer il:of context)) (il:smallp (car (il:fetch linear-pointer il:of context)))) (when (and (il:fetch matching? il:of context) (il:neq (car (il:fetch linear-pointer il:of context)) x)) (new-block context) (il:replace matching? il:of context il:with nil)) (rplaca (il:fetch linear-pointer il:of context) x)) (t (set-linear context (cons x (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (new-block context) (il:replace matching? il:of context il:with nil)))) (step-linear context) (advance x)) (t (il:* il:|;;| "we're pretty printing") (il:for i il:from 1 il:to (il:iquotient x (il:fetch space-width il:of (il:fetch environment il:of context))) il:do (il:tedit.insert (il:fetch display-window il:of context) " " nil il:defaultfont t)) (il:add (il:fetch current-x il:of context) x)))) ) (output-string (il:lambda (context string prin-2? font) (il:* il:\; "Edited 7-Jul-87 12:49 by DCB") (il:* il:\; "insert a string at this point in the linear form") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:\; "we're editing") (let (this-item width) (when (null font) (il:* il:\; "font defaults to the DefaultFont of this environment") (il:setq font (il:fetch default-font il:of (il:fetch environment il:of context)))) (cond ((and (il:listp (il:fetch linear-pointer il:of context)) (il:type? string-item (il:setq this-item (car (il:fetch linear-pointer il:of context))))) (il:* il:\; "there was already a string at this point. is it the same one?") (cond ((or (il:neq (il:fetch string il:of this-item) string) (il:neq (il:fetch font il:of this-item) font) (il:neq (il:fetch prin-2? il:of this-item) prin-2?)) (il:* il:\; "it's different. reuse the structure, but recompute everything and smash all the fields") (il:* il:\; "read table specific") (il:setq width (stringwidth string font prin-2?)) (il:replace string il:of this-item il:with string) (il:replace width il:of this-item il:with width) (il:replace font il:of this-item il:with font) (il:replace prin-2? il:of this-item il:with prin-2?) (when (il:fetch matching? il:of context) (new-block context) (il:replace matching? il:of context il:with nil))) (t (il:* il:\; "it's the same. this is easy") (il:setq width (il:fetch width il:of this-item))))) (t (il:* il:\; "we need to create a new StringItem") (il:* il:\; "read table specific") (il:setq width (stringwidth string font prin-2?)) (set-linear context (cons (il:create string-item string il:_ string width il:_ width font il:_ font prin-2? il:_ prin-2?) (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (il:* il:\; "not anymore") (new-block context) (il:replace matching? il:of context il:with nil)))) (step-linear context) (il:change (il:fetch line-ascent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop font (quote il:ascent)))) (il:change (il:fetch line-descent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop font (quote il:descent)))) (advance width))) (t (il:* il:|;;| "we're pretty printing. we have to map the font because TEDIT.INSERT does weird things with interpress fonts") (il:tedit.insert (il:fetch display-window il:of context) (cond (prin-2? (il:* il:\; "read table specific") (il:setq string (il:mkstring string t))) (t string)) nil (map-font (or font (il:setq font (il:fetch default-font il:of (il:fetch environment il:of context)))) (il:fetch environment il:of context)) t) (il:add (il:fetch current-x il:of context (stringwidth string font)))))) ) (paint-to-end-of-line (il:lambda (context linear-end) (il:* il:\; "Edited 17-Nov-87 11:40 by DCB") (il:* il:|;;;| "update the window to the end of the current line") (let ((this-line (car (il:fetch current-line il:of context)))) (cond ((eq (il:fetch repaint-line il:of context) this-line) (il:* il:|;;| "we've already started displaying some of this line") (let ((blank-from (cond ((eq (il:fetch repaint-x il:of context) (il:fetch indent il:of this-line)) (il:* il:|;;| "painting from the start of the line, so blank from left edge of window") (il:fetch window-left il:of context)) (t (il:* il:|;;| "just blank the part we're repainting") (il:fetch repaint-x il:of context))))) (il:bltshade il:whiteshade (il:fetch display-window il:of context) blank-from (il:add1 (il:fetch next-line-y il:of this-line)) (il:add1 (il:idifference (il:fetch window-right il:of context) blank-from)) (il:fetch line-height il:of this-line))) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of this-line) (il:fetch repaint-start il:of context) linear-end)) (t (il:* il:|;;| "there are several lines which need to be repainted") (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch next-line-y il:of this-line)) (il:add1 (il:idifference (il:fetch window-right il:of context) (il:fetch window-left il:of context))) (il:idifference (il:fetch ycoord il:of (il:fetch repaint-line il:of context)) (il:fetch next-line-y il:of this-line))) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of (il:fetch repaint-line il:of context)) (cdr (il:fetch repaint-start il:of context)) linear-end))))) ) (recompute-format-values (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 12:49 by DCB") (let (changed?) (if (eq (il:fetch node-type il:of node) type-litatom) (il:setq changed? (il:fetch inline-width il:of node)) (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (recompute-format-values subnode context) (when (il:fetch changed? il:of subnode) (il:setq changed? t)))) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context) (when (and changed? (il:neq changed? (il:fetch inline-width il:of node))) (il:replace changed? il:of node il:with t)))) ) (relinearize (il:lambda (node context) (il:* il:\; "Edited 7-Apr-88 11:04 by woz") (il:* il:|;;;| "some part of this node has changed. do all the work necessary to update the linear form and window. this function is never supposed to be an entry point. that is, it assumes it will run under an sedit profile.") (let ((super-node (il:|fetch| super-node il:|of| node)) following-line from-top (old-actual-width (il:|fetch| actual-width il:|of| node)) (old-actualllength (il:|fetch| actual-llength il:|of| node)) (old-last-line (il:|fetch| last-line il:|of| node)) (display-window-region (il:dspclippingregion nil (il:|fetch| display-window il:|of| context))) y-1 y-2) (il:* il:\; "we cache the window dimensions because they're needed so often") (il:|replace| window-left il:|of| context il:|with| (il:|fetch| (il:region il:left) il:|of| display-window-region)) (il:|replace| window-bottom il:|of| context il:|with| (il:|fetch| (il:region il:bottom) il:|of| display-window-region)) (il:|replace| window-right il:|of| context il:|with| (il:|fetch| (il:region il:right) il:|of| display-window-region)) (il:|replace| window-top il:|of| context il:|with| (il:|fetch| (il:region il:top) il:|of| display-window-region)) (cond (super-node (il:* il:\; "the usual case: some node changed and we want to do a minimal update") (il:|replace| relinearization-time-stamp il:|of| context il:|with| (il:add1 (il:|fetch| relinearization-time-stamp il:|of| context))) (il:|replace| shift-y il:|of| context il:|with| nil) (il:|replace| shift-down il:|of| context il:|with| 0) (let ((first-line (il:|fetch| first-line il:|of| node)) first-line-linear) (il:setq first-line-linear (first-line-linear node context)) (cond ((il:|replace| below? il:|of| context il:|with| (il:ilessp (il:|fetch| ycoord il:|of| (il:|fetch| first-line il:|of| node)) (il:|fetch| window-bottom il:|of| context))) (il:|replace| matching? il:|of| context il:|with| nil)) (t (il:|replace| matching? il:|of| context il:|with| (il:neq (il:|fetch| start-x il:|of| node) 0)) (let ((block (il:|fetch| first-block il:|of| context))) (il:|replace| current-block il:|of| context il:|with| block) (il:|replace| visible? il:|of| context il:|with| (il:ilessp (il:|fetch| next-line-y il:|of| first-line) (il:|fetch| window-top il:|of| context))) (il:|replace| block-start il:|of| block il:|with| first-line-linear) (il:|replace| block-x il:|of| block il:|with| (il:|fetch| indent il:|of| first-line)) (il:|replace| block-new-x il:|of| block il:|with| (il:|fetch| indent il:|of| first-line)) (cond ((il:|fetch| matching? il:|of| context) (il:|replace| bits? il:|of| block il:|with| t) (il:|replace| block-width il:|of| block il:|with| (il:idifference (il:|fetch| current-x il:|of| context) (il:|fetch| block-x il:|of| block))) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| first-line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| first-line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| first-line))) (t (il:|replace| bits? il:|of| block il:|with| nil))) (il:|replace| repaint-x il:|of| context il:|with| (il:|fetch| indent il:|of| first-line)) (il:|replace| repaint-line il:|of| context il:|with| first-line) (il:|replace| repaint-start il:|of| context il:|with| first-line-linear)))) (il:|replace| cached-ascent il:|of| first-line il:|with| (il:|fetch| line-ascent il:|of| first-line)) (il:|replace| cached-descent il:|of| first-line il:|with| (il:|fetch| line-descent il:|of| first-line)) (il:|replace| cached-y il:|of| first-line il:|with| (il:|fetch| base-line-y il:|of| first-line)) (il:|replace| cache-time il:|of| first-line il:|with| (il:|fetch| relinearization-time-stamp il:|of| context)) (scan-for-bounds (cdr first-line-linear) (il:|fetch| linear-thread il:|of| node) first-line-linear t))) (t (il:* il:|;;| "we're redisplaying everything from scratch (probably because the window was reshaped). node is the root node ") (il:bltshade il:whiteshade (il:|fetch| display-window il:|of| context) (il:|fetch| (il:region il:left) il:|of| display-window-region) (il:|fetch| (il:region il:bottom) il:|of| display-window-region) (il:|fetch| (il:region il:width) il:|of| display-window-region) (il:|fetch| (il:region il:height) il:|of| display-window-region)) (il:|replace| shift-down il:|of| context il:|with| nil) (il:setq from-top t) (il:|replace| below? il:|of| context il:|with| (quote new)) (il:|replace| matching? il:|of| context il:|with| nil) (il:* il:|;;| "must set ascent and descent of first line because the linearizer never touches this line start") (il:|replace| line-ascent il:|of| (il:|fetch| first-line il:|of| node) il:|with| 0) (il:|replace| line-descent il:|of| (il:|fetch| first-line il:|of| node) il:|with| 0) (il:* il:|;;| "not sure if the format values will be taken care of elsewhere, so do it here just to be sure.") (compute-all-formats context))) (when (eq (il:|fetch| start-x il:|of| node) 0) (il:shouldnt "the linearize root method should take care of this") (il:|replace| start-x il:|of| node il:|with| (il:|fetch| start-x il:|of| super-node)) (il:|replace| first-line il:|of| node il:|with| (il:|fetch| first-line il:|of| super-node)) (il:|replace| right-margin il:|of| node il:|with| (il:|fetch| (il:region il:width) il:|of| display-window-region))) (il:|replace| current-x il:|of| context il:|with| (il:|fetch| start-x il:|of| node)) (il:|replace| current-node il:|of| context il:|with| super-node) (il:|replace| current-line il:|of| context il:|with| (first-line-linear node context)) (il:|replace| linear-pointer il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)) (il:|replace| linear-prev il:|of| context il:|with| nil) (generate-linear-form node context (if from-top (il:|fetch| (il:region il:width) il:|of| display-window-region) (il:|fetch| right-margin il:|of| node))) (il:* il:|;;| "if this isn't the top of the tree, and reformatting this node caused the width of its last line to change, the formatting of its supernode might change, so we'll have to relinearize it. and so on...") (il:|while| (and super-node (il:|fetch| super-node il:|of| super-node) (il:neq (il:|fetch| current-x il:|of| context) (il:iplus (il:|fetch| start-x il:|of| node) old-actualllength))) il:|do| (il:setq old-actualllength (il:|fetch| actual-llength il:|of| super-node)) (il:setq old-last-line (il:|fetch| last-line il:|of| super-node)) (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|fetch| linear-prev il:|of| context))) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| (il:|fetch| sub-node-index il:|of| node)) (il:* il:|;;| "compute the maximum width of the lines in the linear form of the super up to the end of the node we just linearized (so we can recompute the super's width)") (il:|replace| actual-width il:|of| super-node il:|with| (il:|bind| (width il:_ 0) il:|for| (line il:_ (il:|fetch| first-line il:|of| super-node)) il:|by| (car (il:|fetch| next-line il:|of| line)) il:|while| (il:neq line (car (il:|fetch| current-line il:|of| context))) il:|do| (when (il:igreaterp (il:|fetch| line-length il:|of| line) width) (il:setq width (il:|fetch| line-length il:|of| line))) il:|finally| (return width))) (il:|replace| actual-llength il:|of| super-node il:|with| nil) (funcall (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| super-node)) super-node context (il:|fetch| sub-node-index il:|of| node)) (when (not (and (il:|type?| weak-link (il:|fetch| linear-pointer il:|of| context)) (eq (il:fetch destination il:of (il:|fetch| linear-pointer il:|of| context)) super-node))) (set-linear context (cdr (last (il:fetch linear-form il:of super-node))))) (il:* il:|;;| "this used to be:") (il:* il:|;;| "(il:|replace| last-line-linear il:|of| super-node il:|with| (il:fetch current-line il:of context))") (il:|replace| last-line il:|of| super-node il:|with| (car (il:|fetch| current-line il:|of| context))) (il:|replace| actual-width il:|of| super-node il:|with| (il:idifference (il:imax (il:|fetch| actual-width il:|of| super-node) (il:|fetch| current-x il:|of| context)) (il:|fetch| start-x il:|of| super-node))) (il:|replace| actual-llength il:|of| super-node il:|with| (il:idifference (il:|fetch| current-x il:|of| context) (il:|fetch| start-x il:|of| super-node))) (il:|replace| changed? il:|of| super-node il:|with| nil) (il:setq node super-node) (il:setq super-node (il:|fetch| super-node il:|of| super-node)) (il:|replace| current-node il:|of| context il:|with| super-node)) (il:|replace| line-length il:|of| (il:|fetch| last-line il:|of| node) il:|with| (il:|fetch| current-x il:|of| context)) (cond ((or (null super-node) (null (il:|fetch| super-node il:|of| super-node))) (il:* il:|;;| "need to fix up node and supernode pointers, because came through root path") (when (null super-node) (il:setq super-node node) (il:setq node (subnode 1 node))) (il:* il:|;;| "we've relinearized to the end of the structure, so all we need to do is make sure the last line is flushed, blank the rest of the window, and fix up some recorded dimensions") (il:|replace| actual-llength il:|of| super-node il:|with| (il:|fetch| actual-llength il:|of| node)) (il:|replace| next-line il:|of| (il:|fetch| last-line il:|of| node) il:|with| nil) (il:selectq (il:|fetch| below? il:|of| context) (t) (nil (line-finished context (il:|fetch| current-x il:|of| context) nil t)) (new (repaint-new-line (last-line-linear node context))) (il:shouldnt "unexpected value for Below?")) (let* ((bottom-y (il:add1 (il:|fetch| next-line-y il:|of| (il:|fetch| last-line il:|of| node)))) (extent (il:windowprop (il:|fetch| display-window il:|of| context) (quote il:extent))) (old-bottom-y (il:idifference (il:|fetch| (il:region il:bottom) il:|of| extent) (or (il:|fetch| shift-down il:|of| context) 0)))) (when (and (il:neq (il:|fetch| below? il:|of| context) t) (il:igreaterp bottom-y old-bottom-y)) (il:bltshade il:whiteshade (il:|fetch| display-window il:|of| context) (il:|fetch| (il:region il:left) il:|of| display-window-region) old-bottom-y (il:|fetch| (il:region il:width) il:|of| display-window-region) (il:idifference bottom-y old-bottom-y))) (il:|replace| (il:region il:bottom) il:|of| extent il:|with| bottom-y) (il:|replace| (il:region il:height) il:|of| extent il:|with| (il:idifference 1 bottom-y)))) (t (il:* il:|;;| "we've finished relinearizing, but there was stuff after this. patch the pieces together and fix up all sorts of things") (il:|add| (il:|fetch| line-length il:|of| (il:|fetch| last-line il:|of| node)) (scan-for-bounds (cdr (il:|fetch| linear-thread il:|of| node)) nil (last-line-linear node context))) (il:setq following-line (car (il:|fetch| next-line il:|of| (il:|fetch| last-line il:|of| node)))) (when (not (il:|fetch| below? il:|of| context)) (new-block context) (let ((block (il:|fetch| current-block il:|of| context))) (il:|replace| block-start il:|of| block il:|with| (cdr (il:|fetch| linear-thread il:|of| node))) (il:|replace| block-new-x il:|of| block il:|with| (il:|fetch| current-x il:|of| context)) (il:|replace| block-x il:|of| block il:|with| (il:|fetch| current-x il:|of| context)) (il:|replace| bits? il:|of| block il:|with| t) (cond ((eq (il:|fetch| cache-time il:|of| old-last-line) (il:|fetch| relinearization-time-stamp il:|of| context)) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| cached-y il:|of| old-last-line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| cached-ascent il:|of| old-last-line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| cached-descent il:|of| old-last-line))) (t (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| old-last-line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| old-last-line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| old-last-line)))) (il:setq y-1 (il:idifference (il:|fetch| block-base-line il:|of| block) (il:iplus (il:|fetch| block-descent il:|of| block) 1))) (il:setq y-2 (il:|fetch| next-line-y il:|of| (car (il:|fetch| current-line il:|of| context))))) (line-finished context (il:|fetch| line-length il:|of| (il:|fetch| last-line il:|of| node)) (il:|fetch| next-line il:|of| (il:|fetch| last-line il:|of| node)) t) (il:setq y-1 (il:idifference y-1 (il:|fetch| shift-down il:|of| context)))) (clean-up-after-relinearization context node following-line y-1 y-2))) (il:* il:\; "changing this node may have changed the width of some of its super nodes") (propagate-width-change context node old-actual-width))) ) (repaint (il:lambda (context x y linear-start end) (il:* il:\; "Edited 11-Apr-88 15:52 by woz") (il:* il:|;;| "display the sequence of linear form from linear.start to end, starting at x,y. end is either an integer, indicating the lowest y to which repainting should be done, or a linear form pointer") (il:|bind| (dsp il:_ (il:|fetch| display-window il:|of| context)) item temp min-y current-font il:|first| (il:moveto x y dsp) (cond ((il:fixp end) (il:setq min-y end) (il:setq end nil)) (t (il:setq min-y (il:|fetch| window-bottom il:|of| context)))) il:|while| (il:neq linear-start end) il:|do| (cond ((not (il:listp linear-start)) (il:* il:\; "finished this node, follow its thread to super") (il:setq linear-start (cdr (il:|fetch| linear-thread il:|of| (il:|fetch| destination il:|of| linear-start))))) ((il:|type?| weak-link (il:setq item (car linear-start))) (il:* il:\; "insert the linear form of a subnode") (il:setq linear-start (il:|fetch| linear-form il:|of| (il:|fetch| destination il:|of| item)))) (t (il:* il:\; "display something") (cond ((il:|type?| line-start item) (il:* il:\; "new line. if it takes us off the bottom of the region to be repainted, we can quit") (when (il:ileq (il:iplus (il:setq y (il:|fetch| base-line-y il:|of| item)) (il:|fetch| line-ascent il:|of| item)) min-y) (il:* il:\; "we've repainted enough") (return)) (il:moveto (il:|fetch| indent il:|of| item) y dsp)) ((il:fixp item) (il:relmoveto item 0 dsp)) ((il:|type?| string-item item) (when (il:neq current-font (il:|fetch| font il:|of| item)) (when (null (il:|fetch| font il:|of| item)) (il:shouldnt "this StringItem has no font")) (il:dspfont (il:|fetch| font il:|of| item) dsp) (il:setq current-font (il:|fetch| font il:|of| item))) (cond ((il:stringp (il:setq temp (il:|fetch| string il:|of| item))) (il:* il:\; "read table specific") (print-string temp dsp (il:|fetch| prin-2? il:|of| item))) ((il:|fetch| prin-2? il:|of| item) (il:* il:\; "read table specific") (il:prin2 temp dsp)) (t (il:prin1 temp dsp)))) ((il:listp item) (il:bitblt (cdr item) nil nil dsp (il:dspxposition nil dsp) (il:idifference y (car item))) (il:relmoveto (il:bitmapwidth (cdr item)) 0 dsp)) (t (il:shouldnt "unknown linear form item"))) (il:setq linear-start (cdr linear-start)))))) ) (reuse-linear-form (il:lambda (node context) (il:* il:\; "Edited 8-Apr-88 12:06 by woz") (il:* il:|;;;| "we've been asked to generate the linear form of node, and have decided that the old one will do. make any necessary adjustments and make sure that it's displayed properly") (let ((current-x (il:|fetch| current-x il:|of| context)) (current-line (il:|fetch| current-line il:|of| context)) delta-x temp) (cond ((il:neq (il:|fetch| start-x il:|of| node) 0) (il:* il:\; "adjust the StartX values for this node and all its subnodes") (when (il:neq (il:setq delta-x (il:idifference (il:|fetch| current-x il:|of| context) (il:|fetch| start-x il:|of| node))) 0) (shift-linear-form node delta-x))) (t (il:* il:\; "this must be a prelinearized atom") (il:|replace| start-x il:|of| node il:|with| current-x))) (cond ((or (null (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node))) (il:|fetch| inline? il:|of| node)) (il:|replace| first-line il:|of| node il:|with| (car current-line)) (when (and (il:|fetch| matching? il:|of| context) (il:|fetch| changed? il:|of| node) (not (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)))) (new-block context) (il:|replace| matching? il:|of| context il:|with| nil)) (il:setq current-x (il:iplus current-x (scan-for-bounds (il:|fetch| linear-form il:|of| node) (cdr (last (il:|fetch| linear-form il:|of| node))) current-line nil)))) (t (il:* il:\; "the linear form spans several lines") (il:setq current-x (il:iplus current-x (scan-for-bounds (il:|fetch| linear-form il:|of| node) (cdr (last (il:|fetch| linear-form il:|of| node))) current-line nil))) (il:|replace| first-line il:|of| node il:|with| (car current-line)) (il:setq temp (il:|fetch| next-line il:|of| (car current-line))) (il:|replace| prev-line il:|of| (car temp) il:|with| current-line) (il:|replace| line-length il:|of| (car current-line) il:|with| current-x) (il:|add| (il:|fetch| indent il:|of| (car temp)) delta-x) (il:* il:|;;| "for each line in the linear form, adjust its y coordinate and indentation and the flush it (except the last)") (il:|bind| (block il:_ (il:|fetch| first-block il:|of| context)) (delta-y il:_ (il:idifference (il:|fetch| next-line-y il:|of| (car current-line)) (il:|fetch| ycoord il:|of| (car temp)))) (below? il:_ (il:|fetch| below? il:|of| context)) il:|first| (when (not below?) (line-finished context current-x temp) (il:setq below? (il:|fetch| below? il:|of| context)) (il:|replace| current-block il:|of| context il:|with| block)) il:|do| (cond (below? (when (eq below? (quote new)) (il:|replace| linear-pointer il:|of| context il:|with| temp) (repaint-new-line (il:|fetch| prev-line il:|of| (car temp)))) (il:setq temp (car temp))) (t (il:|replace| block-start il:|of| block il:|with| (cdr temp)) (il:|replace| current-line il:|of| context il:|with| temp) (il:|replace| shift-y il:|of| context il:|with| nil) (il:setq temp (car temp)) (il:|replace| block-x il:|of| block il:|with| (il:idifference (il:|fetch| indent il:|of| temp) delta-x)) (il:|replace| block-new-x il:|of| block il:|with| (il:|fetch| indent il:|of| temp)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| temp)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| temp)) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| temp)) (il:|replace| bits? il:|of| block il:|with| t))) (il:|replace| ycoord il:|of| temp il:|with| (il:iplus (il:|fetch| ycoord il:|of| temp) delta-y)) (when (eq temp (il:|fetch| last-line il:|of| node)) (when (not below?) (il:|replace| cached-y il:|of| temp il:|with| (il:idifference (il:|fetch| base-line-y il:|of| temp) delta-y)) (il:|replace| cached-ascent il:|of| temp il:|with| (il:|fetch| line-ascent il:|of| temp)) (il:|replace| cached-descent il:|of| temp il:|with| (il:|fetch| line-descent il:|of| temp)) (il:|replace| cache-time il:|of| temp il:|with| (il:|fetch| relinearization-time-stamp il:|of| context))) (return)) (il:|replace| line-length il:|of| temp il:|with| (il:setq current-x (il:iplus (il:|fetch| line-length il:|of| temp) delta-x))) (il:setq temp (il:|fetch| next-line il:|of| temp)) (il:|add| (il:|fetch| indent il:|of| (car temp)) delta-x) (when (not below?) (line-finished context current-x temp) (il:setq below? (il:|fetch| below? il:|of| context)))) (il:* il:\; "used to be replace CurrentLine of context with (SETQ current.line (fetch LastLineLinear of node))") (il:|replace| current-line il:|of| context il:|with| (il:setq current-line (last-line-linear node context))) (il:setq current-x (il:iplus (il:|fetch| indent il:|of| temp) (scan-for-bounds (cdr current-line) (cdr (last (il:|fetch| linear-form il:|of| node))) current-line t))))) (when (il:neq current-x (il:iplus (il:|fetch| start-x il:|of| node) (il:|fetch| actual-llength il:|of| node))) (il:shouldnt "old ActualLLength value doesn't match")) (il:|replace| current-x il:|of| context il:|with| current-x) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)))))) ) (shift-block (il:lambda (context x y width start end ascent descent new-x old-y) (il:* il:\; "Edited 17-Nov-87 11:45 by DCB") (il:* il:|;;;| "we've found a block of bits in the window which can be reused. bitblt them to the appropriate place") (let* ((current-line (car (il:fetch current-line il:of context))) (current-line-bottom (il:add1 (il:fetch next-line-y il:of current-line))) (delta (il:idifference (il:idifference y descent) current-line-bottom)) (repaint-start (il:fetch repaint-start il:of context)) h w) (when (and (il:igreaterp delta 0) (il:igreaterp (il:setq h (il:idifference current-line-bottom (il:fetch window-bottom il:of context))) 0)) (il:* il:|;;| "we're shifting stuff down, so move the bits below them out of the way (down) first") (il:bitblt (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:iplus (il:fetch window-bottom il:of context) delta) (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:fetch window-bottom il:of context) (il:add1 (il:idifference (il:fetch window-right il:of context) (il:fetch window-left il:of context))) h) (il:replace shift-down il:of context il:with (il:iplus (il:fetch shift-down il:of context) delta))) (when (or (il:neq y (il:fetch base-line-y il:of current-line)) (il:neq x new-x)) (il:* il:|;;| "the bits aren't already in the right place, so move them") (cond ((il:igreaterp (il:iplus y ascent) current-line-bottom) (il:* il:|;;| "we'll take along the rest of the line while we're at it (rather than lose those bits)") (cond ((eq old-y (il:fetch shift-y il:of context)) (il:replace shift-right il:of context il:with (il:iplus (il:fetch shift-right il:of context) (il:idifference new-x x)))) (t (il:replace shift-right il:of context il:with (il:idifference new-x x)) (il:replace shift-y il:of context il:with old-y))) (il:setq w (il:add1 (il:idifference (il:fetch window-right il:of context) new-x)))) (t (il:setq w width))) (il:setq descent (il:imin descent (il:fetch line-descent il:of current-line))) (il:setq ascent (il:imin ascent (il:fetch line-ascent il:of current-line))) (il:bitblt (il:fetch display-window il:of context) x (il:idifference y descent) (il:fetch display-window il:of context) new-x (il:idifference (il:fetch base-line-y il:of current-line) descent) w (il:iplus ascent descent))) (when (il:ileq (il:setq ascent (il:iplus (il:fetch base-line-y il:of current-line) ascent)) (il:fetch ycoord il:of current-line)) (il:* il:|;;| "it wasn't as tall as the line it's moved to, so blank above it") (il:bltshade il:whiteshade (il:fetch display-window il:of context) new-x ascent width (il:add1 (il:idifference (il:fetch ycoord il:of current-line) ascent)))) (when (il:ilessp descent (il:fetch line-descent il:of current-line)) (il:* il:|;;| "it descend as mush as the line it's moved to, so blank below it") (il:bltshade il:whiteshade (il:fetch display-window il:of context) new-x (il:add1 (il:fetch next-line-y il:of current-line)) width (il:idifference (il:fetch line-descent il:of current-line) descent))) (when (il:type? line-start (car repaint-start)) (il:setq repaint-start (cdr repaint-start))) (cond ((eq repaint-start start) (il:* il:|;;| "nothing to be painted, just blank where necessary") (when (and (or (il:neq y (il:fetch base-line-y il:of current-line)) (il:neq x new-x)) (eq new-x (il:fetch indent il:of current-line))) (il:* il:|;;| "this is the start of the line, so blank to the left margin") (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch next-line-y il:of current-line)) (il:idifference new-x (il:fetch window-left il:of context)) (il:fetch line-height il:of current-line)))) (t (il:* il:|;;| "there is extra material to paint in front of the bits we've moved") (cond ((il:neq (il:fetch repaint-line il:of context) current-line) (il:* il:|;;| "there are several lines of stuff to paint. blank the area it's going to first") (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch ycoord il:of current-line)) (il:add1 (il:idifference (il:fetch window-right il:of context) (il:fetch window-left il:of context))) (il:idifference (il:fetch ycoord il:of (il:fetch repaint-line il:of context)) (il:fetch ycoord il:of current-line))) (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch next-line-y il:of current-line)) (il:idifference new-x (il:fetch window-left il:of context)) (il:fetch line-height il:of current-line)) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of (il:fetch repaint-line il:of context)) repaint-start start)) (t (il:* il:|;;| "the stuff to be repainted is all on this line") (when (eq (il:setq x (il:fetch repaint-x il:of context)) (il:fetch indent il:of (il:fetch repaint-line il:of context))) (il:* il:|;;| "this is the beginning of the line, so blank to the left margin") (il:setq x (il:fetch window-left il:of context))) (il:bltshade il:whiteshade (il:fetch display-window il:of context) x (il:add1 (il:fetch next-line-y il:of current-line)) (il:idifference new-x x) (il:fetch line-height il:of current-line)) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of (il:fetch repaint-line il:of context)) repaint-start start))))) (il:replace repaint-start il:of context il:with end) (il:replace repaint-line il:of context il:with current-line) (il:replace repaint-x il:of context il:with (il:iplus new-x width)))) ) (try-reusing-bits (il:lambda (context block) (il:* il:\; "Edited 17-Nov-87 11:47 by DCB") (il:* il:|;;;| "decide whether the bits described by this block are actually available. if so, use shift.block to move them to the appropriate position. return T if we were successful") (prog ((shifted-x (il:fetch block-x il:of block)) (left-clip (il:fetch window-left il:of context)) (start (il:fetch block-start il:of block)) (end (il:fetch block-start il:of (il:fetch next-block il:of block))) (ascent (il:fetch block-ascent il:of block)) (descent (il:fetch block-descent il:of block)) (width (il:fetch block-width il:of block)) (new-x (il:fetch block-new-x il:of block)) shifted-y) (when (eq width 0) (il:* il:|;;| "no point in it if there are no bits") (go no-good)) (il:* il:|;;| "make sure they haven't been overwritten already, or shifted off the window") (cond ((il:fetch shift-y il:of context) (cond ((eq (il:fetch block-base-line il:of block) (il:fetch shift-y il:of context)) (il:setq shifted-y (il:fetch base-line-y il:of (car (il:fetch current-line il:of context)))) (il:setq shifted-x (il:iplus shifted-x (il:fetch shift-right il:of context))) (il:setq left-clip (il:fetch repaint-x il:of context))) (t (il:setq shifted-y (il:idifference (il:fetch block-base-line il:of block) (il:fetch shift-down il:of context))) (when (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch next-line-y il:of (car (il:fetch current-line il:of context)))) (go no-good))))) (t (il:setq shifted-y (il:idifference (il:fetch block-base-line il:of block) (il:fetch shift-down il:of context))) (when (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch ycoord il:of (il:fetch repaint-line il:of context))) (go no-good)) (when (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch next-line-y il:of (il:fetch repaint-line il:of context))) (il:setq left-clip (il:fetch repaint-x il:of context))))) (when (or (il:igreaterp shifted-x (il:fetch window-right il:of context)) (il:ileq (il:iplus shifted-y ascent) (il:fetch window-bottom il:of context))) (il:* il:\; "none of it's within the window") (go no-good)) (when (or (and (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch window-top il:of context)) (il:ilessp (il:fetch base-line-y il:of (car (il:fetch current-line il:of context))) shifted-y)) (and (il:ilessp (il:idifference shifted-y descent) (il:fetch window-bottom il:of context)) (il:igreaterp (il:fetch base-line-y il:of (car (il:fetch current-line il:of context))) shifted-y))) (il:* il:|;;| "some of it's within the window, but too much is clipped by the top or bottom edge of the window") (go no-good)) (when (il:igeq left-clip (il:iplus shifted-x width)) (go no-good)) (il:setq start (next-linear-item start)) (when (il:igreaterp (il:idifference left-clip shifted-x) (il:idifference (il:fetch window-right il:of context) new-x)) (il:* il:|;;| "this block was clipped on the left, so adjust its description (we'll have to repaint more)") (il:while (il:igreaterp left-clip shifted-x) il:bind w il:do (il:setq w (linear-item-width (car start))) (when (il:igeq w width) (il:* il:\; "there's nothing useable left") (go no-good)) (il:setq width (il:idifference width w)) (il:setq shifted-x (il:iplus shifted-x w)) (il:setq new-x (il:iplus new-x w)) (il:setq start (next-linear-item (cdr start))))) (when (and (il:igreaterp shifted-x new-x) (il:igreaterp (il:sub1 (il:iplus shifted-x width)) (il:fetch window-right il:of context))) (il:* il:|;;| "this block was clipped on the right, so adjust its description (we'll have to repaint more)") (il:setq end start) (il:setq width 0) (il:bind w il:until (il:igreaterp (il:sub1 (il:iplus shifted-x width (il:setq w (linear-item-width (car end))))) (il:fetch window-right il:of context)) il:do (il:setq width (il:iplus width w)) (il:setq end (next-linear-item (cdr end)))) (when (eq start end) (il:* il:|;;| "there's nothing useable left") (go no-good))) (il:* il:|;;| "there seem to be some useful bits here. put them in the right place") (shift-block context shifted-x shifted-y width start end ascent descent new-x (il:fetch block-base-line il:of block)) (return t) no-good)) ) ) (IL:PUTPROPS IL:SEDIT-LINEAR IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3402 73091 (CLEAN-UP-AFTER-RELINEARIZATION 3415 . 7248) (FIRST-LINE-LINEAR 7250 . 7855) (GENERATE-LINEAR-FORM 7857 . 12194) (LAST-LINE-LINEAR 12196 . 12844) (LINE-FINISHED 12846 . 15932) (LINEAR-ITEM-WIDTH 15934 . 16301) (LINEARIZE 16303 . 26852) (NEW-BLOCK 26854 . 27828) ( NEXT-LINEAR-ITEM 27830 . 29226) (OUTPUT-BITMAP 29228 . 30357) (OUTPUT-CONSTANT-STRING 30359 . 32394) ( OUTPUT-CR 32396 . 37036) (OUTPUT-SPACE 37038 . 38208) (OUTPUT-STRING 38210 . 40925) ( PAINT-TO-END-OF-LINE 40927 . 42622) (RECOMPUTE-FORMAT-VALUES 42624 . 43272) (RELINEARIZE 43274 . 55982 ) (REPAINT 55984 . 58248) (REUSE-LINEAR-FORM 58250 . 63366) (SHIFT-BLOCK 63368 . 68934) ( TRY-REUSING-BITS 68936 . 73089))))) IL:STOP