Squeak-dev July 2013

squeak-dev@lists.squeakfoundation.org

50 participants
342 discussions

Re: [squeak-dev] The Trunk: SystemChangeNotification-Tests-fbs.20.mcz
by Nicolas Cellier 24 Jul '13

24 Jul '13

includesKey: ? 2013/7/23 <commits(a)source.squeak.org> > Frank Shearar uploaded a new version of SystemChangeNotification-Tests to > project The Trunk: > http://source.squeak.org/trunk/SystemChangeNotification-Tests-fbs.20.mcz > > ==================== Summary ==================== > > Name: SystemChangeNotification-Tests-fbs.20 > Author: fbs > Time: 23 July 2013, 9:16:27.988 pm > UUID: 2e5843bc-9a94-7b48-a658-8fc3a944d576 > Ancestors: SystemChangeNotification-Tests-ul.19 > > "Smalltalk keys" is deprecated; use "Smalltalk globals keys" instead. > > =============== Diff against SystemChangeNotification-Tests-ul.19 > =============== > > Item was changed: > ----- Method: SystemChangeFileTest>>testClassAdded (in category > 'testing') ----- > testClassAdded > | aClassName | > aClassName := self genericClassName. > self > change: [ > self createClass: aClassName. > ] > verify: [ > + self assert: (Smalltalk globals keys includes: > aClassName). > - self assert: (Smalltalk keys includes: aClassName). > ] > > ! > > Item was changed: > ----- Method: SystemChangeFileTest>>testClassRemoved (in category > 'testing') ----- > testClassRemoved > | aClass aClassName | > aClassName := self genericClassName. > self > prepare: [ > aClass := self createClass: aClassName. > ] > change: [ > aClass removeFromSystem. > ] > verify: [ > + self deny: (Smalltalk globals keys includes: > aClassName). > - self deny: (Smalltalk keys includes: aClassName). > ]. > ! > > Item was changed: > ----- Method: SystemChangeFileTest>>testClassRenamed (in category > 'testing') ----- > testClassRenamed > | aClass aNewClassName anOldClassName | > anOldClassName := self genericClassName. > aNewClassName := self genericClassName. > self > prepare: [ > aClass := self createClass: anOldClassName. > ] > change: [ > aClass rename: aNewClassName. > ] > verify: [ > + self assert: (Smalltalk globals keys includes: > aNewClassName). > + self deny: (Smalltalk globals keys includes: > anOldClassName). > - self assert: (Smalltalk keys includes: > aNewClassName). > - self deny: (Smalltalk keys includes: > anOldClassName). > ].! > > Item was changed: > ----- Method: SystemChangeFileTest>>testExpressionDoIt (in category > 'testing') ----- > testExpressionDoIt > | aClassName | > aClassName := self genericClassName.. > self > prepare: [ > self createClass: aClassName. > ] > change: [ > Compiler evaluate: '(Smalltalk at: ', aClassName > storeString, ') removeFromSystem'. > ] > verify: [ > + self deny: (Smalltalk globals keys includes: > aClassName). > - self deny: (Smalltalk keys includes: aClassName). > ].! > > >

2 2

The Trunk: SystemChangeNotification-Tests-fbs.21.mcz
by commits＠source.squeak.org 24 Jul '13

24 Jul '13

Frank Shearar uploaded a new version of SystemChangeNotification-Tests to project The Trunk: http://source.squeak.org/trunk/SystemChangeNotification-Tests-fbs.21.mcz ==================== Summary ==================== Name: SystemChangeNotification-Tests-fbs.21 Author: fbs Time: 24 July 2013, 7:07:57.846 am UUID: 6474bbc8-9898-664a-956d-d44d80c3ba64 Ancestors: SystemChangeNotification-Tests-fbs.20 Take Nicolas Cellier's suggestion to heart and use #includesKey:. =============== Diff against SystemChangeNotification-Tests-fbs.20 =============== Item was changed: ----- Method: SystemChangeFileTest>>testClassAdded (in category 'testing') ----- testClassAdded | aClassName | aClassName := self genericClassName. self change: [ self createClass: aClassName. ] verify: [ + self assert: (Smalltalk globals includesKey: aClassName). - self assert: (Smalltalk globals keys includes: aClassName). ] ! Item was changed: ----- Method: SystemChangeFileTest>>testClassRemoved (in category 'testing') ----- testClassRemoved | aClass aClassName | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aClass removeFromSystem. ] verify: [ + self deny: (Smalltalk globals includesKey: aClassName). - self deny: (Smalltalk globals keys includes: aClassName). ]. ! Item was changed: ----- Method: SystemChangeFileTest>>testClassRenamed (in category 'testing') ----- testClassRenamed | aClass aNewClassName anOldClassName | anOldClassName := self genericClassName. aNewClassName := self genericClassName. self prepare: [ aClass := self createClass: anOldClassName. ] change: [ aClass rename: aNewClassName. ] verify: [ + self assert: (Smalltalk globals includesKey: aNewClassName). + self deny: (Smalltalk globals includesKey: anOldClassName). - self assert: (Smalltalk globals keys includes: aNewClassName). - self deny: (Smalltalk globals keys includes: anOldClassName). ].! Item was changed: ----- Method: SystemChangeFileTest>>testExpressionDoIt (in category 'testing') ----- testExpressionDoIt | aClassName | aClassName := self genericClassName.. self prepare: [ self createClass: aClassName. ] change: [ Compiler evaluate: '(Smalltalk at: ', aClassName storeString, ') removeFromSystem'. ] verify: [ + self deny: (Smalltalk globals includesKey: aClassName). - self deny: (Smalltalk globals keys includes: aClassName). ].! Item was changed: ----- Method: SystemChangeFileTest>>testMethodAdded (in category 'testing') ----- testMethodAdded | aClassName aClass aSelector | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aSelector := self genericSelector. aClass compile: aSelector. ] verify: [ + self assert: (aClass methodDict includesKey: aSelector). - self assert: (aClass methodDict keys includes: aSelector). ] ! Item was changed: ----- Method: SystemChangeFileTest>>testMethodRemoved (in category 'testing') ----- testMethodRemoved | aClassName aClass aSelector | aClassName := self genericClassName. aSelector := self genericSelector. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector. ] change: [ aClass removeSelector: aSelector. ] verify: [ + self deny: (aClass methodDict includesKey: aSelector). - self deny: (aClass methodDict keys includes: aSelector). ] !

1 0

Daily Commit Log
by commits＠source.squeak.org 24 Jul '13

