"======================================================================
|
|   Smalltalk Tk-based GUI building blocks (canvas widget).
|
|
 ======================================================================"


"======================================================================
|
| Copyright 1999,2000,2001,2002,2003,2004 Free Software Foundation, Inc.
| 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 02110-1301, USA.  
|
 ======================================================================"


BViewport subclass:  #BCanvas
	instanceVariableNames: 'items boundingBox '
	classVariableNames: 'Initialized '
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BCanvas subclass:  #BScrolledCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BEventTarget subclass:  #BCanvasObject
	instanceVariableNames: 'blox name properties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BCanvasObject subclass:  #BBoundingBox
	instanceVariableNames: 'points '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BBoundingBox subclass:  #BLine
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BBoundingBox subclass:  #BRectangle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BRectangle subclass:  #BOval
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BOval subclass:  #BArc
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BCanvasObject subclass:  #BPolyline
	instanceVariableNames: 'closed points boundingBox '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BPolyline subclass:  #BSpline
	instanceVariableNames: 'smoothness '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BBoundingBox subclass:  #BEmbeddedText
	instanceVariableNames: 'anchor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

BBoundingBox subclass:  #BEmbeddedImage
	instanceVariableNames: 'imageChanged data shared '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Windows'!

"-------------------------- BCanvas class -----------------------------"

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 class methodsFor: 'private'!

initializeOnStartup
    Initialized := false
! !

!BCanvas methodsFor: 'accessing'!

backgroundColor
    "Answer the value of the backgroundColor option for the widget.

     Specifies the normal background color to use when displaying the widget."
    self properties at: #background ifPresent: [ :value | ^value ].
    self tclEval: '%1 cget -background'
	with: self connected
	with: self container.
    ^self properties at: #background put: (self tclResult )!

backgroundColor: value
    "Set the value of the backgroundColor option for the widget.

     Specifies the normal background color to use when displaying the widget."
    self tclEval: '%1 configure -background %3'
	with: self connected
	with: self container
	with: (value  asTkString).
    self properties at: #background put: value!

foregroundColor
    "Answer the value of the foregroundColor option for the widget.

     Specifies the normal foreground color to use when displaying the widget."
    self properties at: #foreground ifPresent: [ :value | ^value ].
    self tclEval: '%1 cget -foreground'
	with: self connected
	with: self container.
    ^self properties at: #foreground put: (self tclResult )!

foregroundColor: value
    "Set the value of the foregroundColor option for the widget.

     Specifies the normal foreground color to use when displaying the widget."
    self tclEval: '%1 configure -foreground %3'
	with: self connected
	with: self container
	with: (value  asTkString).
    self properties at: #foreground put: value! !

!BCanvas methodsFor: 'private - BCanvasObject protocol'!

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.
!

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
!

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
! !

!BCanvas methodsFor: 'geometry management'!

addChild: child
    "The widget identified by child has been added to the receiver.
     This method is public not because you can call it, but because
     it can be useful to override it, not forgetting the call to
     either the superclass implementation or #basicAddChild:, to
     perform some initialization on the children just added. Answer
     the new 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
!

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
    "Offset the given child's height by value pixels."
    self child: child height: (self heightChild: child) + value!

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
    "Offset the given child's width by value pixels."
    self child: child width: (self widthChild: child) + value!

child: child x: value
    "Set the given child's top-left corner's x coordinate, in pixels
     in the canvas' coordinate system."
    | 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
    "Offset the given child's top-left x by value pixels."
    self child: child x: (self xChild: child) + value!

child: child y: value
    "Set the given child's top-left corner's y coordinate, in pixels
     in the canvas' coordinate system."
    | 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
    "Offset the given child's top-left y by value pixels."
    self child: child y: (self yChild: child) + value!

heightChild: child
    "Answer the given child's height in pixels."
    ^child heightAbsolute!

widthChild: child
    "Answer the given child's width in pixels."
    ^child widthAbsolute!

