"
 COPYRIGHT (c) 1992 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

Object subclass:#Cursor
       instanceVariableNames:'shape sourceForm maskForm hotX hotY
			      device cursorId'
       classVariableNames:   'Lobby
			      DefaultFgColor DefaultBgColor

			      NormalCursor HandCursor ArrowCursor
			      WaitCursor CrossHairCursor OriginCursor
			      CornerCursor SquareCursor FourWayCursor
			      UpDownArrowCursor LeftRightArrowCursor
			      ThumbsUpCursor ThumbsDownCursor
			      ReadCursor WriteCursor XeqCursor
			      StopCursor EyeCursor'
       poolDictionaries:''
       category:'Graphics-Support'
!

!Cursor class methodsFor:'documentation'!

copyright
"
 COPYRIGHT (c) 1992 by Claus Gittinger
	      All Rights Reserved

 This software is furnished under a license and may be used
 only in accordance with the terms of that license and with the
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"
!

version
    ^ '$Header: /cvs/stx/stx/libview/Cursor.st,v 1.26 1996-03-06 13:54:46 cg Exp $'
!

documentation
"
    I represents cursors in a device independent manner.
    Normally, cursors are defined at view creation time,
    via 'aView cursor:aCursor'.

    Instance variables:

	shape           <Symbol>        a shape (i.e. #arrow, #hand, ...) or nil
	sourceForm      <Form>          if shape is nil, the source bits
	maskForm        <Form>          if shape is nil, the mask bits
	hotX            <SmallInteger>  if shape is nil, the hotSpot x of the cursor
	hotY            <SmallInteger>  if shape is nil, the hotSpot y of the cursor
	device          <aDevice>       the device, if associated to one
	cursorId        <anObject>      the device-specific id if device is nonNil

    class variables:

	Lobby           <Registry>      keeps track of known device cursors

	DefaultFgColor  <Color>         default foreground color for cursors (usually black)
	DefaultBgColor  <Color>         default background color for cursors (usually white)

	NormalCursor    <Cursor>        cached instance of normal (arrow) cursor
	 ...

"
!

examples
"
    get a standard cursor:

	Cursor wait
	Cursor stop
	Cursor normal

    create a custom cursor:

	Cursor extent:16@16 
	       fromArray:#[ 2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r11111111 2r11111111
			    2r11111111 2r11111111
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r11111111 2r11111111
			    2r11111111 2r11111111
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r11111111 2r11111111
			    2r11111111 2r11111111
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r00000000 2r00000000]
		offset:-8@-8   

    define a cursor for a view:

	|v|

	v := View new.
	v cursor:Cursor stop.
	v open.

      with above custom cursor:

	|v|

	v := View new.
	v cursor:(
	    Cursor extent:16@16 
	       fromArray:#[ 2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r11111111 2r11111111
			    2r11111111 2r11111111
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r11111111 2r11111111
			    2r11111111 2r11111111
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r11111111 2r11111111
			    2r11111111 2r11111111
			    2r00000000 2r00000000
			    2r00000000 2r00000000
			    2r00000000 2r00000000]
		offset:-8@-8).   
	v open.

      with multiple views:

	|v1 v2 top|

	top := StandardSystemView new.
	top extent:300@300.
	v1 := View origin:0.0@0.0 corner:1.0@0.5 in:top.
	v1 viewBackground:(Color grey:75).
	v1 cursor:Cursor thumbsUp.
	v2 := View origin:0.0@0.5 corner:1.0@1.0 in:top.
	v2 viewBackground:(Color white).
	v2 cursor:Cursor wait.
	top open.


    show a cursor in ALL ST/X views for a while:
        
	Cursor wait 
	    showWhile:[
		(Delay forSeconds:5) wait
	    ]


    show a cursor in all views belonging to a windowGroup:
    (have to wait until top is visible to access windowGroup)

	|v1 v2 top|

	top := StandardSystemView new.
	top extent:300@300.
	v1 := View origin:0.0@0.0 corner:1.0@0.5 in:top.
	v1 viewBackground:(Color grey:75).
	v2 := View origin:0.0@0.5 corner:1.0@1.0 in:top.
	v2 viewBackground:(Color white).
	top open.

	[top shown] whileFalse:[Processor yield].

	top windowGroup
	    withCursor:Cursor wait 
	    do:[
		  (Delay forSeconds:10) wait
	       ]


    show a cursor in a single view for a while:

	|v1 v2 top|

	top := StandardSystemView new.
	top extent:300@300.
	v1 := View origin:0.0@0.0 corner:1.0@0.5 in:top.
	v1 viewBackground:(Color grey:75).
	v2 := View origin:0.0@0.5 corner:1.0@1.0 in:top.
	v2 viewBackground:(Color white).
	top open.

	v1 withCursor:Cursor wait 
	   do:[
		  (Delay forSeconds:10) wait
	      ]
