'From Squeak3.1alpha of 5 February 2001 [latest update: #4013] on 11 May 2001 at 9:07:47 am'! "Change Set: twoColumnGeeMail Date: 29 April 2001 Author: Bob Arning Add page views to GeeMail. The previous single, long style is now known as a galley view. The menu on the scrollbar now includes options for 1, 2, 3 or 4-column page views. When in page view, column breaks may be inserted in the text via the yellow button menu on the text itself." ! Object subclass: #CharacterScanner instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks ' classVariableNames: 'DefaultStopConditions ' poolDictionaries: 'TextConstants ' category: 'Graphics-Text'! Object subclass: #GeePrinter instanceVariableNames: 'pasteUp printSpecs computedBounds geeMail ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-GeeMail'! Object subclass: #NewParagraph instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Text Support'! Object subclass: #TextComposer instanceVariableNames: 'lines maxRightX currentY scanner possibleSlide nowSliding prevIndex prevLines currCharIndex startCharIndex stopCharIndex deltaCharIndex theText theContainer isFirstLine theTextStyle defaultLineHeight actualHeight wantsColumnBreaks ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Text Support'! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:50'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addGeeMailMenuItemsTo: aCustomMenu.! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:49'! addGeeMailMenuItemsTo: menu self flag: #convertToBook. "<-- no longer used" menu addUpdating: #showPageBreaksString action: #togglePageBreaks; addUpdating: #keepScrollbarString action: #toggleKeepScrollbar; addLine; add: 'Print...' action: #printPSToFile; addLine. thePasteUp allTextPlusMorphs size = 1 ifTrue: [ menu add: 'make 1-column book' selector: #makeBookStyle: argument: 1. menu add: 'make 2-column book' selector: #makeBookStyle: argument: 2. menu add: 'make 3-column book' selector: #makeBookStyle: argument: 3. menu add: 'make 4-column book' selector: #makeBookStyle: argument: 4. ] ifFalse: [ menu add: 'make a galley of me' action: #makeGalleyStyle. ]. ^menu! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:42'! allTextPlusMorphs ^thePasteUp allTextPlusMorphs! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 18:48'! drawOn: aCanvas super drawOn: aCanvas. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:50'! getMenu: shiftKeyState | menu | self flag: #convertToBook. "<-- no longer used" menu _ MenuMorph new defaultTarget: self. self addGeeMailMenuItemsTo: menu. ^menu! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:33'! handlesMouseDown: evt ^evt yellowButtonPressed ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:11'! initialize super initialize. color _ Color white. thePasteUp _ TextPlusPasteUpMorph new borderWidth: 0; color: color. scroller addMorph: thePasteUp. self position: 100@100. self extent: Display extent // 3. self useRoundedCorners. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 10:47'! makeBookStyle: nColumns | all totalWidth second columnWidth currY prev columnHeight currX currColumn pageBreakRectangles r rm columnGap pageGap | pageBreakRectangles _ OrderedCollection new. all _ thePasteUp allTextPlusMorphs. all size = 1 ifFalse: [^self]. Cursor wait show. prev _ all first. totalWidth _ self width - 16. columnGap _ 32. pageGap _ 16. columnWidth _ totalWidth - (columnGap * (nColumns - 1)) // nColumns. columnHeight _ self height - 12. currY _ 4. currX _ 4. currColumn _ 1. prev position: currX@currY; width: columnWidth. [ second _ prev makeSuccessorMorph. thePasteUp addMorphBack: second. prev height: columnHeight. (currColumn _ currColumn + 1) <= nColumns ifTrue: [ currX _ currX + columnWidth + columnGap. ] ifFalse: [ r _ 4@(prev bottom + 4) corner: (self right - 4 @ (prev bottom + pageGap - 4)). rm _ RectangleMorph new bounds: r; color: (Color gray alpha: 0.3); borderWidth: 0. pageBreakRectangles add: rm beSticky. thePasteUp addMorphBack: rm. currColumn _ 1. currX _ 4. currY _ prev bottom + pageGap. ]. second position: currX@currY; width: columnWidth. "second recomposeChain." prev _ second. prev height > columnHeight ] whileTrue. thePasteUp height: (prev bottom + 20 - self top). self layoutChanged. self setProperty: #pageBreakRectangles toValue: pageBreakRectangles. thePasteUp allTextPlusMorphs do: [ :each | each repositionAnchoredMorphs ]. Cursor normal show. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 15:51'! makeGalleyStyle | all first theRest | (self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]) do: [ :each | each delete ]. self removeProperty: #pageBreakRectangles. all _ thePasteUp allTextPlusMorphs. first _ all select: [ :x | x predecessor isNil]. first size = 1 ifFalse: [^self]. Cursor wait show. first _ first first. theRest _ all reject: [ :x | x predecessor isNil]. theRest do: [ :each | each delete]. first width: self width - 8. first recomposeChain. first repositionAnchoredMorphs. Cursor normal show. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:25'! pageRectanglesForPrinting | pageBreaks prevBottom pageRects r | pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [^nil]. prevBottom _ 0. pageRects _ pageBreaks collect: [ :each | r _ 0@prevBottom corner: self width @ each top. prevBottom _ each bottom. r ]. pageRects add: (0@prevBottom corner: self width @ thePasteUp bottom). ^pageRects! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:20'! printPSToFile thePasteUp printer geeMail: self; doPages! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 16:16'! scrollBarValue: scrollValue | newPt pageBreaks topOfPage | scroller hasSubmorphs ifFalse: [^ self]. newPt _ -3 @ (self leftoverScrollRange * scrollValue). pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. pageBreaks isEmpty ifTrue: [ ^scroller offset: newPt. ]. topOfPage _ pageBreaks inject: (0@0 corner: 0@0) into: [ :closest :each | (each bottom - newPt y) abs < (closest bottom - newPt y) abs ifTrue: [ each ] ifFalse: [ closest ]. ]. topOfPage ifNotNil: [ newPt _ newPt x @ topOfPage bottom. scrollBar value: newPt y / self leftoverScrollRange. ]. scroller offset: newPt.! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 09:21'! scrollSelectionIntoView: event alignTop: alignTop inTextMorph: tm "Scroll my text into view if necessary and return true, else return false" | selRects delta selRect rectToTest transform cpHere | selRects _ tm paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest _ selRects first merge: selRects last. transform _ scroller transformFrom: self. (event notNil and: [event isMouse and: [event anyButtonPressed]]) ifTrue: "Check for autoscroll" [cpHere _ transform localPointToGlobal: event cursorPoint. cpHere y <= self top ifTrue: [rectToTest _ selRects first topLeft extent: 2@2] ifFalse: [cpHere y >= self bottom ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect _ transform localBoundsToGlobal: rectToTest. selRect height > bounds height ifTrue: [^ false]. "Would not fit, even if we tried to scroll" alignTop ifTrue: [ self scrollBy: 0@(bounds top - selRect top). ^ true ]. selRect bottom > bounds bottom ifTrue: [ self scrollBy: 0@(bounds bottom - selRect bottom - 30). ^ true ]. (delta _ selRect amountToTranslateWithin: self bounds) y ~= 0 ifTrue: [ "Scroll end of selection into view if necessary" self scrollBy: 0@delta y. ^ true]. ^ false! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:06'! scrollToPage: pageNumber | rects oneRect | rects _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. oneRect _ rects at: pageNumber - 1 ifAbsent: [0@0 extent: 0@0]. self scrollToYAbsolute: oneRect bottom. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:01'! scrollToYAbsolute: yValue | transform transformedPoint | transform _ scroller transformFrom: self. transformedPoint _ transform localPointToGlobal: 0@yValue. self scrollBy: 0@(bounds top - transformedPoint y). ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'RAA 5/4/2001 13:53'! columnBreak ^true! ! !CharacterScanner methodsFor: 'initialize' stamp: 'RAA 5/7/2001 10:11'! wantsColumnBreaks: aBoolean wantsColumnBreaks _ aBoolean! ! !CharacterScanner methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 17:23'! setYFor: anchoredMorph ! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/4/2001 13:52'! columnBreak "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/7/2001 10:12'! setFont super setFont. stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #space. wantsColumnBreaks == true ifTrue: [ stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. ]. ! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'RAA 5/7/2001 10:30'! setYFor: anchoredMorph 1 = 1 ifTrue: [^self]. anchoredMorph top: (lineY - morphicOffset y). anchoredMorph left: (leftMargin - morphicOffset x + (anchoredMorph valueOfProperty: #geeMailLeftOffset ifAbsent: [0]) ). ! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:37'! allPages | pageNumber allPages maxPages | maxPages _ 9999. pageNumber _ 0. allPages _ self pageRectangles collect: [ :rect | pageNumber _ pageNumber + 1. (self as: GeePrinterPage) pageNumber: pageNumber bounds: rect ]. allPages size > maxPages ifTrue: [allPages _ allPages first: maxPages]. allPages do: [ :each | each totalPages: allPages size]. ^allPages ! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:49'! bounds ^computedBounds ifNil: [computedBounds _ self computeBounds]! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:49'! computeBounds | w ratio | w _ pasteUp width. self printSpecs scaleToFitPage ifTrue: [ ^0@0 extent: w@(w * self hOverW) rounded. ]. ratio _ 8.5 @ 11. self printSpecs landscapeFlag ifTrue: [ ratio _ ratio transposed ]. ^0@0 extent: (ratio * 72) rounded! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:54'! doPrintToPrinter "fileName _ ('gee.',Time millisecondClockValue printString,'.eps') asFileName." self pageRectangles. "ensure bounds computed" DSCPostscriptCanvasToDisk morphAsPostscript: self rotated: self printSpecs landscapeFlag specs: self printSpecs ! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:20'! geeMail: aGeeMail geeMail _ aGeeMail! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:32'! pageRectangles | pageBounds allPageRects maxExtent | geeMail ifNotNil: [ allPageRects _ geeMail pageRectanglesForPrinting. allPageRects ifNotNil: [ maxExtent _ allPageRects inject: 0@0 into: [ :max :each | max max: each extent ]. computedBounds _ 0@0 extent: maxExtent. ^allPageRects ]. ]. pageBounds _ self bounds. allPageRects _ OrderedCollection new. [pageBounds top <= pasteUp bottom] whileTrue: [ allPageRects add: pageBounds. pageBounds _ pageBounds translateBy: 0 @ pageBounds height. ]. ^allPageRects ! ! !NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:04'! wantsColumnBreaks ^wantsColumnBreaks! ! !NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'! wantsColumnBreaks: aBoolean wantsColumnBreaks _ aBoolean! ! !NewParagraph methodsFor: 'composition' stamp: 'RAA 5/6/2001 15:06'! OLDcomposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | charIndex lineY lineHeight scanner line row firstLine lineHeightGuess saveCharIndex hitCR maybeSlide sliding bottom priorIndex priorLine | charIndex _ start. lines _ lineColl. lineY _ startingY. lineHeightGuess _ textStyle lineGrid. maxRightX _ container left. maybeSlide _ stop < text size and: [container isMemberOf: Rectangle]. sliding _ false. priorIndex _ 1. bottom _ container bottom. scanner _ CompositionScanner new text: text textStyle: textStyle. firstLine _ true. [charIndex <= text size and: [(lineY + lineHeightGuess) <= bottom]] whileTrue: [sliding ifTrue: ["Having detected the end of rippling recoposition, we are only sliding old lines" priorIndex < priorLines size ifTrue: ["Adjust and re-use previously composed line" priorIndex _ priorIndex + 1. priorLine _ (priorLines at: priorIndex) slideIndexBy: delta andMoveTopTo: lineY. lineColl addLast: priorLine. lineY _ priorLine bottom. charIndex _ priorLine last + 1] ifFalse: ["There are no more priorLines to slide." sliding _ maybeSlide _ false]] ifFalse: [lineHeight _ lineHeightGuess. saveCharIndex _ charIndex. hitCR _ false. row _ container rectanglesAt: lineY height: lineHeight. 1 to: row size do: [:i | (charIndex <= text size and: [hitCR not]) ifTrue: [line _ scanner composeFrom: charIndex inRectangle: (row at: i) firstLine: firstLine leftSide: i=1 rightSide: i=row size. lines addLast: line. (text at: line last) = Character cr ifTrue: [hitCR _ true]. lineHeight _ lineHeight max: line lineHeight. "includes font changes" charIndex _ line last + 1]]. row size >= 1 ifTrue: [lineY _ lineY + lineHeight. lineY > bottom ifTrue: ["Oops -- the line is really too high to fit -- back out" charIndex _ saveCharIndex. row do: [:r | lines removeLast]] ifFalse: ["It's OK -- the line still fits." maxRightX _ maxRightX max: scanner rightX. 1 to: row size - 1 do: "Adjust heights across row if necess" [:i | (lines at: lines size - row size + i) lineHeight: lines last lineHeight baseline: lines last baseline]. charIndex > text size ifTrue: ["end of text" hitCR ifTrue: ["If text ends with CR, add a null line at the end" ((lineY + lineHeightGuess) <= container bottom) ifTrue: [row _ container rectanglesAt: lineY height: lineHeightGuess. row size > 0 ifTrue: [line _ (TextLine start: charIndex stop: charIndex-1 internalSpaces: 0 paddingWidth: 0) rectangle: row first; lineHeight: lineHeightGuess baseline: textStyle baseline. lines addLast: line]]]. lines _ lines asArray. ^ maxRightX]. firstLine _ false]] ifFalse: [lineY _ lineY + lineHeight]. (maybeSlide and: [charIndex > stop]) ifTrue: ["Check whether we are now in sync with previously composed lines" [priorIndex < priorLines size and: [(priorLines at: priorIndex) first < (charIndex - delta)]] whileTrue: [priorIndex _ priorIndex + 1]. (priorLines at: priorIndex) first = (charIndex - delta) ifTrue: ["Yes -- next line will have same start as prior line." priorIndex _ priorIndex - 1. maybeSlide _ false. sliding _ true] ifFalse: [priorIndex = priorLines size ifTrue: ["Weve reached the end of priorLines, so no use to keep looking for lines to slide." maybeSlide _ false]]]]]. firstLine ifTrue: ["No space in container or empty text" line _ (TextLine start: start stop: start-1 internalSpaces: 0 paddingWidth: 0) rectangle: (container topLeft extent: 0@lineHeightGuess); lineHeight: lineHeightGuess baseline: textStyle baseline. lines _ Array with: line ] ifFalse: [ self fixLastWithHeight: lineHeightGuess ]. "end of container" lines _ lines asArray. ^ maxRightX! ! !NewParagraph methodsFor: 'composition' stamp: 'RAA 5/7/2001 10:58'! composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | newResult | newResult _ TextComposer new composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY textStyle: textStyle text: text container: container wantsColumnBreaks: wantsColumnBreaks == true. lines _ newResult first asArray. maxRightX _ newResult second. ^maxRightX ! ! !NewParagraph methodsFor: 'composition' stamp: 'RAA 5/6/2001 15:09'! testNewComposeAll | newResult | self OLDcomposeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top. newResult _ TextComposer new composeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top textStyle: textStyle text: text container: container wantsColumnBreaks: false. newResult first with: lines do: [ :e1 :e2 | e1 longPrintString = e2 longPrintString ifFalse: [self halt]. ]. newResult second = maxRightX ifFalse: [self halt]. ^{newResult. {lines. maxRightX}} ! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 15:09'! fontsForComicBold | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica-Narrow-Bold' 0.8); at: 1 put: #('Helvetica-Narrow-Bold' 0.8); at: 2 put: #('Helvetica-Narrow-BoldOblique' 0.8); at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.8). ^d! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 15:11'! fontsForComicPlain | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" "how do we do underlined??" d _ Dictionary new. d at: 0 put: #('Helvetica-Narrow' 0.8); at: 1 put: #('Helvetica-Narrow-Bold' 0.8); at: 2 put: #('Helvetica-Narrow-Oblique' 0.8); at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.8). ^d ! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 14:54'! fontsForHelvetica | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica' 0.9); at: 1 put: #('Helvetica-Bold' 0.9); at: 2 put: #('Helvetica-Oblique' 0.9); at: 3 put: #('Helvetica-BoldOblique' 0.9); at: 8 put: #('Helvetica-Narrow' 0.9); at: 9 put: #('Helvetica-Narrow-Bold' 0.9); at: 10 put: #('Helvetica-Narrow-Oblique' 0.9); at: 11 put: #('Helvetica-Narrow-BoldOblique' 0.9). ^d! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 14:54'! fontsForNewYork | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica' 0.9); at: 1 put: #('Helvetica-Bold' 0.9); at: 2 put: #('Helvetica-Oblique' 0.9); at: 3 put: #('Helvetica-BoldOblique' 0.9); at: 8 put: #('Helvetica-Narrow' 0.9); at: 9 put: #('Helvetica-Narrow-Bold' 0.9); at: 10 put: #('Helvetica-Narrow-Oblique' 0.9); at: 11 put: #('Helvetica-Narrow-BoldOblique' 0.9). ^d! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 14:58'! fontsForPalatino | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Palatino-Roman' 0.9); at: 1 put: #('Palatino-Bold' 0.9); at: 2 put: #('Palatino-Italic' 0.9); at: 3 put: #('Palatino-BoldItalic' 0.9). ^d ! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 15:11'! initializeFontMap "Initialize the dictionary mapping message names to actions for C code generation." fontMap _ Dictionary new. fontMap at: 'NewYork' put: self fontsForNewYork; at: 'Helvetica' put: self fontsForHelvetica; at: 'Palatino' put: self fontsForPalatino; at: 'ComicBold' put: self fontsForComicBold; at: 'ComicPlain' put: self fontsForComicPlain; yourself.! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 5/7/2001 13:44'! writeSetupForRect:aRect | scaleForTranslate | scaleForTranslate _ EPSCanvas bobsPostScriptHacks ifTrue: [initialScale] ifFalse: [1]. "I thought the above was a good idea once, but GeeMail seems to like the line below better" scaleForTranslate _ 1. target print:'% psBounds origin'; cr. target translate: psBounds origin. target print:'% flip'; cr. target translate: 0 @ (aRect extent y * scaleForTranslate); scale: initialScale @ initialScale negated; print:' [ {true setstrokeadjust} stopped ] pop [ currenttransfer /exec cvx 1.2 /exp cvx ] cvx bind settransfer'; cr. ! ! !PostscriptCanvas methodsFor: 'drawing support' stamp: 'RAA 5/8/2001 12:52'! postscriptFontInfoForFont: font | fontName desired mask lengthToUse | fontName _ font familyName asString. lengthToUse _ fontName size. [lengthToUse > 0] whileTrue: [ fontMap at: (fontName first: lengthToUse) ifPresent: [ :subD | desired _ font emphasis. mask _ 31. [ desired _ desired bitAnd: mask. subD at: desired ifPresent: [ :answer | ^answer]. mask _ mask bitShift: -1. desired > 0 ] whileTrue. ]. lengthToUse _ lengthToUse - 1. ]. font emphasis == 1 ifTrue:[ fontName _ fontName,'-Bold'. ]. "Q add: {font. fontName}." ^ {fontName. 0.9} ! ! !PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'RAA 5/8/2001 10:01'! addEmphasis: emphasisCode emphasis _ emphasis bitOr: emphasisCode.! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 18:09'! addNullLineForIndex: index "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic." | oldLastLine r | oldLastLine _ lines last. oldLastLine last - oldLastLine first >= 0 ifFalse: [^self]. oldLastLine last = (index - 1) ifFalse: [^self]. r _ oldLastLine left @ oldLastLine bottom extent: 0@(oldLastLine bottom - oldLastLine top). "Even though we may be below the bottom of the container, it is still necessary to compose the last line for consistency..." self addNullLineWithIndex: index andRectangle: r. ! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/5/2001 11:05'! addNullLineWithIndex: index andRectangle: r lines addLast: ( ( TextLine start: index stop: index - 1 internalSpaces: 0 paddingWidth: 0 ) rectangle: r; lineHeight: defaultLineHeight baseline: theTextStyle baseline ) ! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 11:33'! checkIfReadyToSlide "Check whether we are now in sync with previously composed lines" (possibleSlide and: [currCharIndex > stopCharIndex]) ifFalse: [^self]. [prevIndex < prevLines size and: [(prevLines at: prevIndex) first < (currCharIndex - deltaCharIndex)]] whileTrue: [prevIndex _ prevIndex + 1]. (prevLines at: prevIndex) first = (currCharIndex - deltaCharIndex) ifTrue: [ "Yes -- next line will have same start as prior line." prevIndex _ prevIndex - 1. possibleSlide _ false. nowSliding _ true ] ifFalse: [ prevIndex = prevLines size ifTrue: [ "Weve reached the end of prevLines, so no use to keep looking for lines to slide." possibleSlide _ false ] ]! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 14:48'! composeAllLines [currCharIndex <= theText size and: [(currentY + defaultLineHeight) <= theContainer bottom]] whileTrue: [ nowSliding ifTrue: [ self slideOneLineDown ifNil: [^nil]. ] ifFalse: [ self composeOneLine ifNil: [^nil]. ] ]. ! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 09:23'! composeAllRectangles: rectangles | charIndexBeforeLine numberOfLinesBefore reasonForStopping | actualHeight _ defaultLineHeight. charIndexBeforeLine _ currCharIndex. numberOfLinesBefore _ lines size. reasonForStopping _ self composeEachRectangleIn: rectangles. currentY _ currentY + actualHeight. currentY > theContainer bottom ifTrue: [ "Oops -- the line is really too high to fit -- back out" currCharIndex _ charIndexBeforeLine. lines size - numberOfLinesBefore timesRepeat: [lines removeLast]. ^self ]. "It's OK -- the line still fits." maxRightX _ maxRightX max: scanner rightX. 1 to: rectangles size - 1 do: [ :i | "Adjust heights across rectangles if necessary" (lines at: lines size - rectangles size + i) lineHeight: lines last lineHeight baseline: lines last baseline ]. isFirstLine _ false. reasonForStopping == #columnBreak ifTrue: [^nil]. currCharIndex > theText size ifTrue: [ ^nil "we are finished composing" ]. ! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 15:14'! composeEachRectangleIn: rectangles | myLine lastChar | 1 to: rectangles size do: [:i | currCharIndex <= theText size ifFalse: [^false]. myLine _ scanner composeFrom: currCharIndex inRectangle: (rectangles at: i) firstLine: isFirstLine leftSide: i=1 rightSide: i=rectangles size. lines addLast: myLine. actualHeight _ actualHeight max: myLine lineHeight. "includes font changes" currCharIndex _ myLine last + 1. lastChar _ theText at: myLine last. lastChar = Character cr ifTrue: [^#cr]. wantsColumnBreaks ifTrue: [ lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. ]. ]. ^false! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 10:11'! composeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks wantsColumnBreaks _ argWantsColumnBreaks. lines _ argLinesCollection. theTextStyle _ argTextStyle. theText _ argText. theContainer _ argContainer. deltaCharIndex _ argDelta. currCharIndex _ startCharIndex _ argStart. stopCharIndex _ argStop. prevLines _ argPriorLines. currentY _ argStartY. defaultLineHeight _ theTextStyle lineGrid. maxRightX _ theContainer left. possibleSlide _ stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle]. nowSliding _ false. prevIndex _ 1. scanner _ CompositionScanner new text: theText textStyle: theTextStyle. scanner wantsColumnBreaks: wantsColumnBreaks. isFirstLine _ true. self composeAllLines. isFirstLine ifTrue: ["No space in container or empty text" self addNullLineWithIndex: startCharIndex andRectangle: (theContainer topLeft extent: 0@defaultLineHeight) ] ifFalse: [ self fixupLastLineIfCR ]. ^{lines asArray. maxRightX} ! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 12:59'! composeOneLine | rectangles | rectangles _ theContainer rectanglesAt: currentY height: defaultLineHeight. rectangles size >= 1 ifTrue: [ (self composeAllRectangles: rectangles) ifNil: [^nil]. ] ifFalse: [ currentY _ currentY + defaultLineHeight ]. self checkIfReadyToSlide.! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 18:09'! fixupLastLineIfCR "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic." (theText size > 1 and: [theText last = Character cr]) ifFalse: [^self]. self addNullLineForIndex: theText size + 1. ! ! !TextComposer methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 15:15'! slideOneLineDown | priorLine | "Having detected the end of rippling recoposition, we are only sliding old lines" prevIndex < prevLines size ifFalse: [ "There are no more prevLines to slide." ^nowSliding _ possibleSlide _ false ]. "Adjust and re-use previously composed line" prevIndex _ prevIndex + 1. priorLine _ (prevLines at: prevIndex) slideIndexBy: deltaCharIndex andMoveTopTo: currentY. lines addLast: priorLine. currentY _ priorLine bottom. currCharIndex _ priorLine last + 1. wantsColumnBreaks ifTrue: [ priorLine first to: priorLine last do: [ :i | (theText at: i) = TextComposer characterForColumnBreak ifTrue: [ nowSliding _ possibleSlide _ false. ^nil ]. ]. ]. ! ! !TextComposer class methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 09:31'! characterForColumnBreak ^Character value: 12! ! !TextMorph methodsFor: 'private' stamp: 'RAA 5/6/2001 15:11'! paragraph "Paragraph instantiation is lazy -- create it only when needed" paragraph ifNotNil: [^ paragraph]. self setDefaultContentsIfNil. "...Code here to recreate the paragraph..." paragraph _ (self paragraphClass new textOwner: self owner). paragraph wantsColumnBreaks: successor notNil. paragraph compose: text style: textStyle copy from: self startingIndex in: self container. wrapFlag ifFalse: ["Was given huge container at first... now adjust" paragraph adjustRightX]. self fit. ^ paragraph! ! !TextMorph methodsFor: 'private' stamp: 'RAA 5/6/2001 15:12'! setSuccessor: newSuccessor successor _ newSuccessor. paragraph ifNotNil: [paragraph wantsColumnBreaks: successor notNil]. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:42'! addAlansAnchorFor: aMorph | ed attribute selRects | self removeAlansAnchorFor: aMorph. ed _ self editor. attribute _ TextAnchorPlus new anchoredMorph: aMorph. aMorph setProperty: #geeMailLeftOffset toValue: aMorph left - self left. ed replaceSelectionWith: (ed selection addAttribute: attribute). selRects _ self paragraph selectionRects. selRects isEmpty ifFalse: [ aMorph top: selRects first top ]. self releaseParagraphReally. self layoutChanged. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/6/2001 15:15'! addColumnBreak | ed old new break | ed _ self editor. old _ ed selection. break _ TextComposer characterForColumnBreak asString. break _ Text string: break attributes: {}. new _ old ,break. ed replaceSelectionWith: new. self releaseParagraphReally. self layoutChanged. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:05'! addSuccessor: evt evt hand attachMorph: self makeSuccessorMorph! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:13'! doJumpTo: aString | myStart myStop | myStart _ myStop _ nil. text runs withStartStopAndValueDo: [:start :stop :attributes | attributes do: [:att | ((att isMemberOf: TextPlusJumpEnd) and: [att jumpLabel = aString]) ifTrue: [ myStart ifNil: [myStart _ start. myStop _ stop] ifNotNil: [myStart _ myStart min: start. myStop _ myStop max: stop]. ] ] ]. myStart ifNil: [^self]. self editor selectFrom: myStart to: myStop. ignoreNextUp _ true. self changed. self scrollSelectionToTop. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 09:18'! doYellowButtonPress: evt | menu | menu _ CustomMenu new. menu add: 'Go to top of document' action: [self jumpToDocumentTop]; add: 'Move selection to top of page' action: [self scrollSelectionToTop]; add: 'Add column break' action: [self addColumnBreak]; add: 'Define as jump start' action: [self addJumpBeginning]; add: 'Define as jump end' action: [self addJumpEnd]. ((menu build startUpCenteredWithCaption: 'Text navigation options') ifNil: [^self]) value. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 10:17'! fixAllLeftOffsets | am | text runs withStartStopAndValueDo: [:start :stop :attributes | attributes do: [:att | (att isMemberOf: TextAnchorPlus) ifTrue: [ am _ att anchoredMorph. (am isNil or: [am world isNil]) ifFalse: [ am valueOfProperty: #geeMailLeftOffset ifAbsent: [ am setProperty: #geeMailLeftOffset toValue: am left - self left ] ] ] ] ]. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:35'! handleInteraction: interactionBlock fromEvent: evt super handleInteraction: interactionBlock fromEvent: evt. (self parentGeeMail ifNil: [^self]) scrollSelectionIntoView: evt alignTop: false inTextMorph: self. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:13'! jumpToDocumentTop self editor selectFrom: 1 to: 0. self changed. self scrollSelectionToTop. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:47'! keyboardFocusChange: aBoolean | parent | "we basically ignore loss of focus unless it is going to one of our siblings" aBoolean ifFalse: [^self]. "A hand is wanting to send us characters..." self hasFocus ifFalse: [self editor "Forces install"]. "Inform our siblings we have taken the focus" parent _ self parentGeeMail ifNil: [^self]. parent allTextPlusMorphs do: [ :each | each == self ifFalse: [each keyboardFocusLostForSure] ]. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:46'! keyboardFocusLostForSure editor ifNotNil: [ self selectionChanged. self paragraph selectionStart: nil selectionStop: nil. editor _ nil ]. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 14:05'! makeSuccessorMorph | newMorph | self fixAllLeftOffsets. newMorph _ self class new text: text textStyle: textStyle wrap: wrapFlag color: color predecessor: self successor: successor. newMorph extent: self width @ 100. successor ifNotNil: [successor setPredecessor: newMorph]. self setSuccessor: newMorph. successor recomposeChain. ^newMorph! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:35'! parentGeeMail ^self ownerThatIsA: AlansTextPlusMorph ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 10:25'! predecessorChanged super predecessorChanged. self repositionAnchoredMorphs. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 10:48'! repositionAnchoredMorphs | am cBlock leftShift firstCharacterIndex lastCharacterIndex | firstCharacterIndex _ paragraph firstCharacterIndex. lastCharacterIndex _ paragraph lastCharacterIndex. text runs withStartStopAndValueDo: [:start :stop :attributes | attributes do: [:att | (att isMemberOf: TextAnchorPlus) ifTrue: [ am _ att anchoredMorph. (am isNil or: [am world isNil]) ifFalse: [ (stop between: firstCharacterIndex and: lastCharacterIndex) ifTrue: [ cBlock _ self paragraph characterBlockForIndex: stop. leftShift _ am valueOfProperty: #geeMailLeftOffset ifAbsent: [0]. am position: cBlock origin + (leftShift @ 0). ]. ] ] ] ]. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:35'! scrollSelectionToTop (self parentGeeMail ifNil: [^self]) scrollSelectionIntoView: nil alignTop: true inTextMorph: self. ! ! !TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/5/2001 15:48'! updateFromParagraph super updateFromParagraph. self repositionAnchoredMorphs. ! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 10:13'! acceptDroppingMorph: aMorph event: evt | allTextPlus | (aMorph isKindOf: NewHandleMorph) ifTrue: [^self]. (aMorph isKindOf: GeeBookMorph) ifTrue: [^self]. "avoid looping" (aMorph isKindOf: TextPlusMorph) ifTrue: [ ^self addMorphBack: aMorph. ]. self addMorph: aMorph. allTextPlus _ self allTextPlusMorphs. aMorph allMorphsDo: [ :each | allTextPlus do: [ :e2 | e2 removeAlansAnchorFor: each]. ]. (self nearestTextPlusMorphTo: aMorph) linkNewlyDroppedMorph: aMorph! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/2/2001 16:59'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addUpdating: #showPageBreaksString action: #togglePageBreaks. ! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/29/2001 18:06'! allTextPlusMorphs ^submorphs select: [ :each | each isKindOf: TextPlusMorph] ! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:22'! initialize super initialize. showPageBreaks _ true. self addMorphBack: (TextPlusMorph new position: 4@4). ! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:31'! nearestTextPlusMorphTo: aMorph ^self allTextPlusMorphs inject: nil into: [ :best :each | self select: best or: each asClosestTo: aMorph ]! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:30'! select: bestPrevious or: current asClosestTo: aMorph bestPrevious ifNil: [^current]. (bestPrevious bounds intersects: aMorph bounds) ifTrue: [^bestPrevious]. (current bounds intersects: aMorph bounds) ifTrue: [^current]. bestPrevious left < current left ifTrue: [ ^aMorph left < current left ifTrue: [bestPrevious] ifFalse: [current] ]. ^aMorph left < bestPrevious left ifTrue: [current] ifFalse: [bestPrevious] ! ! !TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/30/2001 09:31'! textPlusMenuFor: aMorph ^(self nearestTextPlusMorphTo: aMorph) textPlusMenuFor: aMorph ! ! TextPlusPasteUpMorph removeSelector: #theTextMorph:! TextPlusMorph removeSelector: #scrollerOwner:! TextComposer removeSelector: #addNullLineToEnd! TextComposer removeSelector: #composeLinesFrom:to:delta:into:priorLines:atY:textStyle:text:container:! TextComposer removeSelector: #fixupLastLine! Object subclass: #GeePrinter instanceVariableNames: 'pasteUp printSpecs geeMail computedBounds ' classVariableNames: '' poolDictionaries: '' category: 'Morphic-GeeMail'! DisplayScanner removeSelector: #columnBreak! AlansTextPlusMorph removeSelector: #scrollSelectionIntoView:alignTop:! "Postscript: " !