home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
European Smalltalk User Group 2004 September
/
esugcd.iso
/
Books-Tutorial-Lectures
/
Books
/
FreeBooks
/
GuzdialBookDrafts
/
CRCmorphs.cs
< prev
next >
Wrap
Text File
|
2003-03-31
|
6KB
|
197 lines
'From Squeak 2.5 of August 6, 1999 on 15 September 1999 at 4:28:30 pm'!
"Change Set: CRCCard
Date: 10 April 1999
Author: Mark Guzdial and Lex Spoon
A basic CRC Card and morphic interface."!
BorderedMorph subclass: #GridMorph
instanceVariableNames: 'paneMorphs paneRects '
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Windows'!
GridMorph subclass: #LabelledGridMorph
instanceVariableNames: 'labelMorph labelBorderMorph '
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Windows'!
LabelledGridMorph subclass: #CRCCard
instanceVariableNames: 'classname responsibilities collaborators '
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Windows'!
!GridMorph commentStamp: '<historical>' prior: 0!
Lays out objects in a grid, like SystemWindows do.!
!GridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 15:00'!
addMorph: aMorph frame: relFrame
self addMorph: aMorph.
paneMorphs _ paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
paneRects _ paneRects copyReplaceFrom: 1 to: 0 with: (Array with: relFrame).
aMorph borderWidth: 1; borderColor: Color black;
bounds: ((relFrame scaleBy: self paneArea extent) translateBy: self paneArea topLeft) truncated.
! !
!GridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 14:44'!
extent: newExtent
super extent: newExtent.
self setBoundsOfPaneMorphs.! !
!GridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 14:47'!
initialize
super initialize.
paneMorphs _ #().
paneRects _ #().
self color: Color white.
self extent: 300@200.
! !
!GridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 14:47'!
paneArea
"return the bounds where panes are to be placed"
^self bounds! !
!GridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 14:46'!
setBoundsOfPaneMorphs
| paneArea |
paneArea _ self paneArea.
paneMorphs with: paneRects do:
[:m :frame |
m bounds: (((frame scaleBy: paneArea extent) translateBy: paneArea topLeft)) truncated]! !
!LabelledGridMorph commentStamp: '<historical>' prior: 0!
A lot like a system window, except it doesn't do expand/contract, and it doesn't have a notion of the "active" window!
!LabelledGridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 15:02'!
extent: newExtent
super extent: newExtent.
self recenterLabel.! !
!LabelledGridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 15:13'!
initialize
labelMorph _ StringMorph new contents: ''.
labelBorderMorph _ RectangleMorph new.
labelBorderMorph color: Color white; borderWidth: 2.
super initialize.
self addMorph: labelBorderMorph.
labelBorderMorph addMorph: labelMorph.! !
!LabelledGridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 15:06'!
label: aStringOrText
labelMorph contents: aStringOrText.
self recenterLabel.! !
!LabelledGridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 15:13'!
paneArea
^self bounds withTop: (self bounds top + labelMorph height + 6)! !
!LabelledGridMorph methodsFor: 'as yet unclassified' stamp: 'ls 4/10/1999 15:13'!
recenterLabel
labelBorderMorph extent: (self width @ (labelMorph height + 6)).
labelMorph position: (
labelBorderMorph position + (3@3) +
((labelBorderMorph width - labelMorph width / 2 max: 0) @ 0)
) truncated.! !
Smalltalk renameClassNamed: #CRCWindow as: #CRCCard!
!CRCCard methodsFor: 'all' stamp: 'ls 4/10/1999 14:10'!
className
^classname! !
!CRCCard methodsFor: 'all' stamp: 'ls 4/10/1999 14:10'!
className: aString
classname _ aString.
^ true! !
!CRCCard methodsFor: 'all' stamp: 'mjg 9/25/1998 16:00'!
collaborators
^collaborators! !
!CRCCard methodsFor: 'all' stamp: 'mjg 9/25/1998 16:26'!
collaborators: aString
collaborators _ aString.
^true! !
!CRCCard methodsFor: 'all' stamp: 'ls 4/10/1999 13:51'!
initialExtent
^360@230! !
!CRCCard methodsFor: 'all' stamp: 'mjg 9/15/1999 16:22'!
initialize
^self openAsMorph
! !
!CRCCard methodsFor: 'all' stamp: 'ls 4/10/1999 15:37'!
openAsMorph
"open a set of windows for viewing this browser"
|win |
"create a window for it"
win _ LabelledGridMorph new.
win label: 'CRC Card'.
"create a class view"
win addMorph: (TextComponent new setText: 'Class:') frame: (0.0@0.0 extent: 0.2@0.1).
win addMorph: (PluggableTextMorph on: self text: #className accept: #className:) frame: (0.2@0.0 extent: 0.8@0.1).
"create a Responsibilities frame"
win addMorph: (TextComponent new setText: 'Responsibilities:') frame: (0.0@0.1 extent: 0.5@0.10).
win addMorph: (PluggableTextMorph on: self text: #responsibilities accept: #responsibilities:) frame: (0.0@0.20 extent: 0.5@0.80).
"create a Collaborators frame"
win addMorph: (TextComponent new setText: 'Collaborators:') frame: (0.5@0.10 extent: 0.5@0.10).
win addMorph: (PluggableTextMorph on: self text: #collaborators accept: #collaborators:) frame: (0.5@0.20 extent: 0.5@0.80).
win openInWorld.
^win! !
!CRCCard methodsFor: 'all' stamp: 'ls 4/10/1999 15:28'!
openAsMorphOrig
"(Mark's original version, using SystemWindow)"
"open a set of windows for viewing this browser"
|win |
"create a window for it"
win _ SystemWindow labelled: 'CRC'.
win model: self.
"create a class view"
win addMorph: (TextComponent new setText: 'Class:') frame: (0.0@0.0 extent: 0.10@0.1).
win addMorph: (PluggableTextMorph on: self text: #className accept: #className:) frame: (0.10@0.0 extent: 0.90@0.1).
"create a Responsibilities frame"
win addMorph: (TextComponent new setText: 'Responsibilities:') frame: (0.0@0.1 extent: 0.5@0.10).
win addMorph: (PluggableTextMorph on: self text: #responsibilities accept: #responsibilities:) frame: (0.0@0.20 extent: 0.5@0.80).
"create a Collaborators frame"
win addMorph: (TextComponent new setText: 'Collaborators:') frame: (0.5@0.10 extent: 0.5@0.10).
win addMorph: (PluggableTextMorph on: self text: #collaborators accept: #collaborators:) frame: (0.5@0.20 extent: 0.5@0.80).
win openInWorld.
^win! !
!CRCCard methodsFor: 'all' stamp: 'mjg 9/25/1998 16:00'!
responsibilities
^responsibilities! !
!CRCCard methodsFor: 'all' stamp: 'mjg 9/25/1998 16:26'!
responsibilities: aString
responsibilities _ aString.
^true! !
CRCCard removeSelector: #class!
CRCCard removeSelector: #class:!