"
! !

!Cursor class methodsFor:'initialization'!

initialize
    Lobby isNil ifTrue:[
	Lobby := Registry new.

	"want to be informed when returning from snapshot"
	ObjectMemory addDependent:self
    ]
!

flushDeviceCursors
    "unassign all cursors from their device"

    Lobby notNil ifTrue:[
	Lobby do:[:aCursor |
	    aCursor restored.
	    Lobby registerChange:aCursor
	]
    ]
!

update:something
    "sent when restarted after a snapIn"

    (something == #restarted) ifTrue:[
	self flushDeviceCursors
    ]
! !

!Cursor class methodsFor:'default access'!

defaultFgColor:fgColor defaultBgColor:bgColor
    "set the default colors used for cursors"

    DefaultFgColor := fgColor.
    DefaultBgColor := bgColor
! !

!Cursor class methodsFor:'instance creation'!

extent:extent fromArray:array offset:offset
    "create a new bitmap cursor from bits in the array argument
     - ST-80 compatibility"

    |sourceForm|

    sourceForm := Form extent:extent fromArray:array offset:offset.
    ^ self sourceForm:sourceForm maskForm:sourceForm hotSpot:(offset negated)
!

extent:extent sourceArray:sourceArray maskArray:maskArray offset:offset
    "create a new bitmap cursor with mask from bits in sourceArray and
     maskArray"

    |sourceForm maskForm|

    sourceForm := Form extent:extent fromArray:sourceArray offset:offset.
    maskForm := Form extent:extent fromArray:maskArray offset:offset.
    ^ self sourceForm:sourceForm maskForm:maskForm hotSpot:(offset negated)
!

