Object subclass: Visual [
    paint: context [
        ^ self subclassResponsibility
    ]

    bounds [
        ^ self subclassResponsibility
    ]

    invalidate [
        ^ self broadcast: #notifyDamage: with: self bounds.
    ]
]

Visual subclass: FilledRectangle [
    | rect |

    extent: aRect [
        rect := aRect.
        self invalidate.
        ^ self
    ]

    paint: context [
        context newPath.
        context rectangle: rect.
        context setSourceRed: 1.0 green: 1.0 blue: 1.0.
        context fill.
    ]

    bounds [
        ^ rect
    ]

]

Visual subclass: Label [
    | text cachedBounds |

    text: aString [
	text := aString.
	^ self
    ]

    paint: context [
	| extents |
	extents := context textExtents: text.
	cachedBounds := extents bearing corner: extents extent.

	context setSourceRed: 0.5 green: 0.5 blue: 0.5.
	context newPath.
	context rectangle: cachedBounds.
	context stroke.
	context setSourceRed: 1 green: 1 blue: 0.
	context showText: text.
    ]

    bounds [
	^ cachedBounds isNil ifTrue: [ Rectangle new ]
			   ifFalse: [ cachedBounds ]
    ]
]

Object subclass: Transformable [
    | transform |
    
    initialize [
	transform := IdentityTransform new.
        ^ self
    ]
    
    translateBy: distance [ self transform: (transform translateBy: distance) ]
    translateTo: point [ self transform: (transform translateTo: point) ]
    scaleBy: sxsy [ self transform: (transform scaleBy: sxsy) ]
    scaleBy: sxsy about: point [
	self transform: (transform transformBy: ((Scale by: sxsy) about: point))]
    scaleTo: sxsy [ self transform: (transform scaleBy: sxsy) ]
    rotateBy: angle [ self transform: (transform rotateBy: angle) ]
    rotateTo: angle [ self transform: (transform rotateTo: angle) ]
    rotateBy: angle about: point [
	self transform: (transform transformBy: ((Rotate by: angle) about: point))]

    transform [ ^ transform ]
    transform: newTransform [ transform := newTransform ]
]

"
Zorphs.

A zorph is something that can paint itself onto a canvas, and responds
to events.  For convenience we also let zorphs be transformed, and provide
some methods for the damage/rendering/event systems to use."

Transformable subclass: Zorph [
    | visuals cachedLocalBounds |
    
    initialize [ super initialize. ]

    addVisual: visual [
        visuals ifNil: [ visuals := OrderedCollection new ].
        visuals add: visual.
        visual addDependent: self.
        cachedLocalBounds := nil.
        ^ self
    ]

    "Painting"

    paintOn: aContext [
	transform ifNil: [ ^self paintLocal: aContext ]
		  ifNotNil: [ :trans |
		      ^ aContext excursion: [
			  trans accept: aContext.
			  ^ self paintLocal: aContext.
		      ]
		  ].
    ]

    paintLocal: context [
        "Paint, assuming we are in local co-ordinates."
        visuals ifNotNil: [ :visuals | visuals do: [ :visual |
            visual paint: context.
        ]]
    ]

    transform: aTransformation [
	"I set the transform of the zorph.  THis is overridden so that we can
	 notify of damage to the view."
        | oldbounds |
        oldbounds := self bounds.
	super transform: aTransformation.
	"FIXME: we can do better, since the bounds won't necessarily overlap"
        self transformedDamage: (self bounds merge: oldbounds).
    ]
    
    "Bounds"
                
    localBounds [
        "The bounds of the zorph, outside of which it promises
         not to draw, in local coordinates."
        cachedLocalBounds ifNotNil: [ :cached | ^ cached ].
        cachedLocalBounds :=
            visuals ifNil: [ Rectangle new ]
                    ifNotNil: [ :visuals |
                        (visuals collect: [ :each | each bounds]) fold:
                            [ :rect1 :rect2 | rect1 merge: rect2 ]].
        ^ cachedLocalBounds
    ]

    boundsFromLocal: aRect [
        ^ self transform transformBounds: aRect
    ]
    
    bounds [
        ^ self boundsFromLocal: self localBounds
    ]

    "Damage protocol"

    transformedDamage: aRect [
        "Transcript << 'Zorph damage: ' << aRect; nl."
        self broadcast: #notifyDamage: with: aRect.
    ]

    notifyDamage: aRect [
        cachedLocalBounds ifNotNil: [ :cached |
        (cached contains: aRect) ifFalse: [ cachedLocalBounds := nil ]].
        self transformedDamage: (self boundsFromLocal: aRect).
    ]

]