xChild: child
    "Answer the given child's top-left corner's x coordinate, in pixels
     in the canvas' coordinate system."
    ^(child properties at: #xyGeom ifAbsentPut: [ Point new ]) x!

yChild: child
    "Answer the given child's top-left corner's y coordinate, in pixels
     in the canvas' coordinate system."
    ^(child properties at: #xyGeom ifAbsentPut: [ Point new ]) y! !

!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: 'widget protocol'!

at: aPoint
    "Selects the topmost item in the canvas overlapping
     the point given by 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
    "Evaluate aBlock for each item whose bounding box intersects the
     rectangle between the two Points, origin and corner.  Pass the
     item to the block."
    | r |
    r := Rectangle origin: origin corner: corner.
    items copy do: [ :each |
	(each boundingBox intersects: r)
	    ifTrue: [ aBlock value: each ]
    ]
!

boundingBox
    "Answer the bounding box of all the items in the canvas"
    ^boundingBox
!

destroyed
    "The widget has been destroyed.  Tell all of its items about this
     fact."
    items do: [ :each |
	(each isKindOf: BCanvasObject) ifTrue: [ each destroyed ]
    ]
!

do: aBlock
    "Evaluate aBlock, passing each item to it."
    items do: aBlock
!

empty
    "Remove all the items from the canvas, leaving it empty"
    items copy do: [ :each | each remove ]
!

extraSpace
    "Answer the amount of space that is left as a border around the
     canvas items."
    ^self properties at: #extraSpace ifAbsentPut: [ Point new ]
!

extraSpace: aPoint
    "Set the amount of space that is left as a border around the
     canvas items."
    self properties at: #extraSpace put: aPoint
!

items
    "Answer an Array containing all the items in the canvas"
    ^items copy
!

mapPoint: aPoint
    "Given aPoint, a point expressed in window coordinates, answer the
     corresponding canvas coordinates that are displayed at that location."
    | 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
! !



"-------------------------- BScrolledCanvas class -----------------------------"

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
! !



"-------------------------- BCanvasObject class -----------------------------"

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
    "Answer a new instance of the receiver, displayed into the given
     parentCanvas."
    ^self basicNew
	blox: parentCanvas;
	initializeWithProperties: IdentityDictionary new
! !

!BCanvasObject methodsFor: 'accessing'!

blox
    "Answer the parent canvas of the receiver"
    ^blox
!

boundingBox
    "Answer a Rectangle enclosing all of the receiver"
    self subclassResponsibility
!

color
    "Answer the color to be used to fill this item's area."
    ^self at: #fill
!

color: color
    "Set the color to be used to fill this item's area."
    ^self at: #fill put: color
!

copyInto: newCanvas
    "Answer a new BCanvasObject identical to this but displayed
     into another canvas, newCanvas.  The new instance is not
     created at the time it is returned."
    ^self species basicNew
	blox: newCanvas;
	initializeWithProperties: self properties copy;
	points: self points;
	postCopy;
	yourself
!

copyObject
    "Answer a new BCanvasObject identical to this.  Unlike #copy,
     which merely creates a new Smalltalk object with the same data
     and referring to the same canvas item, the object created
     with #copyObject is physically distinct from the original.
     The new instance is not created at the time it is returned."
    ^self copyInto: self blox
!

createCopy
    "Answer a new BCanvasObject identical to this.  Unlike #copy,
     which merely creates a new Smalltalk object with the same data
     and referring to the same canvas item, the object created
     with #copyObject is physically distinct from the original.
     The new instance has already been created at the time it is
     returned."
    ^self copyObject
	create;
	yourself
!

createCopyInto: newCanvas
    "Answer a new BCanvasObject identical to this but displayed
     into another canvas, newCanvas.  The new instance has already
     been created at the time it is returned."
    ^(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
!

grayOut
    "Apply a 50% gray stippling pattern to the object"
    self at: #stipple put: 'gray50'
!

shallowCopy
    "It does not make sense to make a copy, because it would
     make data inconsistent across different objects; so answer
     the receiver"
    ^self
! !

!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
!

blox: canvas
    blox := canvas
!

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)
!

name
    "Answer the name given to the object"
    ^name
!

numberAt: option
     ^(self at: option) asNumber asFloat
!

numberAt: option put: value
     ^self at: option put: value asFloat printString
!

primBind: event to: aSymbol of: anObject parameters: params
    ^self blox
	item: self name
	bind: event
	to: aSymbol
	of: anObject
	parameters: params
!

properties
    ^properties
! !

!BCanvasObject methodsFor: 'widget protocol'!

create
    "If the object has not been created yet and has been initialized
     correctly, insert it for real in the parent canvas"
    self created ifTrue: [
	self error: 'object already created'
    ].
    self checkValidity ifFalse: [
	self error: 'please initialize the object correctly'
    ].
    name := self blox itemCreate: self
!

created
    "Answer whether the object is just a placeholder or has already
     been inserted for real in the parent canvas"
    ^self name notNil
!

lower
    "Move the item to the lowest position in the display list.
     Child widgets always obscure other item types, and the stacking
     order of window items is determined by sending methods to the
     widget object directly."

    self blox lower: self name
!

raise
    "Move the item to the highest position in the display list.
     Child widgets always obscure other item types, and the stacking
     order of window items is determined by sending methods to the
     widget object directly."

    self blox raise: self name
!

redraw
    "Force the object to be displayed in the parent canvas, creating
     it if it has not been inserted for real in the parent, and refresh
     its position if it has changed."
    self created
	ifTrue: [ self blox item: self name points: self points ]
	ifFalse: [ self create ]
!

remove
    "Remove the object from the canvas"
    self blox remove: self name.
!

show
    "Ensure that the object is visible in the center of the canvas,
     scrolling it if necessary."
    self blox show: self name
! !

!BCanvasObject methodsFor: 'private - abstract'!

checkValidity
    ^true
!

initializeWithProperties: aDictionary
    properties := aDictionary.
!

itemType
    self subclassResponsibility
!

points
    self subclassResponsibility
! !



"-------------------------- BBoundingBox class -----------------------------"

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
    "Answer a Rectangle enclosing all of the receiver"
    ^Rectangle
	origin: self origin
	corner: self corner
!

center
    "Answer the center point of the receiver"
    ^(self origin + self corner) / 2
!

center: center extent: extent
    "Move the object so that it is centered around the center Point and
     its size is given by the extent Point.  No changes take place
     until you invoke the #create (if the object has not been inserted
     in the canvas yet) or the #redraw method."
    self
	origin: center - ((self makePoint: extent) / 2)
	extent: extent
!

corner
    "Answer the Point specifying the lower-right corner of the receiver"
    ^self makePoint: (points at: 2)
!

corner: pointOrArray
    "Set the Point specifying the lower-right corner of the receiver;
     pointOrArray can be a Point or a two-item Array.  No changes take place
     until you invoke the #create (if the object has not been inserted
     in the canvas yet) or the #redraw method."
    points at: 2 put: pointOrArray
