"======================================================================
|
|   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'
! !
