VisualComponent subclass: #XBoite instanceVariableNames: 'taille couleur couleurBords label ' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XBoite methodsFor: 'displaying'! displayOn: aGraphicsContext | b p | couleur notNil ifTrue: [ aGraphicsContext paint: couleur ] ifFalse: [ aGraphicsContext paint: ColorValue white ]. aGraphicsContext displayRectangle: (0@0 extent: taille). couleurBords notNil ifTrue: [ aGraphicsContext paint: couleurBords ] ifFalse: [ aGraphicsContext paint: ColorValue black ]. aGraphicsContext displayRectangularBorder: (0@0 extent: taille). label notNil ifTrue: [ b := label bounds. aGraphicsContext paint: ColorValue white. label displayOn: aGraphicsContext at: (p := self bounds extent - b extent // 2 + self bounds origin). aGraphicsContext paint: ColorValue black. label displayOn: aGraphicsContext at: p + 1 ]! ! !XBoite methodsFor: 'bounds accessing'! preferredBounds ^0@0 extent: (taille + 1)! taille ^ taille! taille: unPoint taille := unPoint! ! !XBoite methodsFor: 'accessing'! couleur: aColorValue couleur := aColorValue! couleurBords: aColorValue couleurBords := aColorValue! label: aString label := aString asComposedText! ! VisualComponent subclass: #XEntite instanceVariableNames: 'espace position image bFixe bVisible espaceOrigine interface valeur ' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XEntite methodsFor: 'accessing'! espace ^ espace! espace: esp interface notNil ifTrue: [ esp isNil ifTrue: [ interface sortie ] ]. espace := esp. interface notNil ifTrue: [ esp notNil ifTrue: [ interface entree] ].! espaceOrigine ^ espaceOrigine! fixer bFixe := true! image ^ image! image: uneImage image := uneImage! interface ^ interface! interface: uneXinterface interface := uneXinterface. uneXinterface isNil ifFalse: [ uneXinterface origine: self ]! liberer bFixe := false! obtenirInterface interface isNil ifTrue: [ self interface: (XInterface new) ]. ^ interface! positionAbsolue ^ position + (espace isNil ifTrue: [ 0 ] ifFalse: [ espace positionAbsolue ])! positionAbsolue: pnt espace isNil ifTrue: [ position := pnt ] ifFalse: [ position := pnt - espace positionAbsolue ]! positionRelative ^ position! positionRelative: pnt position := pnt! rendreInvisible bVisible := false! rendreVisible bVisible := true! retirerDeLEspace espace notNil ifTrue: [ espace retireEntite: self ]! valeur ^valeur! valeur: uneValeur valeur := uneValeur! ! !XEntite methodsFor: 'bounds accessing'! preferredBounds bVisible ifFalse: [ ^0 asPoint extent: 0 asPoint ]. ^image isNil ifTrue: [ self positionAbsolue rounded extent: 128 asPoint ] ifFalse: [ self positionAbsolue rounded extent: image preferredBounds extent ]! ! !XEntite methodsFor: 'displaying'! displayOn: aGraphicsContext bVisible ifTrue: [ image isNil ifTrue: [ aGraphicsContext displayRectangle: self preferredBounds ] ifFalse: [ image displayOn: aGraphicsContext at: self positionAbsolue ] ]! ! !XEntite methodsFor: 'initialize-release'! initialize "self allInstances" super initialize. position := 0 asPoint. bFixe := false. bVisible := true! ! !XEntite methodsFor: 'control default'! deplaceDepuis: pnt controller: unControleur "Je suis une entite ou un espace contenu dans un autre. Je suis le mouvement de la souris tant que le bouton est enfonce. A la fin du mouvement, je renvoie a l'espace la responsabilite de me replacer." | vue gc delta lastPosition firstPosition | firstPosition := unControleur sensor cursorPoint. bFixe ifTrue: [interface notNil ifTrue: [ interface clic ]. [ unControleur sensor redButtonPressed ] whileTrue. (vue := unControleur view) displayOn:vue graphicsContext. ^ nil ]. espaceOrigine := espace. position := self positionAbsolue. self retirerDeLEspace. (vue := unControleur view) displayOn: (gc := vue graphicsContext). delta := pnt - position rounded. self follow: [ (lastPosition := unControleur sensor cursorPoint - delta) - position rounded ] while: [ unControleur sensor redButtonPressed ] on: gc. espaceOrigine place: self en: lastPosition. interface notNil ifTrue: [ (firstPosition - unControleur sensor cursorPoint) abs < ( 5@5) ifTrue: [ interface clic ]]. vue displayOn: gc! depose: uneEntite en: pnt "L'entite a termine son mouvement vers une autre entite qui n'est pas un espace." espace bMonoplace ifTrue: [ self echangePlace: uneEntite ] ifFalse: [ espace accepteOuRejete: uneEntite en: pnt ]! echangePlace: uneEntite | espace1 position1 espace2 position2 | espace1 := uneEntite espaceOrigine. position1 := uneEntite positionAbsolue. espace2 := espace. position2 := self positionAbsolue. self retirerDeLEspace. (espace1 accepte: self en: position1) ifTrue: [ espace2 accepteOuRejete: uneEntite en: position2. interface notNil ifTrue: [ self interface echange ] ] ifFalse: [ espace2 accepte: self en: position2 ]! leTempsPasse interface notNil ifTrue: [ interface tempsPasse ]! peutRecevoir: uneEntite en: pnt "teste si le recepteur peut accepter l'entite." ^ bFixe not and: [ (self bounds intersects: (pnt extent: uneEntite bounds extent)) ]! ! !XEntite methodsFor: 'entites accessing'! sousEntites ^Array with: self! ! !XEntite methodsFor: 'testing'! containsPoint: aPoint "Answer whether aPoint lies within the receiver's display box." ^(super containsPoint: aPoint) ifFalse: [ false ] ifTrue: [ image isNil ifTrue: [ true ] ifFalse: [ image containsPoint: aPoint - self positionAbsolue ]]! ! !XEntite methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'Entite:', valeur printString! ! XEntite subclass: #XEspace instanceVariableNames: 'entites bSorties bEntrees bMonoplace ' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XEspace methodsFor: 'entites accessing'! ajouteEntite: ent (self sousEntites includes: ent) ifTrue: [ self error: 'Cycle dans les sous espaces !!' . ^self ]. (ent sousEntites includes: self) ifTrue: [ self error: 'Cycle dans les sous espaces !!' . ^self ]. self entites add: ent. ent espace: self. ^ent! entites entites isNil ifTrue: [ entites := OrderedCollection new ]. ^entites! retireEntite: ent self entites remove: ent. interface notNil ifTrue: [ interface retrait: ent ]. ent espace: nil. ^ ent! sousEntites ^ self entites inject: self entites into: [:coll :ent | coll, ent sousEntites ]! ! !XEspace methodsFor: 'displaying'! displayOn: aGraphicsContext super displayOn: aGraphicsContext. self entites do: [:each | each displayOn: aGraphicsContext ]! ! !XEspace methodsFor: 'control default'! accepte: uneEntite en: pnt "Operation finale. S'il l'accepte, on place l'entite dans le recepteur." | pa | bEntrees ifFalse: [ ^ false ]. bMonoplace ifTrue: [ self entites isEmpty ifFalse: [ ^false ]]. uneEntite positionAbsolue: pnt. self dispose: uneEntite. pa := uneEntite positionAbsolue. self ajouteEntite: uneEntite. uneEntite positionAbsolue: pa. uneEntite interface notNil ifTrue: [ self = uneEntite espaceOrigine ifTrue: [ uneEntite interface deplacement ] ifFalse: [ uneEntite interface drop ]]. interface notNil ifTrue: [ interface ajout: uneEntite ]. ^ true! accepteOuRejete: uneEntite en: pnt (self accepte: uneEntite en: pnt) ifFalse: [ self rejete: uneEntite ]! deplaceDepuis: pnt controller: unControleur "Message envoye initialement par le controleur. On recherche la premiere entite contenant le point, si elle existe, on la deplace. Si elle n'existe pas et que cet espace est contenu dans un autre on deplace l'espace comme si c'etait une entite." | ent | (ent := self entitesDetect: [:each | each containsPoint: pnt ] ifNone: [ espace isNil ifTrue: [ ] ifFalse: [ ^ super deplaceDepuis: pnt controller: unControleur ] ]) notNil ifTrue: [ bSorties ifTrue: [ ent deplaceDepuis: pnt controller: unControleur ] ]! depose: uneEntite en: pnt "On depose une entite, ou un sous espace dans un espace. on descend dans les sous espaces tant que l'on peut. S'il n'y a pas d'entite au point designe, on doit accepter l'entite." | ent | (ent := self entitesDetect: [:each | each peutRecevoir: uneEntite en: pnt ] ifNone: [ self accepteOuRejete: uneEntite en: pnt. ^ self ]) notNil ifTrue: [ ent depose: uneEntite en: pnt ]! dispose: uneEntite uneEntite positionAbsolue: (uneEntite positionAbsolue + (uneEntite bounds amountToTranslateWithin: self bounds))! leTempsPasse super leTempsPasse. interface notNil ifTrue: [ interface tempsPasse ]. entites do: [:each | each leTempsPasse ]! peutRecevoir: uneEntite en: pnt "teste si le recepteur peut accepter l'entite." | taille mataille | "(self containsPoint: pnt) ifFalse: [ ^false ]." (self bounds intersects: (pnt extent: uneEntite bounds extent)) ifFalse: [ ^ false ]. bEntrees ifFalse: [ ^ false ]. taille := uneEntite bounds extent. mataille := self bounds extent. (taille x > mataille x or: [ taille y > mataille y ]) ifTrue: [ ^false ]. ^ true! place: uneEntite en: pnt "L'entite ou l'espace 'uneEntite' a termine son deplacement. tant que le recepteur a un espace englobant, on lui transmet le message. On remonte donc jusqu'en haut de la hierarchie, puis on va redescendre avec le message depose:en: pour trouver le nouveau conteneur." espace notNil ifTrue: [ espace place: uneEntite en: pnt ] ifFalse: [ self depose: uneEntite en: pnt ]! rejete: uneEntite "le mouvement est refuse" (uneEntite espaceOrigine accepte: uneEntite en: uneEntite positionAbsolue) ifFalse: [ self error: 'entite perdue' ]! ! !XEspace methodsFor: 'detection'! entitesDetect: blocCritere ifNone: actionParDefaut "Effectue la detection en partant de la fin" entites size to: 1 by: -1 do: [:idx | (blocCritere value: (entites at: idx)) ifTrue: [ ^ entites at: idx ] ]. ^ actionParDefaut value! ! !XEspace methodsFor: 'bounds accessing'! preferredBoundsRemoved | rect | rect := super preferredBounds. self entites do: [:each | rect := rect merge: each preferredBounds ]. ^rect! ! !XEspace methodsFor: 'initialize-release'! initialize super initialize. bMonoplace := false. bSorties := true. bEntrees := true! ! !XEspace methodsFor: 'accessing'! bEntrees ^ bEntrees! bEntrees: aBoolean bEntrees := aBoolean! bMonoplace ^ bMonoplace! bMonoplace: aBoolean bMonoplace := aBoolean! bSorties ^ bSorties! bSorties: aBoolean bSorties := aBoolean! rendreInvisible super rendreInvisible. entites do: [:each | each rendreInvisible ]! rendreVisible super rendreVisible. entites do: [:each | each rendreVisible ]! tailleMinimale | tailleMinimale | tailleMinimale := 0@0. self entites do: [:each | each bounds width > tailleMinimale x ifTrue: [ tailleMinimale x: each bounds width ]. each bounds height > tailleMinimale y ifTrue: [ tailleMinimale y: each bounds height ] ]. ^ tailleMinimale! ! !XEspace methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'Espace: ', entites printString! ! View subclass: #XView instanceVariableNames: 'pixmap ' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XView methodsFor: 'displaying'! clearInside! displayOn: aGraphicsContext model notNil ifTrue: [ model displayOn: self pixmap graphicsContext. pixmap displayOn: aGraphicsContext ]! ! !XView methodsFor: 'controller accessing'! defaultControllerClass ^ XController! ! !XView methodsFor: 'doubleBuffer'! pixmap (pixmap isNil or: [ pixmap isOpen not or: [ (pixmap bounds = self bounds) not ]]) ifTrue: [ pixmap := Pixmap extent: self bounds extent ]. ^pixmap! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! XView class instanceVariableNames: ''! !XView class methodsFor: 'test'! test1 "self test1" | fenetre ifantome ifond espace fantome vue | ifantome := XMaster imageFantome. ifond := XMaster imageFond. espace := XEspace new. espace image: ifond. fantome := XEntite new. fantome image: ifantome. espace positionAbsolue: 0 asPoint. fantome positionRelative: 50 asPoint. espace ajouteEntite: fantome. fenetre := ScheduledWindow new. fenetre open. vue := self new. vue model: espace. fenetre component: vue.! test2 "self test2" | fenetre ifantome ifond espace fantome vue iboite boite | ifantome := XMaster imageFantome. ifond := XMaster imageFond. iboite := XMaster imageBoite. espace := XEspace new. espace image: ifond. boite := XEspace new. boite image: iboite. fantome := XEntite new. fantome image: ifantome. espace ajouteEntite: fantome. espace ajouteEntite: boite. espace positionAbsolue: 20 asPoint. fantome positionRelative: 50 asPoint. boite positionRelative: 100 asPoint. fenetre := ScheduledWindow new. fenetre open. vue := self new. vue model: espace. fenetre component: vue.! test3 "self test3" | fenetre ifantome ifond espace fantome vue iboite boite boite2 fantome2 boule im1 im2 im3 | ifantome := XMaster imageFantome. ifond := XMaster imageFond. iboite := XMaster imageBoite. espace := XEspace new. espace image: ifond. boite := XEspace new. boite image: iboite. boite2 := XEspace new. "boite image: iboite." fantome := XEntite new. fantome image: ifantome. fantome2 := XEntite new. fantome2 image: ifantome. boule := XEntite new. boule image: XMaster imageTourne. im1 := XEntite new. im1 image: XMaster image1. im2 := XEntite new. im2 image: XMaster image2. im3 := XEntite new. im3 image: XMaster image3. espace ajouteEntite: im1; ajouteEntite: im2; ajouteEntite: im3. espace ajouteEntite: fantome. espace ajouteEntite: fantome2. espace ajouteEntite: boite. espace ajouteEntite: boule. espace ajouteEntite: boite2. boite2 bMonoplace: true. espace positionAbsolue: 20 asPoint. fantome positionRelative: 50 asPoint. boite positionRelative: 100 asPoint. fenetre := ScheduledWindow new. fenetre open. vue := self new. vue model: espace. fenetre component: vue.! ! Controller subclass: #XController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XController methodsFor: 'control default'! controlActivity sensor redButtonPressed ifTrue: [ model deplaceDepuis: self sensor cursorPoint controller: self ]. sensor yellowButtonPressed ifTrue: [ model inspect ]. model leTempsPasse. view displayOn: view graphicsContext. self sensor pseudoEvent.! ! Object subclass: #XInterface instanceVariableNames: 'recepteur origine surClic surDrop surAjout surRetrait surEntree surSortie surEchange surDeplacement surTempsPasse ' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XInterface methodsFor: 'actions'! performAction: messageOuBloc messageOuBloc isNil ifTrue: [ ^self ]. (messageOuBloc isKindOf: Symbol) ifTrue: [ self performMessage: messageOuBloc ] ifFalse: [ self performBloc: messageOuBloc ]! performAction: messageOuBloc with: uneEntite messageOuBloc isNil ifTrue: [ ^self ]. (messageOuBloc isKindOf: Symbol) ifTrue: [ self performMessage: messageOuBloc with: uneEntite ] ifFalse: [ self performBloc: messageOuBloc with: uneEntite ]! performBloc: bloc bloc numArgs = 0 ifTrue: [ ^ bloc value ]. bloc numArgs = 1 ifTrue: [ ^ bloc value: origine ]. bloc numArgs = 2 ifTrue: [ ^ bloc value: origine value: recepteur ]! performBloc: bloc with: uneEntite bloc numArgs = 0 ifTrue: [ ^ bloc value ]. bloc numArgs = 1 ifTrue: [ ^ bloc value: origine ]. bloc numArgs = 2 ifTrue: [ ^ bloc value: origine value: recepteur ]. bloc numArgs = 3 ifTrue: [ ^ bloc value: origine value: recepteur value: uneEntite ]! performMessage: message recepteur isNil ifTrue: [ self error: 'recepteur non defini pour ', message asString. ^self ]. message numArgs = 0 ifTrue: [ ^recepteur perform: message ]. message numArgs = 1 ifTrue: [ ^recepteur perform: message with: origine ]! performMessage: message with: uneEntite recepteur isNil ifTrue: [ self error: 'recepteur non defini pour ', message asString. ^self ]. message numArgs = 0 ifTrue: [ ^recepteur perform: message ]. message numArgs = 1 ifTrue: [ ^recepteur perform: message with: origine ]. message numArgs = 2 ifTrue: [ ^recepteur perform: message with: origine with: uneEntite ]! ! !XInterface methodsFor: 'interface'! ajout ^self performAction: surAjout! ajout: uneEntite ^self performAction: surAjout with: uneEntite! clic ^self performAction: surClic! deplacement ^self performAction: surDeplacement! drop ^self performAction: surDrop! echange ^self performAction: surEchange! entree ^self performAction: surEntree! retrait ^self performAction: surRetrait! retrait: uneEntite ^self performAction: surRetrait with: uneEntite! sortie ^self performAction: surSortie! tempsPasse ^self performAction: surTempsPasse! ! !XInterface methodsFor: 'accessing'! origine ^origine! origine: objet origine := objet! recepteur ^recepteur! recepteur: objet recepteur := objet! surAjout: messageOuBloc surAjout := messageOuBloc! surClic: messageOuBloc surClic := messageOuBloc! surDeplacement: messageOuBloc surDeplacement := messageOuBloc! surDrop: messageOuBloc surDrop := messageOuBloc! surEchange: messageOuBloc surEchange := messageOuBloc! surEntree: messageOuBloc surEntree := messageOuBloc! surRetrait: messageOuBloc surRetrait := messageOuBloc! surSortie: messageOuBloc surSortie := messageOuBloc! surTempsPasse: messageOuBloc surTempsPasse := messageOuBloc! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! XInterface class instanceVariableNames: ''! !XInterface class methodsFor: 'instance creation'! relier: uneOrigine a: unRecepteur ^(self new) origine: uneOrigine; recepteur: unRecepteur! vers: unRecepteur ^(self new) recepteur: unRecepteur! ! VisualComponent subclass: #XImage instanceVariableNames: 'forme couleur pixmap masque pixmapGc ' classVariableNames: '' poolDictionaries: '' category: 'VL-XEspaces'! !XImage methodsFor: 'displaying'! displayOn: aGraphicsContext aGraphicsContext copyArea: self masque from: self pixmapGraphicsContext sourceOffset: 0@0 destinationOffset: 0@0.! ! !XImage methodsFor: 'accessing'! bFormeSensible: aBoolean bFormeSensible := aBoolean! couleur ^couleur! forme: aCoverageImage couleur: aColoredImage forme := aCoverageImage. couleur := aColoredImage! masque (masque == nil or: [masque isOpen not]) ifTrue: [masque := forme asRetainedMedium]. ^masque! pixmap (pixmap == nil or: [pixmap isOpen not]) ifTrue: [pixmap := couleur asRetainedMedium]. ^ pixmap! pixmapGraphicsContext (pixmapGc isNil or: [ pixmapGc medium isOpen not]) ifTrue: [ pixmapGc := self pixmap graphicsContext ]. ^ pixmapGc! ! !XImage methodsFor: 'bounds accessing'! preferredBounds ^couleur preferredBounds! ! !XImage methodsFor: 'initialize-release'! newGraphicsDevice: aGraphicsDevice "Any information that the receiver caches that is platform dependent is questionable. An example of bad information is font widths." pixmap := nil. masque := nil. pixmapGc := nil.! ! !XImage methodsFor: 'testing'! containsPoint: aPoint "Answer whether aPoint lies within the receiver's display box." ^ (self bounds containsPoint: aPoint) ifFalse: [ false ] ifTrue: [ forme isNil ifTrue: [ ^ true ] ifFalse: [ (forme atPoint: aPoint rounded) = 1 ] ]! ! !XImage methodsFor: 'debug'! test self displayOn: Window currentWindow graphicsContext! testCouleur couleur displayOn: Window currentWindow graphicsContext! testMasque self masque displayOn: Window currentWindow graphicsContext! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! XImage class instanceVariableNames: ''! !XImage class methodsFor: 'creation'! forme: aCoverageImage couleur: aColoredImage ^self new forme: aCoverageImage couleur: aColoredImage! ! !XImage class methodsFor: 'exemples'! exemple1 | xim fenetre | xim := self forme: ((ImageReader fromFile: 'masque.bmp') image convertToCoverageWithOpaquePixel: 255) couleur: (ImageReader fromFile: 'fantome.bmp') image. fenetre := ScheduledWindow new. fenetre open. fenetre component: xim.! exemple2 | xim gc | xim := self forme: ((ImageReader fromFile: 'masque.bmp') image convertToCoverageWithOpaquePixel: 255) couleur: (ImageReader fromFile: 'fantome.bmp') image. gc :=Window currentWindow graphicsContext. 1 to: 100 do: [:p | xim displayOn: gc at: p asPoint ]! exemple3 | xim gc fenetre | xim := self forme: ((ImageReader fromFile: 'masque.bmp') image convertToCoverageWithOpaquePixel: 255) couleur: (ImageReader fromFile: 'fantome.bmp') image. gc := (fenetre := Window currentWindow) graphicsContext. xim follow: [ fenetre controller sensor cursorPoint ] while: [ fenetre controller sensor anyButtonPressed not ] on: gc! !