24 Jul '13

Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2013-July/006231.html Name: System-fbs.574 Ancestors: System-fbs.573 Missed a SmalltalkImage self-reference. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006232.html Name: System-fbs.575 Ancestors: System-fbs.574 Move Exceptions close to where they're used, rather than collecting them together just because they're Exceptions. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006233.html Name: Exceptions-fbs.48 Ancestors: Exceptions-fbs.47 Move Exceptions close to where they're used, rather than collecting them together just because they're Exceptions. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006234.html Name: Collections-fbs.524 Ancestors: Collections-fbs.523 Move Exceptions close to where they're used, rather than collecting them together just because they're Exceptions. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006235.html Name: MorphicExtras-fbs.117 Ancestors: MorphicExtras-fbs.116 Move Exceptions close to where they're used, rather than collecting them together just because they're Exceptions. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006236.html Name: Tests-fbs.242 Ancestors: Tests-fbs.241 Nothing depends on Exceptions anymore. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006237.html Name: TrueType-fbs.24 Ancestors: TrueType-fbs.23 Make TrueType sit above (and extend) Graphics, thus breaking the cyclic dependency. The decoupling is pretty rough. By all means make the division between these two packages cleaner! ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006238.html Name: Graphics-fbs.219 Ancestors: Graphics-fbs.218 Make TrueType sit above (and extend) Graphics, thus breaking the cyclic dependency. The decoupling is pretty rough. By all means make the division between these two packages cleaner! ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006239.html Name: System-fbs.576 Ancestors: System-fbs.575 Make TrueType sit above (and extend) Graphics, thus breaking the cyclic dependency. The decoupling is pretty rough. By all means make the division between these two packages cleaner! Methods like #fromUser don't (in my opinion) belong in low level packages, hence their migration to System. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006240.html Name: Graphics-fbs.220 Ancestors: Graphics-fbs.219 Break Graphics -> Morphic dependency. Push some UI-independent code down from Morphic into Graphics, and move extension-y things up into Morphic. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006241.html Name: Morphic-fbs.674 Ancestors: Morphic-dtl.673 Break Graphics -> Morphic dependency. Push some UI-independent code down from Morphic into Graphics, and move extension-y things up into Morphic. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006242.html Name: Tests-fbs.243 Ancestors: Tests-fbs.242 Graphics -/-> TrueType, Graphics -/-> Morphic. TrueType -> Multilingual because of HostFont class >> #initForSubtitles. Don't really like that. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2013-July/006243.html Name: SystemChangeNotification-Tests-fbs.20 Ancestors: SystemChangeNotification-Tests-ul.19 "Smalltalk keys" is deprecated; use "Smalltalk globals keys" instead. =============================================

1 0

Getting morph events when there is no keyboard focus
by tim Rowledge 24 Jul '13

24 Jul '13

I'm trying to get an idea of how to handle keyboard events when there is no keyboard focus; this is for dealing with general application commands like 'start', 'stop', 'explode', etc. I *think* it looks like I might need a listener object added to the handmorph but I don't see how to check if the focus is nil as part of that path. An alternative appears to be something to do with the owner of the hand… maybe? I've spent too long wandering a twisty maze of messages and as a result, got eaten by a Grue. Explanations of how this all works would be appreciated, whether actual or pointers to already written doc. For example, why do all the implementors of #handleFocusEvent: except Morph use both #processEvent: and handleEvent: when it looks like #processEvent also sends #handleEvent: ? I hope there are intelligible explanations out there... tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Strange OpCodes: ETO: Emulate Toaster Oven

2 3

EventSensor keyboardBuffer is truly dead?
by tim Rowledge 24 Jul '13

24 Jul '13

So far as I can tell the EventSensor ivar 'keyboardBuffer' has been unused for 12 years, at least. Has anyone seen any usage of it any time this millennium? I'd lie to steal it for maintaining a map of currently pressed keys, whihc has the advantage of even reasonably matching the name. tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Strange OpCodes: PO: Punch Operator

1 0

The Trunk: SystemChangeNotification-Tests-fbs.20.mcz
by commits＠source.squeak.org 23 Jul '13

23 Jul '13

Frank Shearar uploaded a new version of SystemChangeNotification-Tests to project The Trunk: http://source.squeak.org/trunk/SystemChangeNotification-Tests-fbs.20.mcz ==================== Summary ==================== Name: SystemChangeNotification-Tests-fbs.20 Author: fbs Time: 23 July 2013, 9:16:27.988 pm UUID: 2e5843bc-9a94-7b48-a658-8fc3a944d576 Ancestors: SystemChangeNotification-Tests-ul.19 "Smalltalk keys" is deprecated; use "Smalltalk globals keys" instead. =============== Diff against SystemChangeNotification-Tests-ul.19 =============== Item was changed: ----- Method: SystemChangeFileTest>>testClassAdded (in category 'testing') ----- testClassAdded | aClassName | aClassName := self genericClassName. self change: [ self createClass: aClassName. ] verify: [ + self assert: (Smalltalk globals keys includes: aClassName). - self assert: (Smalltalk keys includes: aClassName). ] ! Item was changed: ----- Method: SystemChangeFileTest>>testClassRemoved (in category 'testing') ----- testClassRemoved | aClass aClassName | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aClass removeFromSystem. ] verify: [ + self deny: (Smalltalk globals keys includes: aClassName). - self deny: (Smalltalk keys includes: aClassName). ]. ! Item was changed: ----- Method: SystemChangeFileTest>>testClassRenamed (in category 'testing') ----- testClassRenamed | aClass aNewClassName anOldClassName | anOldClassName := self genericClassName. aNewClassName := self genericClassName. self prepare: [ aClass := self createClass: anOldClassName. ] change: [ aClass rename: aNewClassName. ] verify: [ + self assert: (Smalltalk globals keys includes: aNewClassName). + self deny: (Smalltalk globals keys includes: anOldClassName). - self assert: (Smalltalk keys includes: aNewClassName). - self deny: (Smalltalk keys includes: anOldClassName). ].! Item was changed: ----- Method: SystemChangeFileTest>>testExpressionDoIt (in category 'testing') ----- testExpressionDoIt | aClassName | aClassName := self genericClassName.. self prepare: [ self createClass: aClassName. ] change: [ Compiler evaluate: '(Smalltalk at: ', aClassName storeString, ') removeFromSystem'. ] verify: [ + self deny: (Smalltalk globals keys includes: aClassName). - self deny: (Smalltalk keys includes: aClassName). ].!

1 0

The Trunk: Tests-fbs.243.mcz
by commits＠source.squeak.org 23 Jul '13

23 Jul '13

