"====================================================================== | | Smalltalk Tk-based GUI building blocks (canvas widget). | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Paolo Bonzini. | | This file is part of the GNU Smalltalk class library. | | The GNU Smalltalk class library is free software; you can redistribute it | and/or modify it under the terms of the GNU Lesser General Public License | as published by the Free Software Foundation; either version 2.1, or (at | your option) any later version. | | The GNU Smalltalk class library is distributed in the hope that it will be | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser | General Public License for more details. | | You should have received a copy of the GNU Lesser General Public License | along with the GNU Smalltalk class library; see the file COPYING.LESSER. | If not, write to the Free Software Foundation, 59 Temple Place - Suite | 330, Boston, MA 02111-1307, USA. | ======================================================================" "----------------------- Main canvas widget class -------------------" BViewport subclass: #BCanvas instanceVariableNames: 'items boundingBox' classVariableNames: 'Initialized' poolDictionaries: '' category: 'Graphics-Windows' ! BCanvas comment: ' I am an host for whatever geometric shape you want. If you want to do some fancy graphics with Smalltalk, I''ll be happy to help. My friends derived from BCanvasObject ask me all sort of things to do, so I am the real worker, not they! BCanvasObject: I am BCanvas: No I am BCanvasObject: No I am BCanvas: No I am well, you know, he always has something to object.'! BCanvas defineAccessor: 'foregroundColor' option: 'foreground' fromStringCode: ''; defineAccessor: 'backgroundColor' option: 'background' fromStringCode: ''; defineMutator: 'foregroundColor' option: 'foreground' toStringCode: ''; defineMutator: 'backgroundColor' option: 'background' toStringCode: ''! !BCanvas class methodsFor: 'private'! initializeOnStartup Initialized := false ! ! !BCanvas methodsFor: 'widget protocol'! at: aPoint | item | self tclEval: '%1 find closest [%1 canvasx %2] [%1 canvasy %3]' with: self connected with: aPoint x printString with: aPoint y printString. item := items at: self tclResult ifAbsent: [ ^nil ]. ^(item boundingBox containsPoint: aPoint) ifTrue: [ item ] ifFalse: [ nil ] ! between: origin and: corner do: aBlock | r | r := Rectangle origin: origin corner: corner. items copy do: [ :each | (each boundingBox intersects: r) ifTrue: [ aBlock value: each ] ] ! boundingBox ^boundingBox ! destroyed items do: [ :each | (each isKindOf: BCanvasObject) ifTrue: [ each destroyed ] ] ! do: aBlock items do: aBlock ! empty items copy do: [ :each | each remove ] ! extraSpace ^self properties at: #extraSpace ifAbsentPut: [ Point new ] ! extraSpace: aPoint self properties at: #extraSpace put: aPoint ! items ^items copy ! mapPoint: aPoint | x stream | self tclEval: 'return "[%1 canvasx %2] [%1 canvasy %3]"' with: aPoint x printString with: aPoint y printString. stream := ReadStream on: self tclResult. x := (stream upTo: $ ) asInteger. ^x @ stream upToEnd asInteger ! ! !BCanvas methodsFor: 'private'! create self create: '-highlightthickness 0'. self tclEval: self connected, ' xview moveto 0'. self tclEval: self connected, ' yview moveto 0'. ! defineSeeProcedure Initialized := true. self tclEval: ' ## "see" method alternative for canvas by Jeffrey Hobbs ## Aligns the named item as best it can in the middle of the screen ## Behavior depends on whether -scrollregion is set ## ## c - a canvas widget ## item - a canvas tagOrId proc canvas_see {c item} { set box [$c bbox $item] if [string match {} $box] return if [string match {} [$c cget -scrollreg]] { ## People really should set -scrollregion you know... foreach {x y x1 y1} $box { set x [expr round(2.5*($x1+$x)/[winfo width $c])] set y [expr round(2.5*($y1+$y)/[winfo height $c])] } $c xview moveto 0 $c yview moveto 0 $c xview scroll $x units $c yview scroll $y units } else { ## If -scrollregion is set properly, use this foreach {x y x1 y1} $box {top btm} [$c yview] {left right} [$c xview] {p q xmax ymax} [$c cget -scrollreg] { set xpos [expr (($x1+$x)/2.0)/$xmax - ($right-$left)/2.0] set ypos [expr (($y1+$y)/2.0)/$ymax - ($btm-$top)/2.0] } $c xview moveto $xpos $c yview moveto $ypos } } ' ! extractCoordinatesFrom: aPointOrArray to: stream (aPointOrArray respondsTo: #do:) ifTrue: [ aPointOrArray do: [ :each | stream space; print: each asInteger ] ] ifFalse: [ stream space; print: aPointOrArray x asInteger; space; print: aPointOrArray y asInteger ] ! initialize: parent items := LookupTable new. super initialize: parent ! widgetType ^'canvas ' ! ! !BCanvas methodsFor: 'geometry management'! addChild: child | name | self tclEval: self connected, ' create window 0 0 -window ', child container. name := self tclResult. items at: name put: child. child properties at: #canvasItemId put: name. child properties at: #xyGeom put: Point new. ^self basicAddChild: child ! xChild: child ^(child properties at: #xyGeom ifAbsentPut: [ Point new ]) x! child: child x: value | id xy | xy := child properties at: #xyGeom. xy x: value. id := child properties at: #canvasItemId. self item: id points: (Array with: xy)! child: child xOffset: value self child: child x: (self xChild: child) + value! yChild: child ^(child properties at: #xyGeom ifAbsentPut: [ Point new ]) y! child: child y: value | id xy | xy := child properties at: #xyGeom. xy y: value. id := child properties at: #canvasItemId. self item: id points: (Array with: xy)! child: child yOffset: value self child: child y: (self yChild: child) + value! widthChild: child "Answer the given child's width in pixels." ^child widthAbsolute! child: child width: value "Set the given child's width." | id xy | id := child properties at: #canvasItemId. self item: id at: #width! child: child widthOffset: value self child: child width: (self widthChild: child) + value! heightChild: child "Answer the given child's height." ^child heightAbsolute! child: child height: value "Set the given child's height." | id xy | id := child properties at: #canvasItemId. self item: id at: #height! child: child heightOffset: value self child: child height: (self heightChild: child) + value! ! !BCanvas methodsFor: 'BCanvasObject private protocol'! itemCreate: item | stream name scrollRegion | stream := WriteStream on: (String new: 50). boundingBox := boundingBox isNil ifFalse: [ boundingBox merge: item boundingBox ] ifTrue: [ item boundingBox ]. stream nextPutAll: self connected; nextPutAll: ' create '; nextPutAll: item itemType; space. item points do: [ :each | self extractCoordinatesFrom: each to: stream ]. item properties keysAndValuesDo: [ :key :value | stream nextPutAll: ' -'; nextPutAll: key; space; nextPutAll: value asTkString ]. self tclEval: stream contents. name := self tclResult. items at: name put: item. scrollRegion := boundingBox expandBy: self extraSpace. stream reset; nextPutAll: self connected; nextPutAll: ' configure -scrollregion {'; print: scrollRegion left asInteger; space; print: scrollRegion top asInteger; space; print: scrollRegion right asInteger; space; print: scrollRegion bottom asInteger; nextPut: $}. self tclEval: stream contents. ^name ! item: name at: option self tclEval: '%1 itemcget %2 -%3' with: self connected with: name with: option ! item: name at: option put: value self tclEval: '%1 itemconfigure %2 -%3 %4' with: self connected with: name with: option with: value asTkString ! item: name bind: event to: aSymbol of: anObject parameters: params self bind: event to: aSymbol of: anObject parameters: params prefix: self connected, ' bind ', name ! item: name points: pointsArray | stream | stream := WriteStream on: (String new: 50). stream nextPutAll: self connected; nextPutAll: ' coords '; nextPutAll: name. pointsArray do: [ :each | self extractCoordinatesFrom: each to: stream ]. self tclEval: stream contents. ! lower: item self tclEval: self connected, ' lower ', item ! raise: item self tclEval: self connected, ' raise ', item ! remove: item (items removeKey: item) destroyed. self tclEval: self connected, ' delete ', item ! show: item Initialized ifFalse: [ self defineSeeProcedure ]. self tclEval: 'canvas_see %1 %2' with: self connected with: item ! ! "---------------------- Scrolling canvases ----------------------------" BCanvas subclass: #BScrolledCanvas instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BScrolledCanvas comment: ' I am much similar to BCanvas, but I sport, in addition, two fancy scroll bars. This is just a convenience, since it could be easily done when creating the canvas...'! !BScrolledCanvas methodsFor: 'private'! create "Create with both scrollbars" super create. self horizontal: true; vertical: true ! ! "----------------------- Abstract item --------------------------------" BEventTarget subclass: #BCanvasObject instanceVariableNames: 'blox name properties' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BCanvasObject comment: ' I am the ultimate ancestor of all items that you can put in a BCanvas. I provide some general methods to my concrete offspring.'! !BCanvasObject class methodsFor: 'instance creation'! new self shouldNotImplement ! new: parentCanvas ^self basicNew blox: parentCanvas; initializeWithProperties: IdentityDictionary new ! ! !BCanvasObject methodsFor: 'accessing'! blox ^blox ! boundingBox self subclassResponsibility ! color ^self at: #fill ! color: color ^self at: #fill put: color ! copyObject ^self copyInto: self blox ! copyInto: newCanvas ^self species basicNew blox: newCanvas; initializeWithProperties: self properties copy; points: self points; postCopy; yourself ! createCopy ^self copyObject create; yourself ! createCopyInto: newCanvas ^(self copyInto: newCanvas) create; yourself ! deepCopy "It does not make sense to make a copy, because it would make data inconsistent across different objects; so answer the receiver" ^self ! shallowCopy "It does not make sense to make a copy, because it would make data inconsistent across different objects; so answer the receiver" ^self ! grayOut self at: #stipple put: 'gray50' ! name ^name ! ! !BCanvasObject methodsFor: 'widget protocol'! create self created ifTrue: [ self error: 'object already created' ]. self checkValidity ifFalse: [ self error: 'please initialize the object correctly' ]. name := self blox itemCreate: self ! created ^self name notNil ! lower self blox lower: self name ! raise self blox raise: self name ! redraw self created ifTrue: [ self blox item: self name points: self points ] ifFalse: [ self create ] ! remove self blox remove: self name. ! show self blox show: self name ! ! !BCanvasObject methodsFor: 'private'! at: option ^self properties at: option ifAbsentPut: [ self created ifFalse: [ self error: 'option not set yet' ]. self blox item: self name at: option ] ! at: option put: value self created ifTrue: [ self blox item: self name at: option put: value ]. ^self properties at: option put: value ! primBind: event to: aSymbol of: anObject parameters: params ^self blox item: self name bind: event to: aSymbol of: anObject parameters: params ! blox: canvas blox := canvas ! properties ^properties ! destroyed name := nil ! integerAt: option ^(self at: option) asInteger ! integerAt: option put: value ^self at: option put: value asInteger printString ! makePoint: pointOrArray (pointOrArray respondsTo: #do:) ifFalse: [ ^pointOrArray ]. ^(pointOrArray at: 1) @ (pointOrArray at: 2) ! numberAt: option ^(self at: option) asNumber asFloat ! numberAt: option put: value ^self at: option put: value asFloat printString ! ! !BCanvasObject methodsFor: 'private - abstract'! checkValidity ^true ! initializeWithProperties: aDictionary properties := aDictionary. ! itemType self subclassResponsibility ! points self subclassResponsibility ! ! "----------------------- Bounded item ----------------------------------" BCanvasObject subclass: #BBoundingBox instanceVariableNames: 'points' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BBoundingBox comment: ' I am the ultimate ancestor of all items that you can put in a BCanvas and which are well defined by their bounding box - i.e. everything except BPolylines and BSplines.'! !BBoundingBox methodsFor: 'accessing'! boundingBox ^Rectangle origin: self origin corner: self corner ! center ^(self origin + self corner) / 2 ! center: center extent: extent self origin: center extent: extent; moveBy: (self makePoint: extent) / -2 ! corner ^self makePoint: (points at: 2) ! corner: pointOrArray points at: 2 put: pointOrArray ! extent ^self corner - self origin ! extent: pointOrArray self corner: self origin + (self makePoint: pointOrArray) ! moveBy: pointOrArray | point | point := self makePoint: pointOrArray. self origin: self origin + point corner: self corner + point ! origin ^self makePoint: (points at: 1) ! origin: pointOrArray points at: 1 put: pointOrArray ! origin: originPointOrArray corner: cornerPointOrArray points at: 1 put: originPointOrArray; at: 2 put: cornerPointOrArray ! origin: originPointOrArray extent: extentPointOrArray points at: 1 put: originPointOrArray; at: 2 put: self origin + (self makePoint: extentPointOrArray) ! ! !BBoundingBox methodsFor: 'private'! checkValidity ^self points allSatisfy: [ :each | each notNil ] ! initializeWithProperties: aDictionary super initializeWithProperties: aDictionary. points := Array new: 2 ! points ^points ! ! "------------------------- Line item ----------------------------------" BBoundingBox subclass: #BLine instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BLine comment: ' I only draw straight lines but I can do that very well, even without a ruler...'! !BLine methodsFor: 'accessing'! cap ^self at: #capstyle ! cap: aSymbol "Can be butt (default), projecting, or round" self at: #capstyle put: aSymbol ! width ^self integerAt: #width ! width: pixels ^self integerAt: #width put: pixels ! ! !BLine methodsFor: 'private'! itemType ^'line' ! ! "----------------------- Rectangle item -------------------------------" BBoundingBox subclass: #BRectangle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BRectangle comment: ' I only draw rectangles but I can do that very well.'! !BRectangle methodsFor: 'accessing'! outlineColor ^self at: #outline ! outlineColor: color ^self at: #outline put: color ! width ^self integerAt: #width ! width: pixels ^self integerAt: #width put: pixels ! ! !BRectangle methodsFor: 'private'! itemType ^'rectangle' ! ! "------------------------- Oval item ----------------------------------" BRectangle subclass: #BOval instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BOval comment: ' I can draw ovals (ok, if you''re a mathematic, they''re really ellipses), or even circles.'! !BOval methodsFor: 'private'! itemType ^'oval' ! ! "-------------------------- Arc item ----------------------------------" BOval subclass: #BArc instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BArc comment: ' I can draw arcs, pie slices (don''t eat them!!), chords, and... nothing more.'! !BArc methodsFor: 'accessing'! endAngle ^self startAngle + self sweepAngle ! endAngle: angle ^self sweepAngle: angle - self startAngle ! fillChord self at: #style put: 'chord' ! fillSlice self at: #style put: 'pieslice' ! startAngle ^self integerAt: #start ! startAngle: angle self integerAt: #start put: angle ! sweepAngle ^self integerAt: #extent ! sweepAngle: angle self integerAt: #extent put: angle ! from: start to: end self from: start; to: end ! from | startAngle | startAngle := self startAngle degreesToRadians. ^self extent * (startAngle cos @ startAngle sin) / 2 + self center ! from: aPoint self startAngle: (aPoint - self center / self extent) arcTan radiansToDegrees ! to | endAngle | endAngle := self endAngle degreesToRadians. ^self extent * (endAngle cos @ endAngle sin) / 2 + self center ! to: aPoint self endAngle: (aPoint - self center / self extent) arcTan radiansToDegrees ! ! !BArc methodsFor: 'private'! initializeWithProperties: aDictionary super initializeWithProperties: aDictionary. self properties at: #style ifAbsentPut: [ 'arc' ] ! itemType ^'arc' ! ! "----------------------- Polyline item --------------------------------" BCanvasObject subclass: #BPolyline instanceVariableNames: 'closed points boundingBox' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BPolyline comment: ' I can draw closed or open polylines, and even fill them!'! !BPolyline methodsFor: 'accessing'! boundingBox ^boundingBox ! cap self closed == true ifTrue: [ self error: 'can''t set cap style for closed polylines' ]. ^self at: #capstyle ! cap: aSymbol "Can be butt (default), projecting, or round" self closed == true ifTrue: [ self error: 'can''t set cap style for closed polylines' ]. ^self at: #capstyle put: aSymbol ! closed ^closed ! closed: aBoolean "Default is 'not closed' " self closed isNil ifFalse: [ self error: 'you can set the closed style only once' ]. closed := aBoolean. ! join self closed == true ifTrue: [ self error: 'can''t set join style for closed polylines' ]. ^self at: #joinstyle ! join: aSymbol "Can be bevel, miter (default), or round" self closed == true ifTrue: [ self error: 'can''t set join style for closed polylines' ]. ^self at: #joinstyle put: aSymbol ! outlineColor self closed == true ifFalse: [ self error: 'outline color not defined for open polylines' ]. ^self at: #outline ! outlineColor: color self closed == true ifFalse: [ self error: 'outline color not defined for open polylines' ]. ^self at: #outline put: color ! points ^points ! points: arrayOfPointsOrArrays points := arrayOfPointsOrArrays collect: [ :each | self makePoint: each ]. boundingBox := Rectangle origin: points anyOne copy corner: points anyOne copy. points do: [ :each | boundingBox left: (boundingBox left min: each x); top: (boundingBox top min: each y); right: (boundingBox right max: each x); bottom: (boundingBox bottom max: each y) ] ! width ^self integerAt: #width ! width: pixels ^self integerAt: #width put: pixels ! ! !BPolyline methodsFor: 'private'! checkValidity ^points notNil ! itemType self closed isNil ifTrue: [ self closed: false ]. ^self closed ifTrue: [ 'polygon' ] ifFalse: [ 'line' ] ! ! "----------------------- Spline item ----------------------------------" BPolyline subclass: #BSpline instanceVariableNames: 'smoothness' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BSpline comment: ' Unlike my father BPolyline, I am more smooth at doing my job.'! !BSpline methodsFor: 'accessing'! smoothness ^self integerAt: #splinesteps ! smoothness: anInteger ^self integerAt: #splinesteps put: anInteger ! ! !BSpline methodsFor: 'private'! initializeWithProperties: aDictionary super initializeWithProperties: aDictionary. self at: #smooth put: '1' ! ! "----------------------- Text item ------------------------------------" BBoundingBox subclass: #BEmbeddedText instanceVariableNames: 'anchor' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BEmbeddedText comment: ' I can draw text in all sorts of colors, sizes and fonts.'! !BEmbeddedText methodsFor: 'accessing'! font ^self at: #font ! font: font ^self at: #font put: font ! justify ^self at: #justify ! justify: aSymbol "Can be left, right, or center (default)" aSymbol == #left ifTrue: [ self at: #anchor put: 'w'. anchor := #leftCenter ]. aSymbol == #right ifTrue: [ self at: #anchor put: 'e'. anchor := #rightCenter ]. aSymbol == #center ifTrue: [ self at: #anchor put: 'center'. anchor := #center ]. ^self at: #justify put: aSymbol ! text ^self at: #text ! text: aString ^self at: #text put: aString ! redraw self at: #width put: (self corner x - self origin x) abs asInteger printString super redraw. ! points | anchorPoint | anchor isNil ifTrue: [ anchor := #center ]. anchorPoint := self boundingBox perform: anchor. ^Array with: anchorPoint ! ! !BEmbeddedText methodsFor: 'private'! itemType ^'text' ! postCopy "Set the anchor variable" self justify: self justify. ! ! "----------------------- Image item -----------------------------------" BBoundingBox subclass: #BEmbeddedImage instanceVariableNames: 'data shared' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BEmbeddedImage comment: ' I can draw a colorful image inside the canvas.'! !BEmbeddedImage methodsFor: 'accessing'! create self at: #anchor put: 'center'. self drawImage. super create ! data ^data ! copyInto: aBlox shared value: shared + 1. ^(super copyInto: aBlox) refCount: shared sharedData: data; yourself ! data: aString (shared isNil or: [ shared value > 1 ]) ifTrue: [ self decRefCount. shared := ValueHolder value: 1. self blox tclEval: 'image create photo'. self at: #image put: self tclResult. ]. data := aString ! redraw self drawImage. super redraw. ! points ^Array with: self boundingBox center ! ! !BEmbeddedImage methodsFor: 'private'! refCount: rc sharedData: dataString data := dataString. shared := rc. ! decRefCount shared value: shared - 1. shared value = 0 ifTrue: [ self blox tclEval: 'image delete ', (self at: #image) ]. ! destroyed self decRefCount. super destroyed. ! drawImage shared isNil ifTrue: [ ^self ]. self blox tclEval: (self at: #image), ' blank'. data isNil ifTrue: [ ^self ]. self blox tclEval: (self at: #image), ' configure -data ', data asTkImageString ! itemType ^'image' ! !