!

extent
    "Answer a Point specifying the size of the receiver"
    ^self corner - self origin
!

extent: pointOrArray
    "Set the Point specifying the size of the receiver;
     pointOrArray can be a Point or a two-item Array.  No changes take place
     until you invoke the #create (if the object has not been inserted
     in the canvas yet) or the #redraw method."
    self corner: self origin + (self makePoint: pointOrArray)
!

moveBy: pointOrArray
    "Move the object by the amount indicated by pointOrArray: that is,
     its whole bounding box is shifted by that amount.  No changes take place
     until you invoke the #create (if the object has not been inserted
     in the canvas yet) or the #redraw method."
    | point |
    point := self makePoint: pointOrArray.
    self
	origin: self origin + point
	corner: self corner + point
!

origin
    "Answer the Point specifying the top-left corner of the receiver"
    ^self makePoint: (points at: 1)
!

origin: pointOrArray
    "Set the Point specifying the top-left corner of the receiver;
     pointOrArray can be a Point or a two-item Array.  No changes take place
     until you invoke the #create (if the object has not been inserted
     in the canvas yet) or the #redraw method."
    points at: 1 put: pointOrArray
!

origin: originPointOrArray corner: cornerPointOrArray
    "Set the bounding box of the object, based on a Point specifying the
     top-left corner of the receiver and another specifying the bottom-right
     corner; the two parameters can both be Points or two-item Arrays.
     No changes take place until you invoke the #create (if the object has
     not been inserted in the canvas yet) or the #redraw method."
    points
	at: 1 put: originPointOrArray;
	at: 2 put: cornerPointOrArray
!

origin: originPointOrArray extent: extentPointOrArray
    "Set the bounding box of the object, based on a Point specifying the
     top-left corner of the receiver and another specifying its size;
     the two parameters can both be Points or two-item Arrays.
     No changes take place until you invoke the #create (if the object has
     not been inserted in the canvas yet) or the #redraw method."
    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
! !



"-------------------------- BLine class -----------------------------"