Frank Shearar uploaded a new version of Tests to project The Trunk: http://source.squeak.org/trunk/Tests-fbs.243.mcz ==================== Summary ==================== Name: Tests-fbs.243 Author: fbs Time: 23 July 2013, 8:50:12.904 pm UUID: e1f01437-4304-ee41-9077-0fc916114ef1 Ancestors: Tests-fbs.242 Graphics -/-> TrueType, Graphics -/-> Morphic. TrueType -> Multilingual because of HostFont class >> #initForSubtitles. Don't really like that. =============== Diff against Tests-fbs.242 =============== Item was changed: ----- Method: PackageDependencyTest>>testGraphics (in category 'tests') ----- testGraphics self testPackage: 'Graphics' dependsExactlyOn: #( Collections Compression Files Kernel - Morphic Multilingual System 'ToolBuilder-Kernel' - TrueType ).! Item was changed: ----- Method: PackageDependencyTest>>testTrueType (in category 'tests') ----- testTrueType self testPackage: 'TrueType' dependsExactlyOn: #( Collections Balloon Files Graphics Kernel + Multilingual System 'ToolBuilder-Kernel' ).!

1 0

Re: [squeak-dev] The Trunk: Tests-fbs.242.mcz
by tim Rowledge 23 Jul '13

23 Jul '13

On 23-07-2013, at 9:55 AM, commits(a)source.squeak.org wrote: > Frank Shearar uploaded a new version of Tests to project The Trunk: > http://source.squeak.org/trunk/Tests-fbs.242.mcz > > Nothing depends on Exceptions anymore. I assume your next job is to remove that dependency? tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Strange OpCodes: RTS: Rewind Tape and Shred

3 3

The Trunk: Morphic-fbs.674.mcz
by commits＠source.squeak.org 23 Jul '13

23 Jul '13