Object subclass: Layer [
    | zorphs |

    addZorph: zorph [
        zorphs ifNil: [ zorphs := OrderedCollection new ].
        zorphs add: zorph.
        zorph addDependent: self.
        ^ self
    ]

    paintOn: context [
        zorphs ifNotNil: [ :zorphs |
            zorphs do: [ :zorph |
                zorph paintOn: context.
            ]].
    ]

    notifyDamage: aRect [
        "Transcript << 'Layer damage: ' << aRect; nl."
        ^ self broadcast: #notifyDamage: with: aRect.
    ]
]

Transformable subclass: Camera [
    | layer |

    initialize [
        ^ super initialize.
    ]
    
    transform: aTransform [
        super transform: aTransform.
        self invalidateView.
    ]

    viewTransform [ ^ self transform ]

    lookAt: aLayer [
        layer ifNotNil: [ :oldlayer | oldlayer removeDependent: self].
        layer := aLayer.
        aLayer addDependent: self.
        self invalidateView.
        ^ self
    ]

    lookingAt [ ^ layer ]

    invalidateView [
        ^ self broadcast: #notifyViewChange.
    ]

    notifyDamage: aRect [
        ^ self broadcast: #notifyDamage:
               with: (self transform transformBounds: aRect)]
]

Transformable subclass: TransformedCamera [
    | innerCamera |

    inner: camera [
        innerCamera isNil ifFalse: [ innerCamera removeDependent: self ].
        innerCamera := camera.
        innerCamera addDependent: self.
        ^ self ]

    viewTransform [ ^ self transform after: innerCamera transform ]
    lookingAt [ ^ innerCamera lookingAt ]

    notifyViewChange [ ^ self broadcast: #notifyViewChange ]
    notifyDamage: aRect [
        ^ self broadcast: #notifyDamage:
               with: (self transform transformBounds: aRect)]                    
]

Visual subclass: Lens [
    | camera rect glass |
    
    initialize [
        glass := Layer new.
        glass addDependent: self.
        ^ self
    ]

    extent: aRect [
        rect := aRect.
        self invalidate.
        ^ self
    ]

    bounds [
        ^ rect
    ]

    camera [
        ^ camera
    ]

    lookThrough: aCamera [
        camera ifNotNil: [ :old | old removeDependent: self ].
        camera := aCamera.
        aCamera addDependent: self.
        self invalidate.
        ^self
    ]

    addToGlass: aZorph [
        
        glass addZorph: aZorph.
        ^ self
    ]

    "Rendering protocol"

    paint: context [
        context excursion: [
            context newPath.
            context rectangle: rect.
	    context setSourceRed: 0 green: 1 blue: 1.
	    context strokePreserve.
	    context setSourceRed: 0 green: 0 blue: 0.
	    context fillPreserve.
            context clip.
            context excursion: [
                camera viewTransform accept: context.
                camera lookingAt paintOn: context].
            glass paintOn: context.]
    ]

    "Damage"

    notifyDamage: aRect [
        | intersection |
        intersection := aRect intersect: self bounds.
        "Transcript << 'Damage through camera: ' << intersection; nl."
        intersection ifNotNil: [ :intersection |
        ^ self broadcast: #notifyDamage:
               with: intersection].
    ]

    notifyViewChange [
        self broadcast: #notifyDamage: with: self bounds.
    ]
]