BLine comment: 
'I only draw straight lines but I can do that very well, even without
a ruler...'!

!BLine methodsFor: 'accessing'!

cap
    "Answer the way in which caps are to be drawn at the endpoints
     of the line.  The answer may be #butt (the default), #projecting, or
     #round)."
    ^self at: #capstyle
!

cap: aSymbol
    "Set the way in which caps are to be drawn at the endpoints
     of the line.  aSymbol may be #butt (the default), #projecting, or
     #round)."
    self at: #capstyle put: aSymbol
!

width
    "Answer the width with which the line is drawn."
    ^self integerAt: #width
!

width: pixels
    "Set the width with which the line is drawn."
    ^self integerAt: #width put: pixels
! !

!BLine methodsFor: 'private'!

itemType
    ^'line'
! !



"-------------------------- BRectangle class -----------------------------"

BRectangle comment: 
'
I only draw rectangles but I can do that very well.'!

!BRectangle methodsFor: 'accessing'!

outlineColor
    "Answer the color with which the outline of the rectangle is drawn."
    ^self at: #outline
!

outlineColor: color
    "Set the color with which the outline of the rectangle is drawn."
    ^self at: #outline put: color
!

width
    "Answer the width with which the outline of the rectangle is drawn."
    ^self integerAt: #width
!

width: pixels
    "Set the width with which the outline of the rectangle is drawn."
    ^self integerAt: #width put: pixels
! !

!BRectangle methodsFor: 'private'!

itemType
    ^'rectangle'
! !



"-------------------------- BOval class -----------------------------"

BOval comment: 
'
I can draw ovals (ok, if you''re a mathematic, they''re really ellipses),
or even circles.'!

!BOval methodsFor: 'private'!

itemType
    ^'oval'
! !



"-------------------------- BArc class -----------------------------"

BArc comment: 
'
I can draw arcs, pie slices (don''t eat them!!), chords, and... nothing more.'!

!BArc methodsFor: 'accessing'!

endAngle
    "Answer the ending of the angular range that is occupied by the arc,
     expressed in degrees"
    ^self startAngle + self sweepAngle
!

endAngle: angle
    "Set the ending of the angular range that is occupied by the arc,
     expressed in degrees"
    ^self sweepAngle: angle - self startAngle
!

fillChord
    "Specify that the arc will be filled by painting an area delimited
     by the arc and the chord that joins the arc's endpoints."
    self at: #style put: 'chord'
!

fillSlice
    "Specify that the arc will be filled by painting an area delimited
     by the arc and the two radii joins the center of the arc with
     each of the endpoints (that is, that a pie slice will be drawn)."
    self at: #style put: 'pieslice'
!

from
    "Answer the starting point of the arc in cartesian coordinates"
    | startAngle |
    startAngle := self startAngle degreesToRadians.
    ^self extent * (startAngle cos @ startAngle sin) / 2 + self center
!

from: aPoint
    "Set the starting point of the arc in cartesian coordinates"
    self startAngle:
	(aPoint - self center / self extent) arcTan radiansToDegrees
!

from: start to: end
    "Set the two starting points of the arc in cartesian coordinates"
    self from: start; to: end
!

startAngle
    "Answer the beginning of the angular range that is occupied by the arc,
     expressed in degrees"
    ^self integerAt: #start
!

startAngle: angle
    "Set the beginning of the angular range that is occupied by the arc,
     expressed in degrees"
    self integerAt: #start put: angle
!

sweepAngle
    "Answer the size of the angular range that is occupied by the arc,
     expressed in degrees"
    ^self integerAt: #extent
!

sweepAngle: angle
    "Set the size of the angular range that is occupied by the arc,
     expressed in degrees"
    self integerAt: #extent put: angle
!

to
    "Answer the ending point of the arc in cartesian coordinates"
    | endAngle |
    endAngle := self endAngle degreesToRadians.
    ^self extent * (endAngle cos @ endAngle sin) / 2 + self center
!

to: aPoint
    "Set the ending point of the arc in cartesian coordinates"
    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'
! !



"-------------------------- BPolyline class -----------------------------"

BPolyline comment: 
'
I can draw closed or open polylines, and even fill them!'!

!BPolyline methodsFor: 'accessing'!

boundingBox
    ^boundingBox
!

cap
    "Answer the way in which caps are to be drawn at the endpoints
     of the line.

     This option is only available for open polylines.  If you want to
     set it for a closed polylines, draw an open one on top of it."
    self closed == true
	ifTrue: [ self error: 'can''t set cap style for closed polylines' ].
    ^self at: #capstyle
!

cap: aSymbol
    "Set the way in which caps are to be drawn at the endpoints
     of the line.  aSymbol may be #butt (the default), #projecting, or
     #round).

     This option is only available for open polylines.  If you want to
     set it for a closed polylines, draw an open one on top of it."
    self closed == true
	ifTrue: [ self error: 'can''t set cap style for closed polylines' ].
    ^self at: #capstyle put: aSymbol
!

closed
    "Answer whether the polyline is an open or a closed one."
    ^closed
!

closed: aBoolean
    "Set whether the polyline is an open or a closed one.  This option
     may be set only once."
    self closed isNil
	ifFalse: [ self error: 'you can set the closed style only once' ].

    closed := aBoolean.
!

join
    "Answer the way in which joints are to be drawn at the vertices of the
     line.

     This option is only available for open polylines.  If you want to
     set it for a closed polylines, draw an open one on top of it."
    self closed == true
	ifTrue: [ self error: 'can''t set join style for closed polylines' ].
    ^self at: #joinstyle
!

join: aSymbol
    "Answer the way in which joints are to be drawn at the vertices of the
     line.  aSymbol can be #bevel, #miter (the default) or #round.

     This option is only available for open polylines.  If you want to
     set it for a closed polylines, draw an open one on top of it."

    self closed == true
	ifTrue: [ self error: 'can''t set join style for closed polylines' ].
    ^self at: #joinstyle put: aSymbol
!

outlineColor
    "Answer the color with which the outline of the polyline is drawn.
     This option is only available for closed polylines."
    self closed == true
	ifFalse: [ self error: 'outline color not defined for open polylines' ].
    ^self at: #outline
!

outlineColor: color
    "Set the color with which the outline of the polyline is drawn.
     This option is only available for closed polylines."
    self closed == true
	ifFalse: [ self error: 'outline color not defined for open polylines' ].
    ^self at: #outline put: color
!

points
    "Answer the points that are vertices of the polyline."
    ^points
!

points: arrayOfPointsOrArrays
    "Set the points that are vertices of the polyline.  Each of the items
     of arrayOfPointsOrArrays can be a Point or a two-element Array.
     Note that no changes take place until you invoke the #create (if
     the object has not been inserted in the canvas yet) or the #redraw
     method."
    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
    "Answer the width with which the polyline (or its outline
     if it is a closed one) is drawn."
    ^self integerAt: #width
!

width: pixels
    "Set the width with which the polyline (or its outline
     if it is a closed one) is drawn."
    ^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' ]
! !



"-------------------------- BSpline class -----------------------------"

BSpline comment: 
'
Unlike my father BPolyline, I am more smooth at doing my job.'!

!BSpline methodsFor: 'accessing'!

smoothness
    "Answer the degree of smoothness desired for curves.  Each spline
     will be approximated with this number of line segments."
    ^self integerAt: #splinesteps
!

smoothness: anInteger
    "Set the degree of smoothness desired for curves.  Each spline
     will be approximated with this number of line segments."
    ^self integerAt: #splinesteps put: anInteger
! !

!BSpline methodsFor: 'private'!

initializeWithProperties: aDictionary
    super initializeWithProperties: aDictionary.
    self at: #smooth put: '1'
! !



"-------------------------- BEmbeddedText class -----------------------------"

BEmbeddedText comment: 
'
I can draw text in all sorts of colors, sizes and fonts.'!

!BEmbeddedText methodsFor: 'accessing'!

font
    "Answer the value of the font option for the canvas object.

     Specifies the font to use when drawing text inside the widget. The font
     can be given as either an X font name or a Blox font description string.

     X font names are given as many fields, each led by a minus, and each of
     which can be replaced by an * to indicate a default value is ok: 
     foundry, family, weight, slant, setwidth, addstyle, pixel size, point size
     (the same as pixel size for historical reasons), horizontal resolution,
     vertical resolution, spacing, width, charset and character encoding.

     Blox font description strings have three fields, which must be separated by
     a space and of which only the first is mandatory: the font family, the font
     size in points (or in pixels if a negative value is supplied), and a number
     of styles separated by a space (valid styles are normal, bold, italic,
     underline and overstrike). Examples of valid fonts are ``Helvetica 10 Bold'',
     ``Times -14'', ``Futura Bold Underline''.  You must enclose the font family
     in braces if it is made of two or more words."
    ^self at: #font
!

font: font
    "Set the value of the font option for the canvas object.

     Specifies the font to use when drawing text inside the widget. The font
     can be given as either an X font name or a Blox font description string.

     X font names are given as many fields, each led by a minus, and each of
     which can be replaced by an * to indicate a default value is ok: 
     foundry, family, weight, slant, setwidth, addstyle, pixel size, point size
     (the same as pixel size for historical reasons), horizontal resolution,
     vertical resolution, spacing, width, charset and character encoding.

     Blox font description strings have three fields, which must be separated by
     a space and of which only the first is mandatory: the font family, the font
     size in points (or in pixels if a negative value is supplied), and a number
     of styles separated by a space (valid styles are normal, bold, italic,
     underline and overstrike). Examples of valid fonts are ``Helvetica 10 Bold'',
     ``Times -14'', ``Futura Bold Underline''.  You must enclose the font family
     in braces if it is made of two or more words."
    ^self at: #font put: font
!

justify
    "Answer how to justify the text within its bounding region."
    ^self at: #justify
!

justify: aSymbol
    "Sets how to justify the text within its bounding region.  Can be
     #left, #right or #center (the 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.
    self redraw.
    ^aSymbol
!

redraw
    "Force the object to be displayed in the parent canvas, creating
     it if it has not been inserted for real in the parent, and refresh
     its position."

    self
	at: #width
	put: (self corner x - self origin x) abs asInteger printString.
    super redraw.
!

text
    "Answer the text that is printed by the object"
    ^self at: #text
!

text: aString
    "Set the text that is printed by the object"
    ^self at: #text put: aString
! !

!BEmbeddedText methodsFor: 'private'!

itemType
    ^'text'
!

points
    "Answer a single point around which the text is positioned.  Vertically,
     the text is centered on the point.  Horizontally, the point can give the
     leftmost, rightmost or center coordinate depending on the setting of #justify."
    | anchorPoint |
    anchor isNil ifTrue: [ anchor := #center ].
    anchorPoint := self boundingBox perform: anchor.
    ^Array with: anchorPoint
!

postCopy
    "Set the anchor variable"
    self justify: self justify.
! !



"-------------------------- BEmbeddedImage class -----------------------------"

BEmbeddedImage comment: 
'I can draw a colorful image inside the canvas.'!

!BEmbeddedImage methodsFor: 'accessing'!

copyInto: aBlox
    "Answer a new BCanvasObject identical to this but displayed
     into another canvas, newCanvas.  The new instance is not
     created at the time it is returned."
    shared value: shared + 1.
    ^(super copyInto: aBlox)
	refCount: shared sharedData: data;
	yourself
!

create
    "If the object has not been created yet and has been initialized
     correctly, insert it for real in the parent canvas"
    self at: #anchor put: 'center'.
    self drawImage.
    super create
!

data
    "Answer the data of the image.  The result will be a String containing
     image data either as Base-64 encoded GIF data, as XPM data, or as PPM data."
    ^data
!

data: aString
    "Set the data of the image.  aString may contain the data either
     as Base-64 encoded GIF data, as XPM data, or as PPM data.  No changes
     are visible until you toggle a redraw using the appropriate method."
    (shared isNil or: [ shared value > 1 ]) ifTrue: [
	self decRefCount.
	shared := ValueHolder with: 1.
	self blox tclEval: 'image create photo'.
	self at: #image put: self blox tclResult.
    ].
    data := aString.
    imageChanged := true.
!

redraw
    "Force the object to be displayed in the parent canvas, creating
     it if it has not been inserted for real in the parent, and refresh
     its position and image data if it has changed."
    imageChanged ifTrue: [ self drawImage ].
    super redraw.
! !

!BEmbeddedImage methodsFor: 'private'!

create
    imageChanged := true.
    super create
!

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 ].

    imageChanged := false.
    self blox tclEval: (self at: #image), ' configure -data ',
	data asTkImageString
!

itemType
    ^'image'
!

points
    ^Array with: self boundingBox center
!

refCount: rc sharedData: dataString 
    data := dataString.
    shared := rc.
! !