Frank Shearar uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-fbs.674.mcz ==================== Summary ==================== Name: Morphic-fbs.674 Author: fbs Time: 23 July 2013, 8:19:08.276 pm UUID: 64910e8e-45f5-1248-b74d-5c66938bf1c5 Ancestors: Morphic-dtl.673 Break Graphics -> Morphic dependency. Push some UI-independent code down from Morphic into Graphics, and move extension-y things up into Morphic. =============== Diff against Morphic-dtl.673 =============== Item was added: + ----- Method: CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: (in category '*Morphic-Text') ----- + composeFrom: startIndex inRectangle: lineRectangle + firstLine: firstLine leftSide: leftSide rightSide: rightSide + "Answer an instance of TextLineInterval that represents the next line in the paragraph." + | runLength stopCondition | + "Set up margins" + leftMargin := lineRectangle left. + leftSide ifTrue: [leftMargin := leftMargin + + (firstLine ifTrue: [textStyle firstIndent] + ifFalse: [textStyle restIndent])]. + destX := spaceX := leftMargin. + rightMargin := lineRectangle right. + rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent]. + lastIndex := startIndex. "scanning sets last index" + destY := lineRectangle top. + lineHeight := baseline := 0. "Will be increased by setFont" + line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) + rectangle: lineRectangle. + self setStopConditions. "also sets font" + runLength := text runLengthFor: startIndex. + runStopIndex := (lastIndex := startIndex) + (runLength - 1). + spaceCount := 0. + self handleIndentation. + leftMargin := destX. + line leftMargin: leftMargin. + + [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex + in: text string rightX: rightMargin stopConditions: stopConditions + kern: kern. + "See setStopConditions for stopping conditions for composing." + (self perform: stopCondition) + ifTrue: [^ line lineHeight: lineHeight + textStyle leading + baseline: baseline + textStyle leading]] repeat! Item was added: + ----- Method: DisplayScreen>>defaultCanvasClass (in category '*Morphic-blitter defaults') ----- + defaultCanvasClass + "Return the WarpBlt version to use when I am active" + ^FormCanvas! Item was added: + ----- Method: DisplayText>>composeForm (in category '*Morphic-Text') ----- + composeForm + "For the TT strings in MVC widgets in a Morphic world such as a progress bar, the form is created by Morphic machinery." + | canvas tmpText | + Smalltalk isMorphic + ifTrue: + [tmpText := TextMorph new contentsAsIs: text deepCopy. + foreColor ifNotNil: [tmpText text addAttribute: (TextColor color: foreColor)]. + backColor ifNotNil: [tmpText backgroundColor: backColor]. + tmpText setTextStyle: textStyle. + canvas := FormCanvas on: (Form extent: tmpText extent depth: 32). + tmpText drawOn: canvas. + form := canvas form. + ] + ifFalse: [form := self asParagraph asForm]! Item was removed: - 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'! Item was removed: - ----- Method: TextComposer class>>characterForColumnBreak (in category 'as yet unclassified') ----- - characterForColumnBreak - - ^Character value: 12! Item was removed: - ----- Method: TextComposer>>addNullLineForIndex: (in category 'as yet unclassified') ----- - 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. - ! Item was removed: - ----- Method: TextComposer>>addNullLineWithIndex:andRectangle: (in category 'as yet unclassified') ----- - addNullLineWithIndex: index andRectangle: r - - lines addLast: ( - ( - TextLine - start: index - stop: index - 1 - internalSpaces: 0 - paddingWidth: 0 - ) - rectangle: r; - lineHeight: defaultLineHeight baseline: theTextStyle baseline - ) - ! Item was removed: - ----- Method: TextComposer>>checkIfReadyToSlide (in category 'as yet unclassified') ----- - 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 - ] - ]! Item was removed: - ----- Method: TextComposer>>composeAllLines (in category 'as yet unclassified') ----- - composeAllLines - - [currCharIndex <= theText size and: - [(currentY + defaultLineHeight) <= theContainer bottom]] whileTrue: [ - - nowSliding ifTrue: [ - self slideOneLineDown ifNil: [^nil]. - ] ifFalse: [ - self composeOneLine ifNil: [^nil]. - ] - ]. - ! Item was removed: - ----- Method: TextComposer>>composeAllRectangles: (in category 'as yet unclassified') ----- - 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 | |lineIndex| - "Adjust heights across rectangles if necessary" - lineIndex:=lines size - rectangles size + i. - (lines size between: 1 and: lineIndex) ifTrue: - [(lines at: lineIndex) - lineHeight: lines last lineHeight - baseline: lines last baseline] - ]. - isFirstLine := false. - reasonForStopping == #columnBreak ifTrue: [^nil]. - currCharIndex > theText size ifTrue: [ - ^nil "we are finished composing" - ]. - ! Item was removed: - ----- Method: TextComposer>>composeEachRectangleIn: (in category 'as yet unclassified') ----- - 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. - (CharacterSet crlf includes: lastChar) ifTrue: [^#cr]. - wantsColumnBreaks ifTrue: [ - lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. - ]. - ]. - ^false! Item was removed: - ----- Method: TextComposer>>composeLinesFrom:to:delta:into:priorLines:atY:textStyle:text:container:wantsColumnBreaks: (in category 'as yet unclassified') ----- - 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. - 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. - defaultLineHeight := scanner canComputeDefaultLineHeight - ifTrue: [ scanner computeDefaultLineHeight ] - ifFalse: [ theTextStyle lineGrid. ]. - 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} - - ! Item was removed: - ----- Method: TextComposer>>composeOneLine (in category 'as yet unclassified') ----- - composeOneLine - | rectangles | - rectangles := theContainer rectanglesAt: currentY height: defaultLineHeight. - rectangles notEmpty - ifTrue: [(self composeAllRectangles: rectangles) ifNil: [^nil]] - ifFalse: [currentY := currentY + defaultLineHeight]. - self checkIfReadyToSlide! Item was removed: - ----- Method: TextComposer>>fixupLastLineIfCR (in category 'as yet unclassified') ----- - 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 > 0 and: [CharacterSet crlf includes: theText last]) ifFalse: [^self]. - self addNullLineForIndex: theText size + 1. - ! Item was removed: - ----- Method: TextComposer>>slideOneLineDown (in category 'as yet unclassified') ----- - 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 - ]. - ]. - ]. - ! Item was removed: - Object subclass: #TextLine - instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline leftMargin' - classVariableNames: '' - poolDictionaries: 'TextConstants' - category: 'Morphic-Text Support'! - - !TextLine commentStamp: '<historical>' prior: 0! - A TextLine embodies the layout of a line of composed text. - left right top bottom The full line rectangle - firstIndex lastIndex Starting and stopping indices in the full text - internalSpaces Number of spaces to share paddingWidth - paddingWidth Number of pixels of extra space in full line - baseline Distance of baseline below the top of the line - leftMargin Left margin due to paragraph indentation - TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.! Item was removed: - ----- Method: TextLine class>>start:stop:internalSpaces:paddingWidth: (in category 'instance creation') ----- - start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger - "Answer an instance of me with the arguments as the start, stop points, - number of spaces in the line, and width of the padding." - | line | - line := self new firstIndex: startInteger lastIndex: stopInteger. - ^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! Item was removed: - ----- Method: TextLine>>= (in category 'comparing') ----- - = line - - self species = line species - ifTrue: [^((firstIndex = line first and: [lastIndex = line last]) - and: [internalSpaces = line internalSpaces]) - and: [paddingWidth = line paddingWidth]] - ifFalse: [^false]! Item was removed: - ----- Method: TextLine>>baseline (in category 'accessing') ----- - baseline - ^ baseline! Item was removed: - ----- Method: TextLine>>bottom (in category 'accessing') ----- - bottom - ^ bottom! Item was removed: - ----- Method: TextLine>>bottomRight (in category 'accessing') ----- - bottomRight - ^ right@bottom! Item was removed: - ----- Method: TextLine>>first (in category 'accessing') ----- - first - ^ firstIndex! Item was removed: - ----- Method: TextLine>>firstIndex:lastIndex: (in category 'private') ----- - firstIndex: firstInteger lastIndex: lastInteger - firstIndex := firstInteger. - lastIndex := lastInteger! Item was removed: - ----- Method: TextLine>>hash (in category 'comparing') ----- - hash - "#hash is re-implemented because #= is re-implemented" - ^firstIndex hash bitXor: lastIndex hash! Item was removed: - ----- Method: TextLine>>internalSpaces (in category 'accessing') ----- - internalSpaces - "Answer the number of spaces in the line." - - ^internalSpaces! Item was removed: - ----- Method: TextLine>>internalSpaces: (in category 'accessing') ----- - internalSpaces: spacesInteger - "Set the number of spaces in the line to be spacesInteger." - - internalSpaces := spacesInteger! Item was removed: - ----- Method: TextLine>>internalSpaces:paddingWidth: (in category 'private') ----- - internalSpaces: spacesInteger paddingWidth: padWidthInteger - - internalSpaces := spacesInteger. - paddingWidth := padWidthInteger! Item was removed: - ----- Method: TextLine>>justifiedPadFor: (in category 'scanning') ----- - justifiedPadFor: spaceIndex - "Compute the width of pad for a given space in a line of justified text." - - | pad | - internalSpaces = 0 ifTrue: [^0]. - pad := paddingWidth // internalSpaces. - spaceIndex <= (paddingWidth \\ internalSpaces) - ifTrue: [^pad + 1] - ifFalse: [^pad]! Item was removed: - ----- Method: TextLine>>justifiedPadFor:font: (in category 'scanning') ----- - justifiedPadFor: spaceIndex font: aFont - "Compute the width of pad for a given space in a line of justified text." - - | pad | - internalSpaces = 0 ifTrue: [^0]. - ^(aFont notNil and:[aFont isSubPixelPositioned]) - ifTrue:[paddingWidth * 1.0 / internalSpaces] - ifFalse:[ - pad := paddingWidth // internalSpaces. - spaceIndex <= (paddingWidth \\ internalSpaces) - ifTrue: [pad + 1] - ifFalse: [pad]] - ! Item was removed: - ----- Method: TextLine>>justifiedTabDeltaFor: (in category 'scanning') ----- - justifiedTabDeltaFor: spaceIndex - "Compute the delta for a tab in a line of justified text, so tab falls - somewhere plausible when line is justified." - - | pad extraPad | - internalSpaces = 0 ifTrue: [^0]. - pad := paddingWidth // internalSpaces. - extraPad := paddingWidth \\ internalSpaces. - spaceIndex <= extraPad - ifTrue: [^spaceIndex * (pad + 1)] - ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! Item was removed: - ----- Method: TextLine>>last (in category 'accessing') ----- - last - ^ lastIndex! Item was removed: - ----- Method: TextLine>>left (in category 'accessing') ----- - left - ^ left! Item was removed: - ----- Method: TextLine>>leftMargin (in category 'accessing') ----- - leftMargin - "This has to get fixed -- store during composition" - ^ self left! Item was removed: - ----- Method: TextLine>>leftMargin: (in category 'accessing') ----- - leftMargin: lm - left := lm! Item was removed: - ----- Method: TextLine>>leftMarginForAlignment: (in category 'accessing') ----- - leftMarginForAlignment: alignmentCode - alignmentCode = RightFlush ifTrue: [^ self left + paddingWidth]. - alignmentCode = Centered ifTrue: [^ self left + (paddingWidth//2)]. - ^ self left "leftFlush and justified"! Item was removed: - ----- Method: TextLine>>lineHeight (in category 'accessing') ----- - lineHeight - ^ bottom - top! Item was removed: - ----- Method: TextLine>>lineHeight:baseline: (in category 'private') ----- - lineHeight: height baseline: ascent - bottom := top + height. - baseline := ascent! Item was removed: - ----- Method: TextLine>>moveBy: (in category 'updating') ----- - moveBy: delta - "Move my rectangle by the given delta" - left := left + delta x. - right := right + delta x. - top := top + delta y. - bottom := bottom + delta y. - ! Item was removed: - ----- Method: TextLine>>paddingWidth (in category 'accessing') ----- - paddingWidth - "Answer the amount of space to be added to the font." - - ^paddingWidth! Item was removed: - ----- Method: TextLine>>paddingWidth: (in category 'accessing') ----- - paddingWidth: padWidthInteger - "Set the amount of space to be added to the font to be padWidthInteger." - - paddingWidth := padWidthInteger! Item was removed: - ----- Method: TextLine>>printOn: (in category 'printing') ----- - printOn: aStream - super printOn: aStream. - aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! Item was removed: - ----- Method: TextLine>>rectangle (in category 'accessing') ----- - rectangle - ^ self topLeft corner: self bottomRight! Item was removed: - ----- Method: TextLine>>rectangle: (in category 'accessing') ----- - rectangle: lineRectangle - left := lineRectangle left. - right := lineRectangle right. - top := lineRectangle top. - bottom := lineRectangle bottom! Item was removed: - ----- Method: TextLine>>right (in category 'accessing') ----- - right - ^ right! Item was removed: - ----- Method: TextLine>>rightMargin (in category 'accessing') ----- - rightMargin - "This has to get fixed -- store during composition" - ^ self right! Item was removed: - ----- Method: TextLine>>setRight: (in category 'accessing') ----- - setRight: x - right := x! Item was removed: - ----- Method: TextLine>>slide: (in category 'updating') ----- - slide: delta - "Change the starting and stopping points of the line by delta." - - firstIndex := firstIndex + delta. - lastIndex := lastIndex + delta! Item was removed: - ----- Method: TextLine>>slideIndexBy:andMoveTopTo: (in category 'updating') ----- - slideIndexBy: delta andMoveTopTo: newTop - "Relocate my character indices and y-values. - Used to slide constant text up or down in the wake of a text replacement." - - firstIndex := firstIndex + delta. - lastIndex := lastIndex + delta. - bottom := bottom + (newTop - top). - top := newTop. - ! Item was removed: - ----- Method: TextLine>>stop: (in category 'accessing') ----- - stop: stopInteger - "Set the stopping point in the string of the line to be stopInteger." - - lastIndex := stopInteger! Item was removed: - ----- Method: TextLine>>top (in category 'accessing') ----- - top - ^ top! Item was removed: - ----- Method: TextLine>>topLeft (in category 'accessing') ----- - topLeft - ^ left @ top! Item was removed: - ----- Method: TextLine>>width (in category 'accessing') ----- - width - ^ right - left! Item was added: + ----- Method: TextStyle class>>emphasisMenuForFont:target:selector:highlight: (in category '*Morphic-user interface') ----- + emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis + "Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font. + Answer nil if no derivatives exist. + " + + | aMenu derivs | + derivs := font derivativeFonts. + derivs isEmpty ifTrue: [ ^nil ]. + aMenu := MenuMorph entitled: 'emphasis' translated. + derivs := derivs asOrderedCollection. + derivs addFirst: font. + derivs do: [ :df | + aMenu + add: df emphasisString + target: target + selector: selector + argument: df. + aMenu lastItem font: df. + df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]]. + ^ aMenu! Item was added: + ----- Method: TextStyle class>>fontMenuForStyle:target:selector: (in category '*Morphic-user interface') ----- + fontMenuForStyle: styleName target: target selector: selector + ^self fontMenuForStyle: styleName target: target selector: selector highlight: nil! Item was added: + ----- Method: TextStyle class>>fontMenuForStyle:target:selector:highlight: (in category '*Morphic-user interface') ----- + fontMenuForStyle: styleName target: target selector: selector highlight: currentFont + "Offer a font menu for the given style. If one is selected, pass + that font to target with a + call to selector. The fonts will be displayed in that font." + | aMenu | + aMenu := MenuMorph entitled: styleName. + (TextStyle named: styleName) + ifNotNil: [:s | s isTTCStyle + ifTrue: [aMenu + add: 'New Size' + target: self + selector: #chooseTTCFontSize: + argument: {styleName. target. selector}]]. + (self pointSizesFor: styleName) + do: [:pointSize | + | font subMenu displayFont | + font := (self named: styleName) + fontOfPointSize: pointSize. + subMenu := self + emphasisMenuForFont: font + target: target + selector: selector + highlight: (currentFont + ifNotNil: [:cf | (cf familyName = styleName + and: [cf pointSize = font pointSize]) + ifTrue: [currentFont emphasis]]). + subMenu + ifNil: [aMenu + add: pointSize asString , ' Point' + target: target + selector: selector + argument: font] + ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu]. + displayFont := font. + (font isSymbolFont or:[(font hasDistinctGlyphsForAll: pointSize asString , ' Point') not]) + ifTrue:[ + "don't use a symbol font to display its own name!!!!" + displayFont := self default fontOfPointSize: pointSize]. + aMenu lastItem font: displayFont. + currentFont + ifNotNil: [:cf | (cf familyName = styleName + and: [cf pointSize = font pointSize]) + ifTrue: [aMenu lastItem color: Color blue darker]]]. + ^ aMenu! Item was added: + ----- Method: TextStyle class>>fontSizeSummary (in category '*Morphic-user interface') ----- + fontSizeSummary + "Open a text window with a simple summary of the available sizes in each of the fonts in the system." + + "TextStyle fontSizeSummary" + | aString aList | + aList := self knownTextStyles. + aString := String streamContents: + [:aStream | + aList do: [:aStyleName | + aStream nextPutAll: + aStyleName, ' ', + (self fontPointSizesFor: aStyleName) asArray storeString. + aStream cr]]. + (StringHolder new contents: aString) + openLabel: 'Font styles and sizes' translated! Item was added: + ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector: (in category '*Morphic-user interface') ----- + promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector + self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil! Item was added: + ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector:highlight: (in category '*Morphic-user interface') ----- + promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: currentFont + "Morphic Only!! prompt for a font and if one is provided, send it to aTarget using a + message with selector aSelector." + "TextStyle promptForFont: 'Choose system font:' andSendTo: Preferences withSelector: + #setSystemFontTo: " + "Derived from a method written by Robin Gibson" + | menu currentTextStyle | + currentTextStyle := currentFont + ifNotNil: [currentFont textStyleName]. + menu := MenuMorph entitled: aPrompt. + self actualTextStyles keysSortedSafely + do: [:styleName | | subMenu | + subMenu := self + fontMenuForStyle: styleName + target: aTarget + selector: aSelector + highlight: currentFont. + menu add: styleName subMenu: subMenu. + menu lastItem + font: ((self named: styleName) + fontOfSize: 18). + styleName = currentTextStyle + ifTrue: [menu lastItem color: Color blue darker]]. + menu popUpInWorld: self currentWorld!