sourceForm:aForm
    "return a new cursor.
     Source- and mask-Bits are taken from aForm; hotSpot is center"

    ^ self sourceForm:aForm
	     maskForm:aForm
		 hotX:(aForm width // 2)
		 hotY:(aForm height // 2)
!

sourceForm:sourceForm maskForm:maskForm
    "return a new cursor. hotSpot is center"

    ^ self sourceForm:sourceForm
	     maskForm:maskForm
		 hotX:(sourceForm width // 2)
		 hotY:(sourceForm height // 2)
!

sourceForm:sourceForm maskForm:maskForm hotSpot:aPoint
    "return a new cursor"

    ^ self sourceForm:sourceForm
	     maskForm:maskForm
		 hotX:(aPoint x)
		 hotY:(aPoint y)
!

sourceForm:sourceForm maskForm:maskForm hotX:hotX hotY:hotY
    "return a new cursor"

    |newCursor|

    "first look if not already known"
    Lobby isNil ifTrue:[
	self initialize
    ].
    Lobby do:[:aCursor |
	(aCursor sourceForm == sourceForm) ifTrue:[
	    (aCursor maskForm == maskForm) ifTrue:[
		(aCursor hotX == hotX) ifTrue:[
		    (aCursor hotY == hotY) ifTrue:[
			^ aCursor
		    ]
		]
	    ]
	]
    ].
    (sourceForm isNil or:[maskForm isNil]) ifTrue:[^ nil].

    newCursor := self basicNew setSourceForm:sourceForm 
				    maskForm:maskForm
					hotX:hotX
					hotY:hotY.
    Lobby register:newCursor.
    ^ newCursor
!

imageArray:imageBits maskArray:maskBits
    "ST-80 compatible cursor creation - the extent is fixed to 16@16"

    "name is ignored ..."

    ^ self imageArray:imageBits maskArray:maskBits hotSpot:8@8 
!

imageArray:imageBits maskArray:maskBits hotSpot:hot name:aString
    "ST-80 compatible cursor creation - the extent is fixed to 16@16"

    "name is ignored ..."

    ^ self imageArray:imageBits maskArray:maskBits hotSpot:hot
!

imageArray:imageBits maskArray:maskBits hotSpot:hot
    "ST-80 compatible cursor creation - the extent is fixed to 16@16"

    ^ self 
	extent:16@16 
	sourceArray:imageBits
	maskArray:maskBits
	offset:hot negated

    "
     |cursor|

     cursor := Cursor
	imageArray: #(
		2r0000000000000000
		2r0000000100001110
		2r0000000100001110
		2r0000000100001110
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0111111111111110
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000000000000)
	maskArray: #(
		2r0000001110011111
		2r0000001110011111
		2r0000001110011111
		2r0000001110011111
		2r0000001110011111
		2r0000001110000000
		2r1111111111111111
		2r1111111111111111
		2r1111111111111111
		2r0000001110000000
		2r0000001110000000
		2r0000001110000000
		2r0000001110000000
		2r0000001110000000
		2r0000001110000000
		2r0000001110000000)
	hotSpot: 8@8.

    WindowGroup activeGroup 
	withCursor:cursor 
	do:[(Delay forSeconds:10)wait]
    "
!

shape:aShape 
    "return one of the standard cursors.
     Each display may offer different shapes - see for example XWorkstation
     for details (however a basic minimum set should be supported by all)"

    |newCursor|

    "first look if not already known"
    Lobby isNil ifTrue:[
	self initialize
    ].
    Lobby do:[:aCursor |
	(aCursor shape == aShape) ifTrue:[
	    ^ aCursor
	]
    ].
    newCursor := self basicNew setShape:aShape.
    Lobby register:newCursor.
    ^ newCursor
!

shape:aShape on:aDevice
    "return one of the standard cursors already associated to aDevice.
     This is the same as '(Cursor shape:aShape) on:aDevice' but somwehat faster."

    |newCursor oldCursor|

    "first look if not already known"
    Lobby isNil ifTrue:[
	self initialize
    ].
    Lobby do:[:aCursor |
	(aCursor shape == aShape) ifTrue:[
	    (aCursor device == aDevice) ifTrue:[^ aCursor].
	    oldCursor := aCursor
	].
    ].

    "found one with same shape, but different device"
    oldCursor notNil ifTrue:[
	^ oldCursor newOn:aDevice
    ].

    newCursor := self basicNew setShape:aShape.
    Lobby register:newCursor.
    ^ newCursor
!

fileCursorNamed:cursorName
    "return a cursor read from the files 'cursorName_bits.bit' and
     'cursorName_mask.bit' - return nil if file does not exist"

    |cursorBits maskBits|

    cursorBits := Form fromFile:(cursorName , '_bits.bit').
    cursorBits notNil ifTrue:[
	maskBits := Form fromFile:(cursorName , '_mask.bit').
	maskBits notNil ifTrue:[
	    ^ self sourceForm:cursorBits maskForm:maskBits
	]
    ].
    ^ nil
! !

!Cursor class methodsFor:'standard cursors'!

eye 
    "return an eye (i.e. watch) cursor (the default here is a questionMark-cursor)"

    EyeCursor notNil ifTrue:[
	^ EyeCursor
    ].
    ^ self questionMark
!

normal
    "return the normal cursor; an arrow.
     for ST-80 compatibility"

    NormalCursor isNil ifTrue:[
	NormalCursor := self arrow on:Display
    ].
    ^ NormalCursor
!

hand
    "return a hand cursor"

    HandCursor isNil ifTrue:[
	HandCursor := self shape:#upRightHand on:Display
    ].
    ^ HandCursor
!

upRightHand
    "return an up-right-hand cursor"

    ^ self shape:#upRightHand
!

leftHand
    "return a left-hand cursor"

    ^ self shape:#leftHand
!

upDownArrow
    "return an up-down-arrow cursor"

    UpDownArrowCursor isNil ifTrue:[
	UpDownArrowCursor := self shape:#upDownArrow on:Display
    ].
    ^ UpDownArrowCursor
!

leftRightArrow
    "return a left-right-arrow cursor"

    LeftRightArrowCursor isNil ifTrue:[
	LeftRightArrowCursor := self shape:#leftRightArrow on:Display
    ].
    ^ LeftRightArrowCursor
!

upLimitArrow
    "return an up-arrow-to-limit cursor"

    ^ self shape:#upLimitArrow on:Display
!

downLimitArrow
    "return a down-arrow-to-limit cursor"

    ^ self shape:#downLimitArrow on:Display
!

leftLimitArrow
    "return a left-arrow-to-limit cursor"

    ^ self shape:#leftLimitArrow on:Display
!

rightLimitArrowOn
    "return a right-arrow-to-limit cursor"

    ^ self shape:#rightLimitArrow on:Display
!

text
    "return a text-cursor"

    ^ self shape:#text on:Display
!

arrow
    "return an arrow (up-left-arrow) cursor"

    ^ self shape:#upLeftArrow on:Display
!

upLeftArrow
    "return an up-right-arrow cursor"

    ^ self shape:#upLeftArrow on:Display
!

upRightArrow
    "return an up-right-arrow cursor"

    ^ self shape:#upRightArrow on:Display
!

questionMark
    "return a question-mark cursor"

    ^ self shape:#questionMark on:Display
!

cross
    "return a cross cursor"

    ^ self shape:#cross on:Display
!

origin
    "return an origin cursor"

    OriginCursor isNil ifTrue:[
	OriginCursor := self shape:#origin on:Display
    ].
    ^ OriginCursor
!

corner 
    "return a corner cursor"

    CornerCursor isNil ifTrue:[
	CornerCursor := self shape:#corner on:Display
    ].
    ^ CornerCursor
!

topRight 
    "return a top-right corner cursor"

    ^ self shape:#topRight on:Display
!

bottomLeft
    "return a bottom-left corner cursor"

    ^ self shape:#bottomLeft on:Display
!

bottomRight
    "return a bottom-right corner cursor"

    ^ self corner
!

topLeft 
    "return a top-left corner cursor"

    ^ self origin
!

crossHair
    "return a crossHair cursor"

    CrossHairCursor isNil ifTrue:[
	CrossHairCursor := self shape:#crossHair on:Display
    ].
    ^ CrossHairCursor
!

fourWay 
    "return a four-way arrow cursor"

    FourWayCursor isNil ifTrue:[
	FourWayCursor := self shape:#fourWay on:Display
    ].
    ^ FourWayCursor
!

stop
    "return a stop cursor (the default here is a wait-cursor)"

    StopCursor notNil ifTrue:[
	^ StopCursor
    ].
    ^ self wait
!

wait
    "return a wait cursor"

    WaitCursor isNil ifTrue:[
	WaitCursor := self shape:#wait on:Display
    ].
    ^ WaitCursor
!

read
    "return a reading-file cursor (the default here is a wait-cursor)"

    ReadCursor notNil ifTrue:[
	^ ReadCursor
    ].
    ^ self wait
!

write
    "return a writing-file cursor (the default here is a wait-cursor)"

    WriteCursor notNil ifTrue:[
	^ WriteCursor
    ].
    ^ self wait
!

execute
    "return a execute cursor - (the default here is a wait-cursor)"

    XeqCursor notNil ifTrue:[
	^ XeqCursor
    ].
    ^ self wait
!

thumbsUp
    "return a hand cursor - ST-80 compatibility"

    ThumbsUpCursor notNil ifTrue:[
	^ ThumbsUpCursor
    ].
    ^ self hand
!

thumbsDown
    "return a hand cursor - ST-80 compatibility"

    ThumbsDownCursor notNil ifTrue:[
	^ ThumbsDownCursor
    ].
    ^ self hand
! !

!Cursor methodsFor:'copying'!

postCopy
    sourceForm := sourceForm copy.
    maskForm := maskForm copy.
    device := cursorId := nil
! !

!Cursor methodsFor:'instance release'!

shallowCopyForFinalization
    ^ self class basicNew setDevice:device id:cursorId
!

disposed
    "some Cursor has been collected - tell it to the x-server"

    cursorId notNil ifTrue:[
	device destroyCursor:cursorId.
    ]
! !

!Cursor methodsFor:'private accessing'!

setShape:aShapeSymbol
    "set the shape"

    shape := aShapeSymbol.
!

setSourceForm:sForm maskForm:mForm hotX:hx hotY:hy
    "set the forms and hotspot"

    sourceForm := sForm.
    maskForm := mForm.
    hotX := hx.
    hotY := hy.
!

setDevice:aDevice id:anId
    "set the device and deviceId of the receiver"

    device := aDevice.
    cursorId := anId
! !

!Cursor methodsFor:'accessing'!

id
    "return the cursors deviceId"

    ^ cursorId
!

device
    "return the device I am associated with"

    ^ device
!

shape
    "return the shape"

    ^ shape
!

sourceForm
    "return the source-form of the receiver"

    ^ sourceForm
!

sourceForm:aForm
    "set the source-form of the receiver"

    sourceForm := aForm
!

maskForm
    "return the mask-form of the receiver"

    ^ maskForm
!

maskForm:aForm
    "set the mask-form of the receiver"

    maskForm := aForm
!

hotX
    "return the hotspots x-coordinate of the receiver"

    ^ hotX
!

hotY
    "return the hotspots y-coordinate of the receiver"

    ^ hotY
!

foreground:fgColor background:bgColor
    "set the cursor colors"

    device colorCursor:cursorId foreground:fgColor background:bgColor
! !

!Cursor methodsFor:'creating a device cursor'!

on:aDevice
    "create a new Cursor representing the same cursor as
     myself on aDevice; if one already exists, return the one"

    aDevice isNil ifTrue:[
	"this may not happen"
	self error:'nil device'
    ].

    "if I am already assigned to that device ..."
    (device == aDevice) ifTrue:[^ self].

    "first look if not already there"
    Lobby do:[:aCursor |
	(aCursor device == aDevice) ifTrue:[
	    shape notNil ifTrue:[
		(aCursor shape == shape) ifTrue:[
		    ^ aCursor
		]
	    ] ifFalse:[
		(aCursor sourceForm == sourceForm) ifTrue:[
		    (aCursor maskForm == maskForm) ifTrue:[
			(aCursor hotX == hotX) ifTrue:[
			    (aCursor hotY == hotY) ifTrue:[
				^ aCursor
			    ]
			]
		    ]
		]
	    ]
	]
    ].
    ^ self newOn:aDevice
! !

!Cursor methodsFor:'private'!

newOn:aDevice
    "create a new Cursor representing the same cursor as
     myself on aDevice. Dont search the lobby."

    |newCursor id sF mF|

    "ask that device for the cursor"
    shape notNil ifTrue:[
	id := aDevice createCursorShape:shape.
	id isNil ifTrue:[
	    'CURSOR: no cursor with shape:' errorPrint. shape errorPrintNL.
	    ^ self
	].
    ] ifFalse:[
	sourceForm notNil ifTrue:[
	    sF := sourceForm on:aDevice.
	].
	maskForm notNil ifTrue:[
	    mF := maskForm on:aDevice.
	].
	(sF isNil or:[mF isNil]) ifTrue:[
	    'CURSOR: cursor has no form' errorPrintNL.
	    ^ self
	].
	sourceForm := sF.
	maskForm := mF.

	id := aDevice createCursorSourceForm:sourceForm
				    maskForm:maskForm
					hotX:hotX
					hotY:hotY.
	id isNil ifTrue:[
	    'CURSOR: cannot create pixmap cursor' errorPrintNL.
	    ^ self
	].
    ].

    "goody for IRIXs red cursor"
    DefaultFgColor notNil ifTrue:[
	aDevice colorCursor:id foreground:DefaultFgColor
			       background:DefaultBgColor
    ].

    device isNil ifTrue:[
	"receiver was not associated - do it now"
	device := aDevice.
	cursorId := id.

	"must re-register, the old registration had a nil cursorId in it"
	Lobby registerChange:self.
	^ self
    ].

    "receiver was already associated to another device - need a new cursor"
    newCursor := self class basicNew.
    shape notNil ifTrue:[
	newCursor setShape:shape.
    ] ifFalse:[
	newCursor setSourceForm:sourceForm
		       maskForm:maskForm
			   hotX:hotX
			   hotY:hotY
    ].
    newCursor setDevice:aDevice id:id.
    Lobby register:newCursor.
    ^ newCursor
!

device:aDevice
    device := aDevice
!

id:anId
    "set the cursors deviceId"

    cursorId := anId
!

restored
    "set both device and id"

    device := nil.
    cursorId := nil
! !

!Cursor methodsFor:'ST-80 displaying'!

showIn:aView 
    "ST-80 mimicri: install the receiver as aViews cursor"

    aView cursor:self
!

showIn:aView while:aBlock
    "ST-80 mimicri: change aViews cursors to the receiver, while evaluationg aBlock.
     Return the value as returned by aBlock."

    |savedCursor|

    savedCursor := aView cursor.
    aView cursor:self.
    ^ aBlock valueNowOrOnUnwindDo:[aView cursor:savedCursor]
!

showWhile:aBlock
    "ST-80 mimicri: change all views cursors to the receiver.
     Return the value as returned by aBlock."

    ^ WindowGroup activeGroup withCursor:self do:aBlock

"/    |v|
"/
"/    Display setCursors:self.
"/    v := aBlock valueNowOrOnUnwindDo:[
"/        Display restoreCursors.
"/    ].
"/    ^ v
!

show
    "ST-80 mimicri: change cursors in active groups views to the receiver."

    WindowGroup activeGroup showCursor:self
!

displayOn:aGC at:origin clippingBox:aRectangle rule:aRule mask:aMask
    "ST-80 compatibility;
     limited functionality: can only display bitmap cursors (yet)"

    sourceForm notNil ifTrue:[
	sourceForm displayOn:aGC at:origin clippingBox:aRectangle 
			rule:aRule mask:aMask
    ]
! !