1 0

The Trunk: Graphics-fbs.220.mcz
by commits＠source.squeak.org 23 Jul '13

23 Jul '13

Frank Shearar uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-fbs.220.mcz ==================== Summary ==================== Name: Graphics-fbs.220 Author: fbs Time: 23 July 2013, 8:18:46.726 pm UUID: 4066227b-0cc5-0f4f-a6b8-dd4f0c5e27f1 Ancestors: Graphics-fbs.219 Break Graphics -> Morphic dependency. Push some UI-independent code down from Morphic into Graphics, and move extension-y things up into Morphic. =============== Diff against Graphics-fbs.219 =============== Item was changed: SystemOrganization addCategory: #'Graphics-Display Objects'! SystemOrganization addCategory: #'Graphics-External-Ffenestri'! SystemOrganization addCategory: #'Graphics-Files'! SystemOrganization addCategory: #'Graphics-Fonts'! SystemOrganization addCategory: #'Graphics-Primitives'! SystemOrganization addCategory: #'Graphics-Text'! SystemOrganization addCategory: #'Graphics-Transformations'! + SystemOrganization addCategory: #'Graphics-Text Support'! Item was removed: - ----- Method: CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: (in category 'scanning') ----- - composeFrom: startIndex inRectangle: lineRectangle - firstLine: firstLine leftSide: leftSide rightSide: rightSide - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition | - "Set up margins" - leftMargin := lineRectangle left. - leftSide ifTrue: [leftMargin := leftMargin + - (firstLine ifTrue: [textStyle firstIndent] - ifFalse: [textStyle restIndent])]. - destX := spaceX := leftMargin. - rightMargin := lineRectangle right. - rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent]. - lastIndex := startIndex. "scanning sets last index" - destY := lineRectangle top. - lineHeight := baseline := 0. "Will be increased by setFont" - line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - self setStopConditions. "also sets font" - runLength := text runLengthFor: startIndex. - runStopIndex := (lastIndex := startIndex) + (runLength - 1). - spaceCount := 0. - self handleIndentation. - leftMargin := destX. - line leftMargin: leftMargin. - - [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: kern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) - ifTrue: [^ line lineHeight: lineHeight + textStyle leading - baseline: baseline + textStyle leading]] repeat! Item was removed: - ----- Method: DisplayScreen>>defaultCanvasClass (in category 'blitter defaults') ----- - defaultCanvasClass - "Return the WarpBlt version to use when I am active" - ^FormCanvas! Item was removed: - ----- Method: DisplayText>>composeForm (in category 'private') ----- - composeForm - "For the TT strings in MVC widgets in a Morphic world such as a progress bar, the form is created by Morphic machinery." - | canvas tmpText | - Smalltalk isMorphic - ifTrue: - [tmpText := TextMorph new contentsAsIs: text deepCopy. - foreColor ifNotNil: [tmpText text addAttribute: (TextColor color: foreColor)]. - backColor ifNotNil: [tmpText backgroundColor: backColor]. - tmpText setTextStyle: textStyle. - canvas := FormCanvas on: (Form extent: tmpText extent depth: 32). - tmpText drawOn: canvas. - form := canvas form. - ] - ifFalse: [form := self asParagraph asForm]! Item was added: + 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: 'Graphics-Text Support'! Item was added: + ----- Method: TextComposer class>>characterForColumnBreak (in category 'as yet unclassified') ----- + characterForColumnBreak + + ^Character value: 12! Item was added: + ----- Method: TextComposer>>addNullLineForIndex: (in category 'as yet unclassified') ----- + 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. + ! Item was added: + ----- Method: TextComposer>>addNullLineWithIndex:andRectangle: (in category 'as yet unclassified') ----- + addNullLineWithIndex: index andRectangle: r + + lines addLast: ( + ( + TextLine + start: index + stop: index - 1 + internalSpaces: 0 + paddingWidth: 0 + ) + rectangle: r; + lineHeight: defaultLineHeight baseline: theTextStyle baseline + ) + ! Item was added: + ----- Method: TextComposer>>checkIfReadyToSlide (in category 'as yet unclassified') ----- + 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 + ] + ]! Item was added: + ----- Method: TextComposer>>composeAllLines (in category 'as yet unclassified') ----- + composeAllLines + + [currCharIndex <= theText size and: + [(currentY + defaultLineHeight) <= theContainer bottom]] whileTrue: [ + + nowSliding ifTrue: [ + self slideOneLineDown ifNil: [^nil]. + ] ifFalse: [ + self composeOneLine ifNil: [^nil]. + ] + ]. + ! Item was added: + ----- Method: TextComposer>>composeAllRectangles: (in category 'as yet unclassified') ----- + 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 | |lineIndex| + "Adjust heights across rectangles if necessary" + lineIndex:=lines size - rectangles size + i. + (lines size between: 1 and: lineIndex) ifTrue: + [(lines at: lineIndex) + lineHeight: lines last lineHeight + baseline: lines last baseline] + ]. + isFirstLine := false. + reasonForStopping == #columnBreak ifTrue: [^nil]. + currCharIndex > theText size ifTrue: [ + ^nil "we are finished composing" + ]. + ! Item was added: + ----- Method: TextComposer>>composeEachRectangleIn: (in category 'as yet unclassified') ----- + 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. + (CharacterSet crlf includes: lastChar) ifTrue: [^#cr]. + wantsColumnBreaks ifTrue: [ + lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. + ]. + ]. + ^false! Item was added: + ----- Method: TextComposer>>composeLinesFrom:to:delta:into:priorLines:atY:textStyle:text:container:wantsColumnBreaks: (in category 'as yet unclassified') ----- + 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. + 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. + defaultLineHeight := scanner canComputeDefaultLineHeight + ifTrue: [ scanner computeDefaultLineHeight ] + ifFalse: [ theTextStyle lineGrid. ]. + 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} + + ! Item was added: + ----- Method: TextComposer>>composeOneLine (in category 'as yet unclassified') ----- + composeOneLine + | rectangles | + rectangles := theContainer rectanglesAt: currentY height: defaultLineHeight. + rectangles notEmpty + ifTrue: [(self composeAllRectangles: rectangles) ifNil: [^nil]] + ifFalse: [currentY := currentY + defaultLineHeight]. + self checkIfReadyToSlide! Item was added: + ----- Method: TextComposer>>fixupLastLineIfCR (in category 'as yet unclassified') ----- + 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 > 0 and: [CharacterSet crlf includes: theText last]) ifFalse: [^self]. + self addNullLineForIndex: theText size + 1. + ! Item was added: + ----- Method: TextComposer>>slideOneLineDown (in category 'as yet unclassified') ----- + 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 + ]. + ]. + ]. + ! Item was added: + Object subclass: #TextLine + instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline leftMargin' + classVariableNames: '' + poolDictionaries: 'TextConstants' + category: 'Graphics-Text Support'! + + !TextLine commentStamp: '<historical>' prior: 0! + A TextLine embodies the layout of a line of composed text. + left right top bottom The full line rectangle + firstIndex lastIndex Starting and stopping indices in the full text + internalSpaces Number of spaces to share paddingWidth + paddingWidth Number of pixels of extra space in full line + baseline Distance of baseline below the top of the line + leftMargin Left margin due to paragraph indentation + TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.! Item was added: + ----- Method: TextLine class>>start:stop:internalSpaces:paddingWidth: (in category 'instance creation') ----- + start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger + "Answer an instance of me with the arguments as the start, stop points, + number of spaces in the line, and width of the padding." + | line | + line := self new firstIndex: startInteger lastIndex: stopInteger. + ^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! Item was added: + ----- Method: TextLine>>= (in category 'comparing') ----- + = line + + self species = line species + ifTrue: [^((firstIndex = line first and: [lastIndex = line last]) + and: [internalSpaces = line internalSpaces]) + and: [paddingWidth = line paddingWidth]] + ifFalse: [^false]! Item was added: + ----- Method: TextLine>>baseline (in category 'accessing') ----- + baseline + ^ baseline! Item was added: + ----- Method: TextLine>>bottom (in category 'accessing') ----- + bottom + ^ bottom! Item was added: + ----- Method: TextLine>>bottomRight (in category 'accessing') ----- + bottomRight + ^ right@bottom! Item was added: + ----- Method: TextLine>>first (in category 'accessing') ----- + first + ^ firstIndex! Item was added: + ----- Method: TextLine>>firstIndex:lastIndex: (in category 'private') ----- + firstIndex: firstInteger lastIndex: lastInteger + firstIndex := firstInteger. + lastIndex := lastInteger! Item was added: + ----- Method: TextLine>>hash (in category 'comparing') ----- + hash + "#hash is re-implemented because #= is re-implemented" + ^firstIndex hash bitXor: lastIndex hash! Item was added: + ----- Method: TextLine>>internalSpaces (in category 'accessing') ----- + internalSpaces + "Answer the number of spaces in the line." + + ^internalSpaces! Item was added: + ----- Method: TextLine>>internalSpaces: (in category 'accessing') ----- + internalSpaces: spacesInteger + "Set the number of spaces in the line to be spacesInteger." + + internalSpaces := spacesInteger! Item was added: + ----- Method: TextLine>>internalSpaces:paddingWidth: (in category 'private') ----- + internalSpaces: spacesInteger paddingWidth: padWidthInteger + + internalSpaces := spacesInteger. + paddingWidth := padWidthInteger! Item was added: + ----- Method: TextLine>>justifiedPadFor: (in category 'scanning') ----- + justifiedPadFor: spaceIndex + "Compute the width of pad for a given space in a line of justified text." + + | pad | + internalSpaces = 0 ifTrue: [^0]. + pad := paddingWidth // internalSpaces. + spaceIndex <= (paddingWidth \\ internalSpaces) + ifTrue: [^pad + 1] + ifFalse: [^pad]! Item was added: + ----- Method: TextLine>>justifiedPadFor:font: (in category 'scanning') ----- + justifiedPadFor: spaceIndex font: aFont + "Compute the width of pad for a given space in a line of justified text." + + | pad | + internalSpaces = 0 ifTrue: [^0]. + ^(aFont notNil and:[aFont isSubPixelPositioned]) + ifTrue:[paddingWidth * 1.0 / internalSpaces] + ifFalse:[ + pad := paddingWidth // internalSpaces. + spaceIndex <= (paddingWidth \\ internalSpaces) + ifTrue: [pad + 1] + ifFalse: [pad]] + ! Item was added: + ----- Method: TextLine>>justifiedTabDeltaFor: (in category 'scanning') ----- + justifiedTabDeltaFor: spaceIndex + "Compute the delta for a tab in a line of justified text, so tab falls + somewhere plausible when line is justified." + + | pad extraPad | + internalSpaces = 0 ifTrue: [^0]. + pad := paddingWidth // internalSpaces. + extraPad := paddingWidth \\ internalSpaces. + spaceIndex <= extraPad + ifTrue: [^spaceIndex * (pad + 1)] + ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! Item was added: + ----- Method: TextLine>>last (in category 'accessing') ----- + last + ^ lastIndex! Item was added: + ----- Method: TextLine>>left (in category 'accessing') ----- + left + ^ left! Item was added: + ----- Method: TextLine>>leftMargin (in category 'accessing') ----- + leftMargin + "This has to get fixed -- store during composition" + ^ self left! Item was added: + ----- Method: TextLine>>leftMargin: (in category 'accessing') ----- + leftMargin: lm + left := lm! Item was added: + ----- Method: TextLine>>leftMarginForAlignment: (in category 'accessing') ----- + leftMarginForAlignment: alignmentCode + alignmentCode = RightFlush ifTrue: [^ self left + paddingWidth]. + alignmentCode = Centered ifTrue: [^ self left + (paddingWidth//2)]. + ^ self left "leftFlush and justified"! Item was added: + ----- Method: TextLine>>lineHeight (in category 'accessing') ----- + lineHeight + ^ bottom - top! Item was added: + ----- Method: TextLine>>lineHeight:baseline: (in category 'private') ----- + lineHeight: height baseline: ascent + bottom := top + height. + baseline := ascent! Item was added: + ----- Method: TextLine>>moveBy: (in category 'updating') ----- + moveBy: delta + "Move my rectangle by the given delta" + left := left + delta x. + right := right + delta x. + top := top + delta y. + bottom := bottom + delta y. + ! Item was added: + ----- Method: TextLine>>paddingWidth (in category 'accessing') ----- + paddingWidth + "Answer the amount of space to be added to the font." + + ^paddingWidth! Item was added: + ----- Method: TextLine>>paddingWidth: (in category 'accessing') ----- + paddingWidth: padWidthInteger + "Set the amount of space to be added to the font to be padWidthInteger." + + paddingWidth := padWidthInteger! Item was added: + ----- Method: TextLine>>printOn: (in category 'printing') ----- + printOn: aStream + super printOn: aStream. + aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! Item was added: + ----- Method: TextLine>>rectangle (in category 'accessing') ----- + rectangle + ^ self topLeft corner: self bottomRight! Item was added: + ----- Method: TextLine>>rectangle: (in category 'accessing') ----- + rectangle: lineRectangle + left := lineRectangle left. + right := lineRectangle right. + top := lineRectangle top. + bottom := lineRectangle bottom! Item was added: + ----- Method: TextLine>>right (in category 'accessing') ----- + right + ^ right! Item was added: + ----- Method: TextLine>>rightMargin (in category 'accessing') ----- + rightMargin + "This has to get fixed -- store during composition" + ^ self right! Item was added: + ----- Method: TextLine>>setRight: (in category 'accessing') ----- + setRight: x + right := x! Item was added: + ----- Method: TextLine>>slide: (in category 'updating') ----- + slide: delta + "Change the starting and stopping points of the line by delta." + + firstIndex := firstIndex + delta. + lastIndex := lastIndex + delta! Item was added: + ----- Method: TextLine>>slideIndexBy:andMoveTopTo: (in category 'updating') ----- + slideIndexBy: delta andMoveTopTo: newTop + "Relocate my character indices and y-values. + Used to slide constant text up or down in the wake of a text replacement." + + firstIndex := firstIndex + delta. + lastIndex := lastIndex + delta. + bottom := bottom + (newTop - top). + top := newTop. + ! Item was added: + ----- Method: TextLine>>stop: (in category 'accessing') ----- + stop: stopInteger + "Set the stopping point in the string of the line to be stopInteger." + + lastIndex := stopInteger! Item was added: + ----- Method: TextLine>>top (in category 'accessing') ----- + top + ^ top! Item was added: + ----- Method: TextLine>>topLeft (in category 'accessing') ----- + topLeft + ^ left @ top! Item was added: + ----- Method: TextLine>>width (in category 'accessing') ----- + width + ^ right - left! Item was removed: - ----- Method: TextStyle class>>emphasisMenuForFont:target:selector:highlight: (in category 'user interface') ----- - emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis - "Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font. - Answer nil if no derivatives exist. - " - - | aMenu derivs | - derivs := font derivativeFonts. - derivs isEmpty ifTrue: [ ^nil ]. - aMenu := MenuMorph entitled: 'emphasis' translated. - derivs := derivs asOrderedCollection. - derivs addFirst: font. - derivs do: [ :df | - aMenu - add: df emphasisString - target: target - selector: selector - argument: df. - aMenu lastItem font: df. - df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]]. - ^ aMenu! Item was removed: - ----- Method: TextStyle class>>fontMenuForStyle:target:selector: (in category 'user interface') ----- - fontMenuForStyle: styleName target: target selector: selector - ^self fontMenuForStyle: styleName target: target selector: selector highlight: nil! Item was removed: - ----- Method: TextStyle class>>fontMenuForStyle:target:selector:highlight: (in category 'user interface') ----- - fontMenuForStyle: styleName target: target selector: selector highlight: currentFont - "Offer a font menu for the given style. If one is selected, pass - that font to target with a - call to selector. The fonts will be displayed in that font." - | aMenu | - aMenu := MenuMorph entitled: styleName. - (TextStyle named: styleName) - ifNotNil: [:s | s isTTCStyle - ifTrue: [aMenu - add: 'New Size' - target: self - selector: #chooseTTCFontSize: - argument: {styleName. target. selector}]]. - (self pointSizesFor: styleName) - do: [:pointSize | - | font subMenu displayFont | - font := (self named: styleName) - fontOfPointSize: pointSize. - subMenu := self - emphasisMenuForFont: font - target: target - selector: selector - highlight: (currentFont - ifNotNil: [:cf | (cf familyName = styleName - and: [cf pointSize = font pointSize]) - ifTrue: [currentFont emphasis]]). - subMenu - ifNil: [aMenu - add: pointSize asString , ' Point' - target: target - selector: selector - argument: font] - ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu]. - displayFont := font. - (font isSymbolFont or:[(font hasDistinctGlyphsForAll: pointSize asString , ' Point') not]) - ifTrue:[ - "don't use a symbol font to display its own name!!!!" - displayFont := self default fontOfPointSize: pointSize]. - aMenu lastItem font: displayFont. - currentFont - ifNotNil: [:cf | (cf familyName = styleName - and: [cf pointSize = font pointSize]) - ifTrue: [aMenu lastItem color: Color blue darker]]]. - ^ aMenu! Item was removed: - ----- Method: TextStyle class>>fontSizeSummary (in category 'user interface') ----- - fontSizeSummary - "Open a text window with a simple summary of the available sizes in each of the fonts in the system." - - "TextStyle fontSizeSummary" - | aString aList | - aList := self knownTextStyles. - aString := String streamContents: - [:aStream | - aList do: [:aStyleName | - aStream nextPutAll: - aStyleName, ' ', - (self fontPointSizesFor: aStyleName) asArray storeString. - aStream cr]]. - (StringHolder new contents: aString) - openLabel: 'Font styles and sizes' translated! Item was removed: - ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector: (in category 'user interface') ----- - promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector - self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil! Item was removed: - ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector:highlight: (in category 'user interface') ----- - promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: currentFont - "Morphic Only!! prompt for a font and if one is provided, send it to aTarget using a - message with selector aSelector." - "TextStyle promptForFont: 'Choose system font:' andSendTo: Preferences withSelector: - #setSystemFontTo: " - "Derived from a method written by Robin Gibson" - | menu currentTextStyle | - currentTextStyle := currentFont - ifNotNil: [currentFont textStyleName]. - menu := MenuMorph entitled: aPrompt. - self actualTextStyles keysSortedSafely - do: [:styleName | | subMenu | - subMenu := self - fontMenuForStyle: styleName - target: aTarget - selector: aSelector - highlight: currentFont. - menu add: styleName subMenu: subMenu. - menu lastItem - font: ((self named: styleName) - fontOfSize: 18). - styleName = currentTextStyle - ifTrue: [menu lastItem color: Color blue darker]]. - menu popUpInWorld: self currentWorld!

1 0

← Newer
1
...
7
8
9
10
11
12
13
...
35
Older →

Jump to page: