BrazilMappingForWin32.ns

Newspeak3
'BrazilForWindows-Mapping'
class BrazilMappingForWin32 platform: platform = (
(* This is the top-level Brazil Windows mapping module that holds together all the bits and pieces of the mapping, most importantly agent classes and the agent factory.

Copyright 2008, 2012 Cadence Design Systems, Inc.

Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  https://www.apache.org/licenses/LICENSE-2.0
*)
|	(* imports *)
	private Map = platform squeak Dictionary.
	private IdentityMap = platform squeak IdentityDictionary.
	private List = platform squeak OrderedCollection.
	private Error = platform squeak Error.
	private Alien = platform squeak Alien.
	private UnsafeAlien = platform squeak UnsafeAlien.
	private Callback = platform squeak Callback.
	private NsFFISessionManager = platform squeak NsFFISessionManager.
	private Transcript = platform squeak Transcript.
	private FileStream = platform squeak FileStream.
	private TimeStamp = platform squeak TimeStamp.
	private Time = platform time Time.
	private UnhandledError = platform squeak UnhandledError.
	private Process = platform squeak Process.
	private Color = platform squeak Color.
	private TextColor = platform squeak TextColor.
	private TextEmphasis = platform squeak TextEmphasis.

	(* Hack dependencies we should eventually lose *)
	private WorldState = platform squeak WorldState.

	(* Brazil specific imports *)
	private brazil = platform brazil.

	private MessageBox = brazil tools MessageBox.
	private AbstractAgentFactory = brazil mapping AbstractAgentFactory.
	private GenericAgent = brazil mapping BrazilMappingAgent.
	private Font = brazil plumbing Font.
	private ModifierKeyState = brazil plumbing ModifierKeyState.

	(* module variables *)
	public api = platform apiManager win32api.
	public agentFactory = AgentFactory new.
	public windowsSession = WindowsSession new.
	public squeakWindowHandle
	public useDoubleBuffering ::= false.

	private activeImageAgentStates = ActiveImageAgentStateClasses new.
	private hyperlinkAgentStates = HyperlinkAgentStateClasses new.
|) (
class ActiveImageAgent forVisual: image = ImageAgent forVisual: image (
(* Maps ActiveIcon visuals. *)
|
	state ::= activeImageAgentStates NormalState forAgent: self.
|) (
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual disabledImageA to: [:newImage | invalidate].
	map: visual hoverImageA to: [:newImage | invalidate].
	map: visual downImageA to: [:newImage | invalidate].
	map: visual enabledA to: [:newEnabledState | invalidate].
	(* The actOnMouseDownA attribute is checked on the fly and needs no mapping. *)
)
public enterState: stateClass = (
	state:: stateClass forAgent: self.
	invalidate.
)
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
	^(visual bounds containsPoint: parentRelativePoint)
		ifTrue: [self]
		ifFalse: [nil]
)
public processMouseDownLeft = (
	state respondToMouseDownLeft.
)
public processMouseEntry = (
	state respondToMouseEntry.
)
public processMouseExit = (
	state respondToMouseExit.
)
public processMouseUpLeft = (
	state respondToMouseUpLeft
)
protected visualImage ^<Form | nil> = (
	(* Answer the image to use as our picture at this very moment. Sent by the painting code. *)
	^state image
)
) : (
)
class ActiveImageAgentStateClasses = (
(* This is a nested module defining the classes of ActiveImageAgent states, to avoid having a unique set of those in each ActiveImageAgent instance. *)
) (
class AgentState forAgent: theAgent = (
(* This is the abstract superclass of all other other active image state classes. *)
|
	agent = theAgent.
|) (
public respondToMouseDownLeft = (
)
public respondToMouseEntry = (
)
public respondToMouseExit = (
	agent enterState: activeImageAgentStates NormalState.
)
public respondToMouseMove = (
)
public respondToMouseUpLeft = (
)
public visual = (
	^agent visual
)
) : (
)
public class HoverState forAgent: theAgent = AgentState forAgent: theAgent (
(* Represents the state when the mouse is within the bounds of the visual but no buttons are pressed. *)
) (
public image = (
	^(visual enabled
		ifTrue: [visual hoverImage]
		ifFalse: [visual disabledImage])
			ifNil: [visual image]
)
public respondToMouseDownLeft = (
	visual enabled ifTrue:
		[visual actOnMouseDown
			ifTrue: [visual doAction]
			ifFalse: [agent enterState: activeImageAgentStates PressedState]]
)
public respondToMouseExit = (
	agent enterState: activeImageAgentStates NormalState
)
) : (
)
public class NormalState forAgent: theAgent = AgentState forAgent: theAgent (
(* Represents the state when the mouse is outside the bounds of the visual. *)
) (
public image = (
	^visual enabled
		ifTrue: [visual image]
		ifFalse: [visual disabledImage ifNil: [visual image]]
)
public respondToMouseEntry = (
	agent enterState: activeImageAgentStates HoverState
)
) : (
)
public class PressedState forAgent: theAgent = AgentState forAgent: theAgent (
(* Represents the state when the mouse is within the bounds of the visual and a button is pressed. *)
) (
public image = (
	^(visual enabled
		ifTrue: [visual downImage]
		ifFalse: [visual disabledImage])
			ifNil: [visual image]
)
public respondToMouseExit = (
	agent enterState: activeImageAgentStates WarmState
)
public respondToMouseUpLeft = (
	agent enterState: activeImageAgentStates HoverState.
	(visual enabled and: [visual actOnMouseDown not])
		ifTrue: [visual doAction]
)
) : (
)
public class WarmState forAgent: theAgent = NormalState forAgent: theAgent (
(* Describes the state of the button when it was initially pressed and then the cursor left its bounds. It now displays itself as normal but will switch to being pressed again if the cursor reenters. *)
) (
public respondToMouseEntry = (
	agent enterState: (agent isLeftButtonDown
		ifTrue: [activeImageAgentStates PressedState]
		ifFalse: [activeImageAgentStates HoverState])
)
) : (
)
) : (
)
class ActiveLabelAgent forVisual: v = LabelAgent forVisual: v (
(* Represents Brazil ActiveLabels. Largely the same as LabelAgent, but expresses interest in mouse events and forwards them to the visual. *)
) (
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
	^(visual bounds containsPoint: parentRelativePoint)
		ifTrue: [self]
		ifFalse: [nil]
)
public processMouseDownLeft = (
	visual respondToMouseDownLeft
)
public processMouseEntry = (
	visual respondToMouseEntry
)
public processMouseExit = (
	visual respondToMouseExit
)
public processMouseMove = (
	visual respondToMouseMove
)
public processMouseUpLeft = (
	visual respondToMouseUpLeft
)
) : (
)
class Agent forVisual: visual = GenericAgent forVisual: visual (
(* This is the common superclass of all Agents used for mapping Brazil visuals to Windows artifacts. *)
|
	api_
	agentFactory_
	protected areBoundsChanging <Boolean> ::= false.
|) (
agentFactory = (
	^agentFactory_ ifNil:
		[agentFactory_: outer BrazilMappingForWin32 agentFactory.
		agentFactory_]
)
public api ^<Win32API> = (
	#BOGUS. (* Why is there here? *)
	^api_ ifNil:
		[api_: outer BrazilMappingForWin32 api.
		api_]
)
public areBoundsHereOrInAncestorsChanging = (
	^areBoundsChanging or:
		[parent
			ifNil: [false]
			ifNotNil: [:it | it areBoundsHereOrInAncestorsChanging]]
)
areBoundsInAncestorsChanging = (
	^parent
		ifNil: [false]
		ifNotNil: [:it | it areBoundsHereOrInAncestorsChanging]
)
public collectControlsByHandleInto: aDictionary = (
	childrenDo: [:each | each collectControlsByHandleInto: aDictionary]
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
(* This message is first sent by a WindowAgent during the processing of a WM_PAINT. The WindowAgent takes care of calling BeginPaint before this request to obtain the HDC. It will call EndPaint afterwards to clean up. Agents that are interested in painting things inside the window should do it here. NOTE: the HDC is untranslated, agents need to translate their visual's coordinates to be window-relative using the supplied parentOrigin. *)
	| translatedUpdateRect myOrigin |
	translatedUpdateRect:: parentRelativeUpdateRect
		translateBy: visual origin negated.
	myOrigin:: parentOrigin + visual origin.
	childrenDo:
		[:each |
		each
			contributeToWM_PAINTOn: hdc
			inside: translatedUpdateRect
			translatedBy: myOrigin]
)
ensureUpToDateAppearance = (
	handle ifNotNil: [:it | api UpdateWindow value: it]
)
fillRectangle: rect <Rectangle> on: hdc <Integer> withGradient: gradient <Gradient> = (
	| topColor bottomColor sizeofTrivertex vertices gradientRect |
	topColor:: gradient startColor.
	bottomColor:: gradient endColor.
	sizeofTrivertex:: api TRIVERTEX dataSize.
	vertices:: Alien newC: sizeofTrivertex * 2.
	(api TRIVERTEX atAddress: vertices address)
		x: rect left;
		y: rect top;
		red: (topColor red * 16rFFFF) asInteger;
		green: (topColor green * 16rFFFF) asInteger;
		blue: (topColor blue * 16rFFFF) asInteger.
	(api TRIVERTEX atAddress: vertices address + sizeofTrivertex)
		x: rect right;
		y: rect bottom;
		red: (bottomColor red * 16rFFFF) asInteger;
		green: (bottomColor green * 16rFFFF) asInteger;
		blue: (bottomColor blue * 16rFFFF) asInteger.
	gradientRect:: api GRADIENT_RECT newC.
	gradientRect
		UpperLeft: 0;
		LowerRight: 1.
	api GradientFill
		value: hdc
		value: vertices address
		value: 2
		value: gradientRect address
		value: 1
		value: api GRADIENT_FILL_RECT_V.
	gradientRect free.
	vertices free.
)
fillRectangle: rect <Rectangle> on: hdc <Integer> withSolidColor: color <Color> = (
	| oldBrush oldPen |
	oldBrush:: api SelectObject
		unsignedValue: hdc
		value: (api GetStockObject unsignedValue: api DC_BRUSH).
	oldPen:: api SelectObject
		unsignedValue: hdc
		value: (api GetStockObject unsignedValue: 8 (* api NULL_PEN *)).
	api SetDCBrushColor
		unsignedValue: hdc
		value: color asColorref.
	api Rectangle
		value: hdc
		value: rect left
		value: rect top
		value: rect right + 1
		value: rect bottom + 1.
	api SelectObject value: hdc value: oldBrush.
	api SelectObject value: hdc value: oldPen.
)
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
	(* If the agent is willing to handle a mouse event that has just occurred at the specified point, it should return itself. A container may return a child instead of itself. When a parent passes this request down to the child it should take care to translate the argument accordingly. *)
	^nil
)
public grabMouse = (
	hostWindowAgent setMouseGrabTo: self
)
public handle ^<Integer> = (
	(* Answer the handle of the window the agent created to represent its visual, or the handle of the nearest parent mapped to a window if the visual has no window for itself. *)
	subclassResponsibility
)
public hostWindowAgent ^<Agent | nil> = (
	(* The agent that manages the native window this agent is located in. This may or may not be the direct parent of the agent. The visual overriding this method with ^self will typically need to reimplement invalidate: and invalidateRectangle: as direct native calls. *)
	^parent ifNotNil: [:it | it hostWindowAgent]
)
invalidate = (
	(* Invalidate the area currently occupied by the visual. *)
	parent ifNotNil:
		[:it |
		it invalidateRectangle: visual bounds]
(*	hostWindowAgent ifNotNil:
		[:it |
		it invalidateRectangle: (rectangleRelativeToHostWindow: visual localBounds)]. *)
)
public invalidateRectangle: rectangle <Rectangle> = (
	(* Invalidate the rectangle. The rectangle is relative to the visual's top left corner. *)
	parent ifNotNil:
		[:it | it invalidateRectangle: (rectangle translateBy: visual origin)].
(*	hostWindowAgent ifNotNil:
		[:it |
		it invalidateRectangle: (rectangleRelativeToHostWindow: rectangle)].
*)
)
invalidateWindow = (
	windowHandle ifNotNil:
		[:hwnd |
		api InvalidateRect
			value: hwnd
			value: 0 (* null rectangle, i.e. the whole thing *)
			value: 0 (* do not erase background--painted by agent *)]
)
isLeftButtonDown ^<Boolean> = (
	^(api GetKeyState unsignedValue: api VK_LBUTTON) > 1
	(* Checking for the state to be > 1 rather than ~= 0 so that the toggle bit (LSB)  doesn't get in the way. *)
)
matchVisualsBounds = (
)
public mousePoint = (
	^visual desktop
		ifNil: [0 @ 0]
		ifNotNil: [:it | it mousePoint translateFrom: it to: visual]
)
public noteBeginningOfBoundsChangeAndProvideEndContinuation = (
	areBoundsChanging: true.
	^[areBoundsChanging: false]
)
platform = (
	^#win32
)
public processMouseDownLeft = (
)
public processMouseEntry = (
)
public processMouseExit = (
)
public processMouseMove = (
)
public processMouseUpLeft = (
)
public rectangleRelativeToHostWindow: rect <Rectangle> ^<Rectangle> = (
	(* By request (presumably) from a child, translate the rectangle to be relative to whatever visual that provides the host reference frame for the child. This rectangle is in our coordinate system. *)
	^parent
		ifNil: [rect]
		ifNotNil: [:it | it rectangleRelativeToHostWindow: (rect translateBy: visual origin)]
)
public releaseMouse = (
	hostWindowAgent releaseMouseGrabFrom: self
)
windowHandle ^<Integer | nil> = (
	(* Answer the Windows handle of the window containing this agent's visual. Answer nil if there is no window or the window is not mapped. *)
	^visual window ifNotNil:
		[:it | it agent ifNotNil:
			[:wagent | wagent handle]]
)
windowsSession ^<WindowsSession> = (
	^outer BrazilMappingForWin32 windowsSession.
)
) : (
)
class AgentFactory = AbstractAgentFactory (
(* The rest of Brazil refers to classes such as this one as mappings, however from here on we'll consider a mapping to be the entire body of code that handles the representation of Brazil visuals as a particular set of native UI primitives. What was previously known as mappings will now be called agent factories of mappings. *)
) (
public createAgentForActiveIcon: icon <ActiveIcon> = (
	^ActiveImageAgent forVisual: icon
)
public createAgentForActiveLabel: label <ActiveLabel> = (
	^ActiveLabelAgent forVisual: label
)
public createAgentForBlank: blank <Blank> = (
	^NullAgent forVisual: blank
)
public createAgentForCompositeVisual: visual <CompositeVisual> = (
	^NullColoredAgent forVisual: visual
)
public createAgentForDesktop: aDesktop <Desktop> = (
	^DesktopAgent desktop: aDesktop
)
public createAgentForEllipseShape: shape <EllipseShape> = (
	^EllipseShapeAgent forVisual: shape
)
public createAgentForHyperlink: link <Hyperlink> = (
	^HyperlinkAgent forVisual: link
)
public createAgentForIcon: icon <Icon> = (
	^ImageAgent forVisual: icon
)
public createAgentForLabel: label <Label> = (
	^LabelAgent forVisual: label
)
public createAgentForLineShape: shape <LineShape> = (
	^LineShapeAgent forVisual: shape
)
public createAgentForListBox: listBox <ListBox> = (
	^ListBoxAgent forVisual: listBox
)
public createAgentForMenu: menu <Menu> = (
	^MenuAgent menu: menu
)
public createAgentForPolygonShape: shape <PolygonShape> = (
	^PolygonShapeAgent forVisual: shape
)
public createAgentForPushButton: button <PushButton> = (
	^ButtonAgent forVisual: button
)
public createAgentForRectangleShape: shape <RectangleShape> = (
	^RectangleShapeAgent forVisual: shape
)
public createAgentForSensitiveIcon: icon <SensitiveIcon> = (
	^SensitiveImageAgent forVisual: icon
)
public createAgentForTextDisplay: visual <TextDisplay> = (
	^TextDisplayAgent forVisual: visual
)
public createAgentForTextView: textView <TextView> = (
	^TextViewAgent forVisual: textView
)
public createAgentForVerticalViewport: viewport <VerticalViewport> = (
	^VerticalViewportAgent forVisual: viewport
)
public createAgentForVerticalVisualSequence: visual <VisualSequence> = (
	^VerticalVisualSequenceAgent forVisual: visual
)
public createAgentForViewport: viewport <Viewport> = (
	^ViewportAgent forVisual: viewport
)
public createAgentForVisualSequence: visual <VisualSequence> = (
	^NullColoredAgent forVisual: visual
)
public createAgentForWindow: window <Window> = (
	^WindowAgent forVisual: window
)
public createAgentForWrapper: wrapper <Wrapper> = (
	^NullColoredAgent forVisual: wrapper
)
) : (
)
class AgentWithHandle forVisual: visual = Agent forVisual: visual (
(* This is an abstract superclass of those agents that create an actual Windows window to represent their visuals. The 'handle' slot holds the integer value of the handle, if it exists. The class also provides some facilities common to window management such as enabling and disabling the window, sending it messages, or changing its style. *)
|
	public handle
|) (
public enableWindow: doEnable <Boolean> = (
	| success |
	ifHandleValid:
		[api EnableWindow
			boolValue: handle
			value: (doEnable ifTrue: [1] ifFalse: [0])]
)
getDCWhile: action <Block> ifNotMapped: unmappedAction <Block> = (
	| hdc |
	handle isNil ifTrue: [^unmappedAction value].
	hdc:: api GetDC unsignedValue: handle.
	hdc = 0 ifTrue: [api reportError: 'GetDC() failed'].
	^[action value: hdc] ensure:
		[api ReleaseDC value: handle value: hdc]
)
getWindowExStyle = (
	^getWindowLong: api GWL_EXSTYLE
)
getWindowLong: index <Integer> ^<Integer> = (
	handle isNil ifTrue: [error: 'agent has no window handle'].
	^api GetWindowLong
		unsignedValue: handle
		value: index.
)
getWindowStyle = (
	^getWindowLong: api GWL_STYLE
)
getWindowText ^<String> = (
	^getWindowTextIfNone: [String new]
)
getWindowTextIfNone: noneBlock ^<String> = (
	| length |
	handle ifNil: [^noneBlock value].
	length:: sendMessage: api WM_GETTEXTLENGTH wParam: 0 lParam: 0.
	^(Alien newC: length + 1) freeAfter:
		[:buffer |
		sendMessage: api WM_GETTEXT
			wParam: length + 1
			lParam: buffer address.
		buffer strcpy withSqueakLineEndings]
)
ifHandleValid: block = (
	^handle ifNotNil: [block value]
)
public resetForNewImageSession = (
	handle:: nil
)
sendMessage: msg <Integer> wParam: wParam <Integer> lParam: lParam <Integer> ^<Integer> = (
	(* Send a Windows message to the agent's Windows window. *)
	^ifHandleValid:
		[api SendMessage
			unsignedValue: handle
			value: msg
			value: wParam
			value: lParam]
)
setWindowExStyle: value <Integer> = (
	setWindowLong: api GWL_EXSTYLE to: value
)
setWindowLong: index <Integer> to: value <Integer> = (
	ifHandleValid:
		[api SetWindowLong
			unsignedValue: handle
			value: index
			value: value]
)
setWindowStyle: value <Integer> = (
	setWindowLong: api GWL_STYLE to: value
)
public setWindowText: newText <String> = (
	(Alien newCString: newText) freeAfter:
		[:cString |
		sendMessage: api WM_SETTEXT
		wParam: 0
		lParam: cString address]
)
showWindow: doShow <Boolean> = (
	ifHandleValid:
		[api ShowWindow
			value: handle
			value: (doShow ifTrue: [api SW_SHOW] ifFalse: [api SW_HIDE])]
)
takeKeyboardFocus = (
	^ifHandleValid:
		[api SetFocus unsignedValue: handle]
)
updateWindow = (
	ifHandleValid:
		[api UpdateWindow value: handle]
)
) : (
)
class BogusAgent forVisual: v = NullAgent forVisual: v (
(* An agent we use in cases when there is no real agent yet that we could use. *)
) (
public matchScrollbarRange = (
	flag: #BOGUS. (* Provided temporarily only so that we can use this as a viewport agent. *)
)
naturalExtent = (
	^100 @ 20
)
public naturalHeightForWidth: ignored = (
	^20
)
scrollbarHeight = (
	flag: #BOGUS. (* Provided temporarily only so that we can use this as a viewport agent. *)
	^15
)
) : (
)
class BoxShapeAgent forVisual: v <Visual> = NullAgent forVisual: v (
(* This is the abstract superclass of agents for those shape visuals that are defined by their bounding box, i.e. rectangles and ellipses. *)
) (
asColor: color <Color | Gradient> = (
	^color isColor
		ifTrue: [color]
		ifFalse: [color startColor mixed: 0.5 with: color endColor]
)
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual colorA to: [:ignored | self invalidate].
	map: visual borderColorA to: [:ignored | self invalidate].
	map: visual borderWidthA to: [:ignored | self invalidate].
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	(needsPaintingRect: parentRelativeUpdateRect) ifTrue:
		[paintShapeOn: hdc in: (visual bounds translateBy: parentOrigin)].
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	invalidate
)
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
	^(visual bounds containsPoint: parentRelativePoint)
		ifTrue: [self]
		ifFalse: [nil]
)
isColor: color = (
	^color yourself asColor == color yourself
)
needsPainting ^<Boolean> = (
	^visual visible and:
		[visual color asColor isTransparent not or:
			[visual borderWidth > 0]]
)
needsPaintingRect: parentRelativeRect <Rectangle> = (
	^needsPainting
		and: [visual bounds intersects: parentRelativeRect]
)
paintShapeOn: hdc <Integer> in: boundsBox <Rectangle> = (
	subclassResponsibility
)
public processMouseDownLeft = (
	visual respondToMouseDownLeft
)
public processMouseEntry = (
	visual respondToMouseEntry
)
public processMouseExit = (
	visual respondToMouseExit
)
public processMouseMove = (
	visual respondToMouseMove
)
public processMouseUpLeft = (
	visual respondToMouseUpLeft
)
setupContextPenIn: hdc <Integer> while: action <Block> = (
	| oldPen |
	oldPen:: api SelectObject
		unsignedValue: hdc
		value: (api GetStockObject unsignedValue: api DC_PEN).
	api SetDCPenColor
		unsignedValue: hdc
		value: visual borderColor asColorref.
	^action ensure:
		[api SelectObject value: hdc value: oldPen].
)
setupFillBrushIn: hdc <Integer> while: action <Block> = (
	| oldBrush |
	oldBrush:: api SelectObject
		unsignedValue: hdc
		value: (api GetStockObject unsignedValue: api DC_BRUSH).
	api SetDCBrushColor
		unsignedValue: hdc
		value: (asColor: visual color) asColorref.
	^action ensure:
		[api SelectObject value: hdc value: oldBrush].
)
setupNullBrushIn: hdc <Integer> while: action <Block> = (
	| oldBrush |
	oldBrush:: api SelectObject
		unsignedValue: hdc
		value: (api GetStockObject unsignedValue: (* NULL_BRUSH *) 5).
	^action ensure:
		[api SelectObject value: hdc value: oldBrush].
)
setupNullPenIn: hdc <Integer> while: action <Block> = (
	| oldPen |
	oldPen:: api SelectObject
		unsignedValue: hdc
		value: (api GetStockObject unsignedValue: 8 (* api NULL_PEN *)).
	^action ensure:
		[api SelectObject value: hdc value: oldPen].
)
setupOutlinePenIn: hdc <Integer> while: action <Block> = (
	^(visual borderWidth > 0 and: [visual borderColor isTransparent not])
		ifTrue: [setupContextPenIn: hdc while: action]
		ifFalse: [setupNullPenIn: hdc while: action]
)
) : (
)
class ButtonAgent forVisual: visual = WindowControlAgent forVisual: visual (
|
	protected cachedNaturalExtent
|) (
public connectOwnArtifacts = (
	map: visual labelA to: self ~ #setWindowText:.
	map: visual enabledA to: self ~ #enableWindow:.
	super connectOwnArtifacts.
)
controlClassName = (
	^'BUTTON'
)
controlWindowTitle = (
	^visual label
)
protected finalExtentFrom: stringExtent <Point> ^ <Point> = (
	| extra |
	extra:: stringExtent y.
	^stringExtent + (2 * extra @ extra)
)
protected measureNaturalExtent ^<Point> = (
	(* We cannot use the BCM_GETIDEALSIZE message provided by XP and above, because it is only available if the application is built with a linker flag or a manifest indicating that it uses CommCtl 6.0+. Thus we need to estimate the size based on some arbitrary assumptions. Insert a suitably sarcastic comment on Microsoft's software design acumen. *)
	^getDCWhile:
		[:hdc |
		selectProperFontInto: hdc.
		finalExtentFrom:
			(measureString: visual label asString using: hdc)]
	ifNotMapped: [0@0].
)
protected measureString: aString using: hdc ^<Point> = (
	| result |
	^api POINT newC freeAfter:
		[:sizeBuffer |
		result:: api GetTextExtentPoint32
			unsignedValue: hdc
			value: (UnsafeAlien forPointerTo: aString)
			value: aString size
			value: sizeBuffer address.
		result = 0 ifTrue: [api reportError: 'GetTextExtentPoint32() failed'].
		sizeBuffer asPoint]
)
public naturalExtent ^<Point> = (
	^cachedNaturalExtent ifNil:
		[cachedNaturalExtent:: measureNaturalExtent.
		cachedNaturalExtent]
)
public processCommand: code <Integer> ^<Integer> = (
	code = api BN_CLICKED ifTrue:
		(* [visual desktop scheduleUIAction: [visual doAction]]. *)
		[visual doAction].
	^0
)
protected selectProperFontInto: hdc <Integer> = (
	| hfont |
	hfont:: windowsSession fontMapper defaultControlFontHandle.
	api SelectObject value: hdc value: hfont.
)
public setWindowText: newText <String> = (
	cachedNaturalExtent: nil.
	super setWindowText: newText asString
)
) : (
)
class DesktopAgent = (
(* This agent maps the desktop of the host platform. *)
|
	public desktop
	protected modifierKeyStateForCurrentEventX
|) (
public areBoundsHereOrInAncestorsChanging = (
	^false
)
public clearDraggedImage = (
	windowsSession removeDragCue
)
public connectArtifactsOfChild: ignored = (
)
public desktopBounds ^<Rectangle> = (
	(* Answer the area of the main desktop available for placing windows. *)

	^windowsSession systemMetrics desktopBounds
)
disableUserInputDuring: action = (
	windowsSession disableAll.
	[^action value] ensure: [windowsSession enableAll]
)
ensureUpToDateAppearance = (
	(* We are always up-to-date on Windows. *)
)
public isMorphic ^<Boolean> = (
	^false
)
isNull ^<Boolean> = (
	^false
)
public isWindows ^<Boolean> = (
	^true
)
public mapping = (
	^outer BrazilMappingForWin32 agentFactory
)
public modifierKeyStateForCurrentEvent = (
	^modifierKeyStateForCurrentEventX ifNil: [ModifierKeyState new]
)
public mousePoint ^<Point> = (
	| api |
	api:: outer BrazilMappingForWin32 api.
	^api POINT newC freeAfter:
		[:point | | result |
		result:: api GetCursorPos unsignedValue: point address.
		result = 0
			ifTrue:
				[api reportError: 'GetCursorPos() failed'.
				0 @ 0]
			ifFalse:
				[point asPoint]]
)
public noticeChangeInChildAgentStructure = (
)
public resetForContinuingImageSession = (
	desktop windows copy do: [:window |
		window agent destroy.
	].
	windowsSession resetForContinuingImageSession.
)
public scheduleUIAction: action <[]> = (
	NsFFISessionManager soleInstance scheduleDeferredAction: action
)
public scheduleUIInstallment: action <[]> = (
	NsFFISessionManager soleInstance scheduleDeferredInstallment: action
)
public setDraggedImage: image <Form> = (
	windowsSession placeDragCue: image at: mousePoint
)
setFingerCursor = (
	(* Unimplemented. *)
	#BOGUS yourself
)
setLeftRightCursor = (
	(* Unimplemented. *)
	#BOGUS yourself
)
public setModifierKeyState: state <ModifierKeyState> while: action <Block> = (
	| oldValue |
	oldValue:: modifierKeyStateForCurrentEventX.
	modifierKeyStateForCurrentEventX:: state.
	^action ensure: [modifierKeyStateForCurrentEventX:: oldValue]
)
setNormalCursor = (
	(* Unimplemented. *)
	#BOGUS yourself
)
setWaitCursor = (
	(* Unimplemented. *)
	#BOGUS yourself
)
systemIsIdle = (
	| now |
	now:: Time millisecondClockValue.
	^(now - windowsSession lastActivity) > 300000
		and: [(now - WorldState currentEvent timeStamp) > 300000]
)
public updateDraggedImagePosition = (
	windowsSession moveDragCueTo: mousePoint
)
usableDesktopBounds ^<Rectangle> = (
	(* Answer the area of the screen excluding the task bar. *)

	^windowsSession systemMetrics workArea
)
public windowAtPoint: point <Point> ^<Window | nil> = (
	| pointStruct hwnd |
	pointStruct:: api POINT new initializeFromPoint: point.
	hwnd:: api WindowFromPoint unsignedValue: pointStruct.
	hwnd = 0 ifTrue: [^nil].
	hwnd:: api GetAncestor unsignedValue: hwnd value: api GA_ROOT.
	hwnd = 0 ifTrue: [^nil].
	^desktop windows
		detect: [:some | some agent handle = hwnd]
		ifNone: [nil]
)
) : (
public desktop: desktop = (
	^DesktopAgent new desktop: desktop
)
)
class EllipseShapeAgent forVisual: v <EllipseShape> = BoxShapeAgent forVisual: v (
(* Specializes the superclass to paint an ellipse when needed. *)
) (
paintShapeOn: hdc <Integer> in: boundingBox <Rectangle> = (
	(* Cannot fill with a gradient in GDI. *)
	setupFillBrushIn: hdc while:
		[setupOutlinePenIn: hdc while:
			[api Ellipse
				value: hdc
				value: boundingBox left
				value: boundingBox top
				value: boundingBox right
				value: boundingBox bottom]]
)
) : (
)
class HyperlinkAgent forVisual: visual = ActiveLabelAgent forVisual: visual (
(* Represents Brazil Hyperlinks. For now we are handling these as soft widgets because the story of Windows command link buttons and syslink widgets is unclear. *)
|
	state ::= hyperlinkAgentStates NormalState forAgent: self.
	isTrackingButtonPress ::= false.
|) (
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point>
= (
	(* This is the painting workhorse. The hdc is already configured with colors and other settings appropriate for the visual, and the box contains a DC-relative rectangle describing the bounds of the visual. *)
	super
		contributeToWM_PAINTOn: hdc
		inside: parentRelativeUpdateRect
		translatedBy: parentOrigin.
	state shouldShowUnderline ifTrue:
		[paintUnderlineOn: hdc inside:
			(visual bounds translateBy: parentOrigin)].
)
enterState: stateClass = (
	state:: stateClass forAgent: self.
	invalidate
)
protected paintUnderlineOn: hdc <Integer> inside: box <Rectangle> = (
	| right bottom pen oldPen |
	bottom:: box top + naturalExtent y - 1 min: box bottom.
	right:: box left + naturalExtent x min: box right.
	pen:: api CreatePen
		unsignedValue: 0 (* PS_SOLID *)
		value: 1
		value: state color asColorref.
	oldPen:: api SelectObject value: hdc value: pen.
	api MoveToEx
		value: hdc value: box left value: bottom value: 0.
	api LineTo
		value: hdc value: right value: bottom.
	api SelectObject value: hdc value: oldPen.
	api DeleteObject value: pen.
)
public processMouseDownLeft = (
	isTrackingButtonPress:: true.
	enterState: hyperlinkAgentStates PressedState.
	visual dragTracker ifNotNil: [:it | it respondToMouseDown].
)
public processMouseEntry = (
	(* #processMouseMove will take care of changing states. *)
)
public processMouseExit = (
	enterState: hyperlinkAgentStates NormalState.
)
public processMouseMove = (
	isTrackingButtonPress
		ifTrue:
			[visual containsMouse
				ifTrue: [state isPressed ifFalse: [enterState: hyperlinkAgentStates PressedState]]
				ifFalse: [state isNormal ifFalse: [enterState: hyperlinkAgentStates NormalState]]]
		ifFalse:
			[state isHover ifFalse: [enterState: hyperlinkAgentStates HoverState]].
	visual dragTracker ifNotNil: [:it | it respondToMouseMove]
)
public processMouseUpLeft = (
	| wasDragInProgress |
	isTrackingButtonPress:: false.
	wasDragInProgress:: false.
	visual dragTracker notNil ifTrue:
		[(* The tracker must always be sent #respondToMouseUp
		so that it gets a chance to reset itself and release the mouse focus. *)
		wasDragInProgress:: visual dragTracker isDragging.
		visual dragTracker respondToMouseUp].
	state respondToButtonRelease.
	enterState::
		visual containsMouse
			ifTrue: [hyperlinkAgentStates HoverState]
			ifFalse: [hyperlinkAgentStates NormalState]
)
protected selectProperColorInto: hdc <Integer> = (
	api SetTextColor value: hdc value: state color asColorref.
)
) : (
)
class HyperlinkAgentStateClasses = (
(* This is a nested module containing the classes used internally by HyperlinkAgent,  to avoid creating unique class instances for each agent instance. *)
) (
class AgentState forAgent: theAgent = (
(* The common superclass of all hyperlink agent states. *)
|
	agent = theAgent.
|) (
public isHover = (
	^false
)
public isNormal = (
	^false
)
public isPressed = (
	^false
)
public respondToButtonRelease = (
)
) : (
)
public class HoverState forAgent: theAgent = AgentState forAgent: theAgent (
(* Captures the behavior of the agent that in has when the mouse is hovering over it. *)
) (
public color ^<Color> = (
	^agent visual hoverColor
)
public isHover = (
	^true
)
public shouldShowUnderline ^<Boolean> = (
	^agent visual underlineHover
)
) : (
)
public class NormalState forAgent: theAgent = AgentState forAgent: theAgent (
(* Captures the behavior of the agent that in has when the mouse is not hovering over it. *)
) (
public color ^<Color> = (
	^agent visual color
)
public isNormal = (
	^true
)
public shouldShowUnderline ^<Boolean> = (
	^agent visual underlineNormal
)
) : (
)
public class PressedState forAgent: theAgent = AgentState forAgent: theAgent (
(* Captures the behavior of the agent that in has when the left mouse button is held down over it. *)
) (
public color ^<Color> = (
	^agent visual downColor
)
public isPressed = (
	^true
)
public respondToButtonRelease = (
	agent visual doAction
)
public shouldShowUnderline ^<Boolean> = (
	^agent visual underlineHover
)
) : (
)
) : (
)
class ImageAgent forVisual: visual = NullAgent forVisual: visual (
(* Handles the Icon visual. *)
) (
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual imageA to: [:newImage | invalidate] (* Change of bounds is handled by the visual itself and by matchVisualsBounds implemented by the superclass. However, we do need to invalidate because the new image may have the same bounds as the old, in which case no layout update and bounds change will be triggered. *)
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	| windowRelativeBounds |
	(visual visible and: [visual bounds intersects: parentRelativeUpdateRect]) ifTrue:
		[windowRelativeBounds:: visual bounds translateBy: parentOrigin.
		paintOn: hdc inside: windowRelativeBounds]
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	invalidate
)
paintOn: hdc inside: windowRelativeBounds = (
	| graphics |
	graphics:: windowsSession gdiPlus Graphics fromHDC: hdc.
	[paintUsing: graphics inside: windowRelativeBounds]
		ensure: [graphics release]
)
paintUsing: graphics inside: windowRelativeBounds = (
	| squeakImage extent bitmap result |
	squeakImage:: visualImage.
	squeakImage isNil ifTrue: [^self].
	extent:: squeakImage extent.
	bitmap:: windowsSession imageMapper map: squeakImage forGraphics: graphics.
	result:: graphics
		drawImage: bitmap
		at: windowRelativeBounds center - (extent // 2).
	result = 0 ifFalse: ['DrawImage() failed'].
)
visualImage ^<Form | nil> = (
	(* Answer the image to use for displaying the visual at this moment. Active images redefine this to take into account the current interaction state. *)
	^visual image
)
) : (
)
class LabelAgent forVisual: v = NullAgent forVisual: v (
(* Handles the Label visuals. This agent does not create a Windows control and instead contributes to WM_PAINT messages to display its visual. The agent is also passive with respect to mouse input. *)
|
	private naturalExtent_
|) (
protected configureDC: hdc <Integer> around: action <Block> = (
	(* Configure the device context passed as the argument according to the current visual's properties. Evaluate the action block and then undo the changes to the DC. *)
	| oldMode |
	oldMode:: api SetBkMode unsignedValue: hdc value: 1. (* TRANSPARENT *)
	selectProperColorInto: hdc.
	selectProperFontInto: hdc.
	^action ensure:
		[api SetBkMode unsignedValue: hdc value: oldMode]
)
public connectOwnArtifacts = (
	map: visual textA to: self ~ #matchVisualsText:.
	map: visual colorA to: self ~ #matchVisualsColor:.
	super connectOwnArtifacts
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point>
= (
	| windowRelativeBounds |
	(visual visible
		and: [visual bounds intersects: parentRelativeUpdateRect])
		ifTrue:
			[windowRelativeBounds:: visual bounds translateBy: parentOrigin.
			configureDC: hdc around:
				[paintOn: hdc inside: windowRelativeBounds]]
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	invalidate
)
public flushLayoutCaches = (
	naturalExtent_:: nil
)
getDCWhile: action <Block> ifNotMapped: unmappedAction <Block> = (
	| hwnd hdc |
	hwnd:: windowHandle.
	hwnd isNil ifTrue: [^unmappedAction value].
	hdc:: api GetDC unsignedValue: hwnd.
	hdc = 0 ifTrue: [api reportError: 'GetDC() failed'].
	^[action value: hdc] ensure:
		[api ReleaseDC value: hwnd value: hdc]
)
public matchVisualsColor: newColor <Color> = (
	invalidate
)
public matchVisualsText: newText <Color> = (
	invalidate.
	flushLayoutCaches.
	invalidate
)
measureLabelUsing: hdc <Integer> ^<Point> = (
	| text result |
	text:: visual text asString.
	selectProperFontInto: hdc.
	^api POINT newC freeAfter:
		[:sizeBuffer |
		result:: api GetTextExtentPoint32
			unsignedValue: hdc
			value: (UnsafeAlien forPointerTo: text)
			value: text size
			value: sizeBuffer address.
		result = 0 ifTrue: [api reportError: 'GetTextExtentPoint32() failed'].
		sizeBuffer asPoint]
)
public naturalExtent ^<Point> = (
	naturalExtent_ isNil ifTrue:
		[getDCWhile:
			[:hdc |
			naturalExtent_:: measureLabelUsing: hdc]
		ifNotMapped:
			[^0@0]].
	^naturalExtent_
)
protected paintOn: hdc <Integer> inside: box <Rectangle> = (
	(* This is the painting workhorse. The hdc is already configured with colors and other settings appropriate for the visual, and the box contains a DC-relative rectangle describing the bounds of the visual. *)
	| visualsText success |
	visualsText:: visual text asString.
	(Alien newCString: visualsText) freeAfter:
		[:buffer |
		success:: api TextOut
			boolValue: hdc
			value: box left
			value: box top
			value: buffer address
			value: visualsText size].
	success ifFalse: [api reportError: 'TextOut() failed']
)
protected selectProperColorInto: hdc <Integer> = (
	api SetTextColor value: hdc value: visual color asColorref.
)
protected selectProperFontInto: hdc <Integer> = (
	| hfont |
	hfont:: windowsSession fontMapper handleForFont: visual font.
	api SelectObject value: hdc value: hfont.
)
) : (
)
class LineShapeAgent forVisual: v <Visual> = NullAgent forVisual: v (
(* Maps LineShapes. *)
) (
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual colorA to: [:ignored | invalidate].
	map: visual widthA to: [:ignoder | invalidate].
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	(needsPaintingRect: parentRelativeUpdateRect) ifTrue:
		[ | from to pen oldPen |
		from: visual area startPoint + parentOrigin.
		to: visual area endPoint + parentOrigin.
		pen:: api CreatePen
			unsignedValue: 0 (* PS_SOLID *)
			value: visual width
			value: visual color asColorref.
		oldPen:: api SelectObject
			value: hdc value: pen.
		api MoveToEx
			value: hdc value: from x value: from y value: 0.
		api LineTo
			value: hdc value: to x value: to y.
	api SelectObject value: hdc value: oldPen.
	api DeleteObject value: pen].
)
public findConsumerForMouseEventAt: point <Point> ^<Agent | nil> = (
	(* This implementation means lines are not interactive. To add interactivity, the agent will have to test the point for being on the line rather than within the bounding rectangle of the visual. *)
	^nil
)
needsPainting ^<Boolean> = (
	^visual visible
		and: [visual color notNil
		and: [visual color asColor isTransparent not]]
)
needsPaintingRect: parentRelativeRect <Rectangle> = (
	^needsPainting
		and: [visual bounds intersects: parentRelativeRect]
)
) : (
)
class ListBoxAgent forVisual: visual = WindowControlAgent forVisual: visual (
(* This is the Win32 agent representing a ListBox Brazil widget. *)
) (
public connectOwnArtifacts = (
	map: visual showHScrollbarA to: self ~ #matchHScrollbarStateFromVisual:.
	map: visual showVScrollbarA to: self ~ #matchVScrollbarStateFromVisual:.
	map: visual objectsHolder to: self ~ #matchListFromVisual:.
	map: visual selectionIndexHolder to: self ~ #matchSelectionIndexFromVisual:.
	(* For the reverse mapping of the selection index, see #processNotification. *)
	super connectOwnArtifacts.
)
controlClassName ^<String> = (
	^'LISTBOX'
)
public dwExStyle = (
	^api WS_EX_CLIENTEDGE
)
public dwStyle = (
	(* The control styles here determine what the control looks like. *)
	^api WS_CHILD
	| api WS_VISIBLE
	| api LBS_HASSTRINGS
	| api LBS_NOTIFY
	| api LBS_NOINTEGRALHEIGHT
	| verticalScrollbarBits
	| horizontalScrollbarBits
)
horizontalScrollbarBits ^<Integer> = (
	(* Return window style bits that select horizontal scroll bar appearance matching that requested by the visual. *)
	^visual showHScrollbar
		ifNil: (* show only when needed, which windows does by default *)
			[api WS_HSCROLL]
		ifNotNil:
			[:doShowAlways |
			doShowAlways
				ifTrue: [api WS_HSCROLL | api LBS_DISABLENOSCROLL]
				ifFalse: [0]]
)
matchHScrollbarStateFromVisual: newState <Boolean | nil> = (
	setWindowStyle:
		horizontalScrollbarBits
		| (getWindowStyle bitClear: api WS_HSCROLL).
)
matchListFromVisual: objects <Collection[objects]> = (
	| strings maxSize buffer |
	strings:: visual objectsAsStrings.
	sendMessage: api LB_RESETCONTENT wParam: 0 lParam: 0.
	maxSize:: strings inject: 0 into: [:max :each | max max: each size].
	strings size > 100 ifTrue:
		[sendMessage: api LB_INITSTORAGE wParam: strings size lParam: maxSize + 1].
	buffer:: Alien rawNewC: maxSize + 1.

	strings do:
		[:each |
		buffer
			replaceFrom: 1 to: each size with: each startingAt: 1;
			unsignedByteAt: each size + 1 put: 0.
		sendMessage: api LB_ADDSTRING wParam: 0 lParam: buffer address.
		].

	buffer free.
	shouldTrackHorizontalScrollRange ifTrue:
		[setHorizontalScrollRangeFor: strings]
)
matchSelectionIndexFromVisual: index1based <Integer> = (
	sendMessage: api LB_SETCURSEL
		wParam: index1based - 1
		lParam: 0
)
matchVScrollbarStateFromVisual: newState <Boolean | nil> = (
	setWindowStyle:
		verticalScrollbarBits
		| (getWindowStyle bitClear: api WS_VSCROLL).
)
protected measureMaxWidthOfStringIn: strings <Collection[String]> = (
	^getDCWhile:
		[:hdc | | maxWidth |
		maxWidth:: 0.
		selectControlFontInto: hdc.
		api POINT newC freeAfter:
			[:sizeBuffer |
			strings do:
				[:each | | result |
				result:: api GetTextExtentPoint32
					unsignedValue: hdc
					value: (UnsafeAlien forPointerTo: each)
					value: each size
					value: sizeBuffer address.
				result = 0 ifTrue: [^api reportError: 'GetTextExtentPoint32() failed'].
				maxWidth:: maxWidth max: sizeBuffer x]].
		maxWidth]
	ifNotMapped: [0]
)
naturalExtent = (
	flag: #BOGUS.
	^100 @ 25
)
public processCommand: code <Integer> ^<Integer> = (
	api LBN_SELCHANGE = code ifTrue:
		[respondToSelectionChange. ^0].
	api LBN_DBLCLK = code ifTrue:
		[respondToDoubleClick. ^0].
	^0
)
respondToDoubleClick = (
	visual doubleClickAction ifNotNil: [:it | it value]
)
respondToSelectionChange = (
	(* Selection index coming from Windows is 0-based and -1 means
	no selection. The index we use is 1-based and 0 means no selection.
	So, simply adding 1 to the value from Windows keeps everyone happy. *)
	| index |
	index:: sendMessage: api LB_GETCURSEL wParam: 0 lParam: 0.
	visual selectionIndexHolder acceptValueFromMapping: index + 1
)
setHorizontalScrollRangeFor: strings = (
	| maxWidth |
	maxWidth:: measureMaxWidthOfStringIn: strings.
	sendMessage: api LB_SETHORIZONTALEXTENT
		wParam: maxWidth
		lParam: 0
)
shouldTrackHorizontalScrollRange ^<Boolean> = (
	(* In Windows, we must explicitly measure the maximum width required by a list box in order for the horizontal scrollbar to work. This method figures out if we should do that, which is the case if the horizontal scrollbar is displayed always (true) or shown automatically (nil). *)
	^visual showHScrollbar ~~ false
)
verticalScrollbarBits ^<Integer> = (
	(* Return window style bits that select vertical scroll bar appearance matching that requested by the visual. *)
	^visual showVScrollbar
		ifNil: (* show only when needed, which windows does by default *)
			[api WS_VSCROLL]
		ifNotNil:
			[:doShowAlways |
			doShowAlways
				ifTrue: [api WS_VSCROLL | api LBS_DISABLENOSCROLL]
				ifFalse: [0]]
)
) : (
)
class MenuAgent menu: menu <Menu> = (
(* Maps a Menu to a Windows pop-up menu. *)
|
	protected menu_ = menu.
	protected menuHandle ::= 0.
	protected itemsById
|) (
buildMenuArtifactIfNeeded = (
	| builder |
	menuHandle = 0 ifTrue:
		[builder:: MenuBuilder new.
		menuHandle:: builder buildFrom: menu_.
		itemsById:: builder itemsById]
)
protected captureModifierKeyState: eventInputState while: action = (
	^menu ownerVisual desktop
		ifNotNil:
			[:it | it agent setModifierKeyState: eventInputState while: action]
		ifNil:
			[action value]
)
createCurrentModifierKeyState = (
	| getKeyState |
	getKeyState:: api GetKeyState.
	^ModifierKeyState new
		shiftPressed: (getKeyState unsignedValue: api VK_SHIFT) > 1;
		controlPressed: (getKeyState unsignedValue: api VK_CONTROL) > 1;
		altPressed: (getKeyState unsignedValue: api VK_MENU) > 1.
	(* Must check for the state to be > 1 rather than just ~= 0 because it appears that all keys are considered by Windows to be toggles, so the lowest bit of something like Shift alternates between 0 and 1 as the key is pressed. *)
)
menu ^<Menu> = (
	^menu_
)
public openAt: topLeftCorner <Point> = (
	| selectedItemId |
	buildMenuArtifactIfNeeded.
	menuHandle = 0 ifTrue: [^self].
	selectedItemId:: api TrackPopupMenu unsignedValueWithArguments: {
		menuHandle.
		api TPM_RETURNCMD | api TPM_NONOTIFY.
		topLeftCorner x.
		topLeftCorner y.
		0. (* nReserved *)
		windowHandle.
		0}.
	selectedItemId = 0 ifFalse:
		[captureModifierKeyState: createCurrentModifierKeyState while:
			[(itemsById at: selectedItemId) action value]]
)
respondToMenuChange = (
	menuHandle:: 0
)
windowHandle ^<Integer> = (
	^menu ownerVisual window agent handle
)
) : (
)
class MenuBuilder = (
(* An instance of this class is used to build a Windows menu from a Brazil counterpart. *)
|
	handleStack <List> = List new.
	public itemsById <Map> = Map new.
	nextAvailableId <Integer> ::= 10000.
|) (
public buildFrom: menu <Menu> ^<Integer> = (
	(* Build a native menu from the Brazil menu passed as the argument and answer the handle of the new native menu. *)
	pushNewMenuHandle.
	menu dispatchTo: self.
	^popMenuHandle
)
public buildMenuBarFrom: menu <Menu> ^<Integer> = (
	(* Build a native menu bar (which is not the same in Windows as a popup menu) from the Brazil menu passed as the argument and answer the handle of the new native menu. *)
	pushNewMenuBarHandle.
	menu dispatchTo: self.
	^popMenuHandle
)
flagsForMenuItem: item <MenuItem> ^<Integer> = (
	^item enabled
		ifTrue: [api MF_ENABLED]
		ifFalse: [api MF_DISABLED | api MF_GRAYED]
)
public handle ^<Integer> = (
	^handleStack isEmpty
		ifTrue: [0]
		ifFalse: [handleStack last]
)
isMenuBuilt ^<Boolean> = (
	^handle ~= 0
)
protected popMenuHandle = (
	^handleStack removeLast.
)
protected pushNewMenuBarHandle = (
	| newHandle |
	newHandle:: api CreateMenu unsignedValue.
	newHandle = 0 ifTrue: [^api reportError: 'CreateMenu() failed'].
	handleStack addLast: newHandle.
)
protected pushNewMenuHandle = (
	| newHandle |
	newHandle:: api CreatePopupMenu unsignedValue.
	newHandle = 0 ifTrue: [^api reportError: 'CreatePopupMenu() failed'].
	handleStack addLast: newHandle.
)
public visitMenuItem: item <MenuItem> = (
	item visible ifTrue:
		[ | result |
		(Alien newCString: item label) freeAfter:
			[:label |
			result:: api AppendMenu
				value: handle
				value: (flagsForMenuItem: item)
				value: nextAvailableId
				value: label address].
		result = 0 ifTrue: [api reportError: 'AppendMenu() failed'].
		itemsById at: nextAvailableId put: item.
		nextAvailableId: nextAvailableId + 1]
)
public visitSeparatorItem: separator <SeparatorItem> = (
	| result |
	result:: api AppendMenu
		value: handle
		value: api MF_SEPARATOR
		value: nextAvailableId
		value: 0.
	result = 0 ifTrue: [api reportError: 'AppendMenu() failed'].
	itemsById at: nextAvailableId put: separator.
	nextAvailableId: nextAvailableId + 1.
)
public visitSubmenuItem: item <SubmenuItem> = (
	| submenuHandle result |
	pushNewMenuHandle.
	item submenu dispatchTo: self.
	submenuHandle: popMenuHandle.
	(Alien newCString: item label) freeAfter:
		[:label |
		result:: api AppendMenu
			value: handle
			value: api MF_POPUP
			value: submenuHandle
			value: label address].
	result = 0 ifTrue: [api reportError: 'AppendMenu() failed'].
)
) : (
)
class NullAgent forVisual: visual = Agent forVisual: visual (
(* This is an agent of a visual that does not map to a Windows artifact. Its important feature is that the #handle it reports upon request is the handle of the parent, so that any descendents can obtain the handle of the window artifact they belong to. *)
|
	lastMouseEventConsumer
|) (
public connectArtifactsOfChild: childAgent <BrazilMappingAgent> = (
	parent connectArtifactsOfChild: childAgent
)
public createOwnArtifacts = (
	(* Nothing to do. *)
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	invalidate
)
public findConsumerForMouseEventAt: point <Point> ^<Agent | nil> = (
	| pointRelativeToSelf |
	(visual bounds containsPoint: point) ifFalse: [^nil].
	pointRelativeToSelf:: point translateBy: visual origin negated.
(* The following causes links and other things in a disclosure composer to not respond to mouse input after being expanded, if the links in two states overlap. (Events are stolen by the instance lingering in lastMouseEventConsumer.) *)
(*	lastMouseEventConsumer notNil ifTrue:
		[(lastMouseEventConsumer
			findConsumerForMouseEventAt: pointRelativeToSelf)
				ifNotNil: [:it | ^it]]. *)
	childrenReverseDo:
		(* We must go in reverse so that the topmost (last) child has the first say. *)
		[:each |
		(each findConsumerForMouseEventAt: pointRelativeToSelf)
			ifNotNil:
				[:consumer |
				lastMouseEventConsumer: each.
				^consumer]].
	^self
)
public handle ^<Integer> = (
	^parent handle
)
public isNull ^<Boolean> = (
	^true
)
matchVisualsBounds = (
	(* Nothing to do here; bounds change end continuation will do all the work. *)
)
public noteBeginningOfBoundsChangeAndProvideEndContinuation = (
	areBoundsChanging: true.
	^areBoundsInAncestorsChanging
		ifTrue: (* they will take care of invalidation *)
			[[areBoundsChanging: false]]
		ifFalse:
			[ | originalBounds |
				originalBounds: visual bounds.
			[parent ifNotNil: [:it | it invalidateRectangle: originalBounds].
			 invalidate.
			 areBoundsChanging: false]]
)
) : (
)
class NullColoredAgent forVisual: v = NullAgent forVisual: v (
(* Maps container visuals that have a colored background. *)
) (
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual colorA to: [:ignoredNewColor | invalidate]
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	(needsPaintingRect: parentRelativeUpdateRect) ifTrue:
		[ | rectToPaint |
		rectToPaint:: visual bounds intersect: parentRelativeUpdateRect.
		(isColor: visual color)
			ifTrue: [paintSolid: rectToPaint on: hdc translatedBy: parentOrigin]
			ifFalse: [paintGradient: rectToPaint on: hdc translatedBy: parentOrigin]].
	super
		contributeToWM_PAINTOn: hdc
		inside: parentRelativeUpdateRect
		translatedBy: parentOrigin
)
protected isColor: color = (
	^color yourself asColor == color yourself
)
needsPainting ^<Boolean> = (
	^visual visible
		and: [visual color notNil
		and: [visual color asColor isTransparent not]]
)
needsPaintingRect: parentRelativeRect <Rectangle> = (
	^needsPainting
		and: [visual bounds intersects: parentRelativeRect]
)
paintGradient: rectToPaint on: hdc <Integer> translatedBy: parentOrigin <Point> = (
	fillRectangle: (visual bounds translateBy: parentOrigin)
	on: hdc
	withGradient: visual color.
)
paintSolid: rectToPaint on: hdc <Integer> translatedBy: parentOrigin <Point> = (
	fillRectangle: (rectToPaint translateBy: parentOrigin)
	on: hdc
	withSolidColor: visual color.
)
) : (
)
class PolygonShapeAgent forVisual: v <PolygonShape> = BoxShapeAgent forVisual: v (
(* Represents Brazil PolygonShape by painting them inside the host window. A polygon isn't really a box shape, but the some of the inherited behavior is useful. *)
) (
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	(needsPaintingRect: parentRelativeUpdateRect) ifTrue:
		[paintShapeOn: hdc translatedBy: parentOrigin].
)
private hostRelativeVerticesTranslatedBy: parentOrigin = (
	^visual area vertices collect: [:each | each + parentOrigin]
)
paintShapeOn: hdc <Integer> translatedBy: parentOrigin <Point> = (
	setupFillBrushIn: hdc while:
		[setupOutlinePenIn: hdc while:
			[ | vertices pointSize cVertices address |
			vertices:: hostRelativeVerticesTranslatedBy: parentOrigin.
			pointSize: api POINT dataSize.
			cVertices:: Alien rawNewC: vertices size * pointSize.
			address: cVertices address.
			vertices do:
				[:vertex |
				(api POINT atAddress: address)
					initializeFromPoint: vertex.
				address: address + pointSize].
			api Polygon
				value: hdc
				value: cVertices address
				value: vertices size.
			cVertices free]]
)
) : (
)
class RectangleShapeAgent forVisual: v <RectangeShape> = BoxShapeAgent forVisual: v (
(* Specializes the superclass to paint a rectangle when needed. *)
) (
paintGradientShapeOn: hdc <Integer> in: boundingBox <Rectangle> = (
	fillRectangle: boundingBox on: hdc withGradient: visual color.
	setupNullBrushIn: hdc while:
		[setupOutlinePenIn: hdc while:
			[api Rectangle
				value: hdc
				value: boundingBox left
				value: boundingBox top
				value: boundingBox right
				value: boundingBox bottom]]
)
paintShapeOn: hdc <Integer> in: boundingBox <Rectangle> = (
	(isColor: visual color)
		ifTrue: [paintSolidShapeOn: hdc in: boundingBox]
		ifFalse: [paintGradientShapeOn: hdc in: boundingBox]
)
paintSolidShapeOn: hdc <Integer> in: boundingBox <Rectangle> = (
	setupFillBrushIn: hdc while:
		[setupOutlinePenIn: hdc while:
			[api Rectangle
				value: hdc
				value: boundingBox left
				value: boundingBox top
				value: boundingBox right
				value: boundingBox bottom]]
)
) : (
)
class RichEditControlAgent forVisual: visual = WindowControlAgent forVisual: visual (
(* The abstract superclass of agents that map to Rich Edit controls, such as text views and text displays. Implements the bulk of the machinery that has to do with measuring text extent. *)
|
	protected cachedNaturalExtent
	protected cachedNaturalHeightWidth
	protected cachedNaturalHeightForWidth
	protected knownControlContents <String> ::= ''.
|) (
clearEventMaskBits: bitsToClear <Integer> = (
	| eventMask |
	eventMask:: sendMessage: api EM_GETEVENTMASK wParam: 0 lParam: 0.
	sendMessage: api EM_SETEVENTMASK
		wParam: 0
		lParam: (eventMask bitClear: bitsToClear).
)
protected computeNaturalExtentOrIfUnmapped: aBlock <Block> ^<Point> = (
	| originalWidth presumedWidth answer |
	flag: #BOGUS. (* Should measure width by gradually narrowing it down. *)
	handle isNil ifTrue: [^aBlock value].
	originalWidth:: currentBounds width.
	flag: #BOGUS. (* The following addition of 18 is a hack due to text extent notification arriving before a new character has been added. (No nice way to do it right *after* the character has been processed. *)
	presumedWidth:: measureWidth + 18.
	answer:: windowsSession textMeasurer
		measureText: visual text
		heightForWidth: presumedWidth.
	^presumedWidth @ answer + 10
)
protected computeNaturalHeightForWidth: width <Number> orIfUnmapped: aBlock <Block> ^<Number> = (
	(* for reasons yet unknown Windows doesn't request enough *)
	^(windowsSession textMeasurer
		measureText: visual text
		heightForWidth: width) + 10
)
public connectOwnArtifacts = (
	map: visual textA to: [:text | setControlText: text].
		(* Mapping the text before the super send, so that the 'visible'
		attribute is bound later. This avoids resizing flicker which would
		happen if the control were first displayed and then updated
		with the actual text. *)
	super connectOwnArtifacts.
)
controlClassName = (
	^'RICHEDIT20A'
)
public createOwnArtifacts = (
	windowsSession ensureRichEdit20Loaded.
	super createOwnArtifacts.
	setEventMaskBits:
		api ENM_CHANGE
		| api ENM_KEYEVENTS.
	(* setStandardTabStops. *)
	flag: #BOGUS. (* should do the above to lessen memory thrashing but UnsafeAlien needs fixing first to correctly wrap safe Aliens. *)
	setTabStops: ((1 to: 32) collect: [:i | i * 360]).
)
currentLineCharacterStart = (
	(* Returns the character index of the first character of the current line. *)

	^sendMessage: api EM_LINEINDEX
		wParam: currentLineIndex
		lParam: 0
)
currentLineIndex = (
	^sendMessage: api EM_LINEFROMCHAR
		wParam: -1  (* -1 tells windows to return which line the caret is on. *)
		lParam: 0.
)
currentLineLength = (
	^sendMessage: api EM_LINELENGTH
		wParam: currentLineCharacterStart  (* If set to -1, this returns the number of characters not selected *)
		lParam: 0.
)
currentLineRange ^<Array[Integer]> = (
	| start stop |
	start:: currentLineCharacterStart+1.
	stop:: start+currentLineLength.
	^{start. stop}
)
public dwExStyle = (
	^api WS_EX_CLIENTEDGE
)
public dwStyle = (
	^api WS_CHILD
	| api ES_MULTILINE
	| api ES_WANTRETURN
)
public flushLayoutCaches = (
	cachedNaturalExtent:: nil.
	cachedNaturalHeightWidth:: nil.
)
public hasUnacceptedEdits = (
	^true
)
ignoreEN_CHANGEWhile: action = (
	(* Disable delivery of ENM_CHANGE notifications while the block runs. *)
	clearEventMaskBits: api ENM_CHANGE.
	^action ensure:
		[setEventMaskBits: api ENM_CHANGE]
)
protected measureWidth = (
	^getDCWhile:
		[:hdc |
		measureWidthUsing: hdc]
	ifNotMapped:
		[0@0]
)
protected measureWidthUsing: hdc <Integer> = (
	| text result |
	text:: visual text asString.
	selectProperFontInto: hdc.
	api POINT newC freeAfter:
		[:sizeBuffer |
		result:: api GetTextExtentPoint32
			unsignedValue: hdc
			value: (UnsafeAlien forPointerTo: text)
			value: text size
			value: sizeBuffer address.
		result = 0 ifTrue: [^api reportError: 'GetTextExtentPoint32() failed'].
		result:: sizeBuffer asPoint].
	^result x
)
public naturalExtent ^<Point> = (
	^cachedNaturalExtent ifNil:
		[cachedNaturalExtent:: (computeNaturalExtentOrIfUnmapped: [^100@25]).
		cachedNaturalExtent]
)
public naturalHeightForWidth: width <Number> ^<Number> = (
	^cachedNaturalHeightWidth = width
		ifTrue:
			[cachedNaturalHeightForWidth]
		ifFalse:
			[ | height |
			height:: computeNaturalHeightForWidth: width orIfUnmapped: [^25].
			cachedNaturalHeightWidth: width.
			cachedNaturalHeightForWidth:: height.
			cachedNaturalHeightForWidth]
)
public processCommand: code <Integer> ^<Integer> = (
(* Process a control notification received by the parent window. The code argument is the notification code passed as the hiword of wParam. *)
	code = api EN_CHANGE ifTrue:
		[^processEN_CHANGE].
	^0
)
processEN_CHANGE = (
	| controlText <String> |
	controlText:: getWindowTextIfNone: [^0].
	(controlText size ~= knownControlContents size (* a quick test first *)
		or: [controlText ~= knownControlContents])
		ifTrue:
			[knownControlContents: controlText.
			visual acceptTextFromAgent: controlText].
	^0
)
processEN_MSGFILTER: lparam <NMHDR> ^<Integer> = (
	^0
)
public processNotification: code <Integer> data: lparam <NMHDR> ^<Integer> = (
(* Process a control notification received by the parent window. The code argument is the code from the NMHDR structure pointed to by the lparam. *)
	code = api EN_MSGFILTER ifTrue:
		[^processEN_MSGFILTER: lparam].
	^0
)
public reemphasizeText: text = (
	(* Sent by some visuals when the text is the same but its highlighting needs to be changed. *)
	text isText ifTrue: [setTextAttributesFrom: text].
)
public selectAll = (
	^selectFrom: 1 to: visual text size
)
public selectFrom: startIndex <Integer> to: endIndex <Integer> = (
	(* The indices are interpreted as Smalltalk 1-based indices into the displayed text. *)
	api CHARRANGE newC freeAfter:
		[:rangeBuffer |
		rangeBuffer
			cpMin: startIndex - 1;
			cpMax: endIndex.
		sendMessage: api EM_EXSETSEL
			wParam: 0
			lParam: rangeBuffer address].
)
protected selectProperFontInto: hdc <Integer> = (
	| hfont |
	hfont:: windowsSession fontMapper handleForFont: visual font.
	api SelectObject value: hdc value: hfont.
)
public selectedText ^<String> = (
	^withSelectionIndicesDo:
		[:min :max |
		visual text copyFrom: min to: (visual text size min: max)]
)
selectionRange ^<Array[Integer]> = (
	(* The indices follow the policy of the copyFrom:to: message: they are 1-based, and the end index is inclusive. IOW, an empty selection range at the beginning of the text is {1. 0} and the range that includes just the first character is {1. 1}. *)
	^withSelectionIndicesDo:
		[:min :max | {min.  max}]
)
protected setControlText: text <String | Text> = (
	flushLayoutCaches.
	knownControlContents: text asString.
	(Alien newCString: knownControlContents) freeAfter:
		[:buffer |
		sendMessage: api WM_SETTEXT wParam: 0 lParam: buffer address].
	text isText ifTrue: [setTextAttributesFrom: text].
	(* In Squeak, #isText is also true for XmlText. That is demented, but we are not supposed to get an xml text instance here. *)
	visual reportNaturalExtentChange.
)
setEventMaskBits: newBits <Integer> = (
	| eventMask |
	eventMask:: sendMessage: api EM_GETEVENTMASK wParam: 0 lParam: 0.
	sendMessage: api EM_SETEVENTMASK wParam: 0 lParam: eventMask | newBits.
)
setStandardTabStops = (
	(* SHOULD NOT BE USED until UnsafeAlien is fixed to correctly point to the data section when wrapping an Alien instance *)
	sendMessage: api EM_SETPARAFORMAT
		wParam: 0
		lParam: (UnsafeAlien forPointerTo: windowsSession paraformatWithStandardTabStops).
)
setTabStops: tabStops <Array[Integer]> = (
	(* Set the tab stops; each tab stop is an absolute position measured from the left edge and specified in twips (1440 twips = 1 inch). A maximum of 32 stops is allowed. *)
	| paraformat |
	tabStops size > 32 (* MAX_TAB_STOPS *) ifTrue: [error: 'too many tabstops'].
	paraformat:: api PARAFORMAT newC.
	paraformat
		dwMask: api PFM_TABSTOPS;
		cTabCount: tabStops size.
	tabStops keysAndValuesDo:
		[:index :each |
		paraformat rgxTabsAt: index put: each].
	sendMessage: api EM_SETPARAFORMAT wParam: 0 lParam: paraformat address.
	paraformat free.
)
protected setTextAttributesFrom: text <Text> = (
	ignoreEN_CHANGEWhile:
		[TextDecorator decorateControlWithHandle: handle accordingTo: text].
)
withSelectionIndicesDo: block <[:Integer Integer]> = (
	(* The indices follow the policy of the copyFrom:to: message: they are 1-based, and the end index is inclusive. IOW, an empty selection range at the beginning of the text is {1. 0} and the range that includes just the first character is {1. 1}. *)
	| min max |
	api CHARRANGE newC freeAfter:
		[:rangeBuffer |
		sendMessage: api EM_EXGETSEL
			wParam: 0
			lParam: rangeBuffer address.
		min:: rangeBuffer cpMin.
		max:: rangeBuffer cpMax].
	^block value: min + 1 value: max
)
) : (
)
class SensitiveImageAgent forVisual: v = ImageAgent forVisual: v (
(* Handles the SensitiveIcon Brazil visual. *)
) (
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
	^(visual bounds containsPoint: parentRelativePoint)
		ifTrue: [self]
		ifFalse: [nil]
)
public processMouseDownLeft = (
	visual respondToMouseDownLeft
)
public processMouseEntry = (
	visual respondToMouseEntry
)
public processMouseExit = (
	visual respondToMouseExit
)
public processMouseMove = (
	visual respondToMouseMove
)
public processMouseUpLeft = (
	visual respondToMouseUpLeft
)
) : (
)
class TextDecorator forControlWithHandle: handle = (
(* Warning: not for general consumption. This is a private class with the API kept at a low level, intended to be used internally by a number of other classes of the mapping.

Sets character formats of a RichEdit control to match a given Text instance. Instances of TextDecorator are normally single-use. The control to work with is specified at the instance creation time. The instance is then sent the #applyEmphasesFrom: message. It is assumed that the content of the control already match the content of the text and only the emphasis needs to be applied. *)
|
	protected controlHandle = handle.
	protected originalSelection <Array[Integer]>
	protected charformat <CHARFORMAT2>
	protected charrange <CHARRANGE>
|) (
protected applyEmphases: emphases <Array[TextAttribute]> from: start <Integer> to: stop <Integer> = (
	| result |
	selectFrom: start - 1
		to: stop. (* inclusive in Squeak, exclusive in Windows - no change *)
	translateToCharformat: emphases.
	result:: sendMessage: api EM_SETCHARFORMAT
		wParam: 1 (* SCF_SELECTION *)
		lParam: charformat address.
	result = 0 ifTrue: [api reportError: 'EM_SETCHARFORMAT failed'].
)
public applyEmphasesFrom: text <Text> = (
	(* This is the main entry point. Note that the application of emphases will trigger a large number of EN_CHANGE notifications. The sender should probably take steps to disable those before sending this message, and reenable them later. *)
	Alien autoFreeAfter:
		[:free |
		charformat:: free value: api CHARFORMAT2 newC.
		charrange:: free value: api CHARRANGE newC.
		saveSelectionRange.
		setRedraw: false.
		clearExistingEmphases.
		text runs withStartStopAndValueDo:
			[:start :stop :emphases |
			applyEmphases: emphases from: start to: stop].
		restoreSelectionRange.
		setRedraw: true.
		invalidate].
)
protected clearExistingEmphases = (
	charformat
		dwMask: api CFM_BOLD | api CFM_ITALIC | api CFM_UNDERLINE | api CFM_COLOR;
		dwEffects: api CFE_AUTOCOLOR.
	sendMessage: api EM_SETCHARFORMAT
		wParam: 4 (* all *)
		lParam: charformat address.
)
invalidate = (
	api InvalidateRect value: controlHandle value: 0 value: 0
)
protected restoreSelectionRange = (
	selectFrom: (originalSelection at: 1) to: (originalSelection at: 2)
)
protected saveSelectionRange = (
	sendMessage: api EM_EXGETSEL
		wParam: 0
		lParam: charrange address.
	originalSelection: {charrange cpMin. charrange cpMax}.
)
protected selectFrom: startIndex to: stopIndex = (
	| result |
	charrange
		cpMin: startIndex;
		cpMax: stopIndex.
	result:: sendMessage: api EM_EXSETSEL
		wParam: 0
		lParam: charrange address.
	(* result = 0 ifTrue: [api reportError: 'EM_EXSETSEL failed']. *)
)
protected sendMessage: id <Integer> wParam: wParam <Integer> lParam: lParam <Integer> = (
	^api SendMessage
		unsignedValue: controlHandle
		value: id
		value: wParam
		value: lParam
)
protected setRedraw: state <Boolean> = (
	(* Enables or disables redrawing of the control. When redrawing is disabled, the control is not repainted to reflect selection and attribute changes. In that case, we must explicitly invalidate it after we are done. *)
	sendMessage: api WM_SETREDRAW
		wParam: (state ifTrue: [1] ifFalse: [0])
		lParam: 0.
)
protected translateToCharformat: emphases <Array[TextAttribute]> = (
	(* Not bothering to make things nice, as we don't plan to rely on Squeak TextAttributes forever. *)
	charformat
		dwMask: 0;
		dwEffects: 0.
	emphases do:
		[:each |
		(each isKindOf: TextColor) ifTrue:
			[charformat
				setDwMaskBits: api CFM_COLOR;
				crTextColor: each color asColorref.
			].
		(each isKindOf: TextEmphasis) ifTrue:
			[each emphasisCode = 1 (* bold *) ifTrue:
				[charformat
					setDwMaskBits: api CFM_BOLD;
					setDwEffectsBits: api CFE_BOLD.
				].
			each emphasisCode = 2 (* italic *) ifTrue:
				[charformat
					setDwMaskBits: api CFM_ITALIC;
					setDwEffectsBits: api CFE_ITALIC.
				].
			each emphasisCode = 4 (* underlined *) ifTrue:
				[charformat
					setDwMaskBits: api CFM_UNDERLINE;
					setDwEffectsBits: api CFE_UNDERLINE.
				]]]
)
) : (
public decorateControlWithHandle: handle <Integer> accordingTo: text <Text> = (
	(self forControlWithHandle: handle)
		applyEmphasesFrom: text
)
)
class TextDisplayAgent forVisual: visual = RichEditControlAgent forVisual: visual (
(* Responsible for materializing TextDisplays as native Windows RichEdit controls (read-only). *)
) (
public createOwnArtifacts = (
	super createOwnArtifacts.
	sendMessage: api EM_SHOWSCROLLBAR wParam: api SB_VERT lParam: 0.
	sendMessage: api EM_SHOWSCROLLBAR wParam: api SB_HORZ lParam: 0.
)
public dwExStyle = (
	^api WS_EX_TRANSPARENT
)
public dwStyle = (
	^super dwStyle
	| api ES_READONLY
)
) : (
)
class TextViewAgent forVisual: visual = RichEditControlAgent forVisual: visual (
(* Responsible for materializing TextViews as native Windows RichEdit controls. *)
|
	wmCharHook
	keydownHook
|) (
public dwStyle = (
	^super dwStyle
	| (visual suppressScrollbars
		ifTrue: [0]
		ifFalse: [api WS_VSCROLL])
)
enumerateLinesUsing: aBlock = (
	#BOGUS yourself. (* Real implementation needed. See TextViewMorphicAgent. *)
)
lineHeight = (
	#BOGUS yourself. (* Real implementation needed. See TextViewMorphicAgent. *)
	^0
)
processAcceptKeyThrough: msgfilter <MSGFILTER> = (
	(* Only getting WM_CHAR messages for Ctrl-S--no keydown or keyup. *)
	visual acceptKeyResponse isNil
		ifTrue:
			[textMayHaveChanged]
		ifFalse:
			[visual acceptKeyResponse value: [^0].
			^1].
	^0
)
processEN_MSGFILTER: lparam <NMHDR> ^<Integer> = (
	| msgfilter charCode |
	msgfilter:: api MSGFILTER atAddress: lparam address.
	charCode:: msgfilter wParam.
	charCode = (* enter *) 13 ifTrue:
		[^processEnterKeyThrough: msgfilter].
	charCode = (* escape *) 27 ifTrue:
		[^processEscapeKeyThrough: msgfilter].
	charCode = (* ctrl+s *) 19 ifTrue:
		[^processAcceptKeyThrough: msgfilter].
	(msgfilter msg = api WM_KEYDOWN and: [keydownHook notNil]) ifTrue:
		[(keydownHook value: charCode) ifTrue: [^1]].
	(msgfilter msg = api WM_CHAR and: [wmCharHook notNil]) ifTrue:
		[(wmCharHook value: charCode) ifTrue: [^1]].
	msgfilter msg = api WM_CHAR ifTrue:
		[textMayHaveChanged.
		textExtentMayHaveChanged].
	^0
	(* zero means process the event, non-zero--ignore it *)
)
processEnterKeyThrough: msgfilter <MSGFILTER> = (
	visual enterKeyResponse isNil
		ifTrue:
			[msgfilter msg = api WM_CHAR ifTrue: [textMayHaveChanged]]
		ifFalse:
			[msgfilter msg = api WM_KEYDOWN ifTrue:
				[visual enterKeyResponse value: [^0]].
			^1].
	^0
)
processEscapeKeyThrough: msgfilter <MSGFILTER> = (
	visual escapeKeyResponse isNil
		ifTrue:
			[msgfilter msg = api WM_CHAR ifTrue: [textMayHaveChanged]]
		ifFalse:
			[msgfilter msg = api WM_KEYDOWN ifTrue:
				[visual escapeKeyResponse value: [^0]].
			^1].
	^0
)
scrollToEnd = (
	api SCROLLINFO newC freeAfter:
		[:scrolllinfo |
		scrolllinfo fMask: api SIF_ALL.
		api GetScrollInfo
			value: handle
			value: api SB_VERT
			value: scrolllinfo address.
		api POINT newC freeAfter:
			[:point |
			point
				x: 0;
				y: scrolllinfo nMax - visual bounds height + 5.
			sendMessage: api EM_SETSCROLLPOS
				wParam: 0
				lParam: point address]]
)
public selectLine = (
	| start |
	start:: currentLineCharacterStart+1.
	selectFrom: start to: start+currentLineLength
)
selectionInterval = (
	| range |
	range:: selectionRange.
	^range first to: range second
)
textExtentMayHaveChanged = (
	visual reportNaturalExtentChange
)
textMayHaveChanged = (
	| controlText |
	controlText:: getWindowTextIfNone: [^self].
	(controlText size ~= knownControlContents size (* quick test first *)
		or: [controlText ~= knownControlContents])
		ifTrue:
			[knownControlContents: controlText.
			visual acceptTextFromAgent: controlText].
)
visibleLineCount = (
	#BOGUS yourself. (* This is incorrect, we should ask Windows for post-word-wrapping line count. *)
	^visual text lineCount
)
) : (
)
class VerticalViewportAgent forVisual: aVisual = ViewportAgent forVisual: aVisual (
(* Maps Brazil VerticalViewports. The difference between this and the superclass is in how the extent of the content is computed: because VerticalViewports squeeze the contents, their agents should size their inner windows according to the natural height of the content. *)
) (
setInnerWindowBounds = (
	| availableWidth requiredHeight newBounds |
	availableWidth:: visual innerExtent x.
	requiredHeight:: visual naturalHeightForWidth: availableWidth.
	newBounds::
		visual scrollPosition negated extent: availableWidth @ requiredHeight.
	innerAgent setWindowBounds: newBounds.
	(* Should also invalidate any exposed portion of the outer window
	to ensure no garbage is left over if the inner window has shrunk. *)
	newBounds bottom < visual innerExtent y ifTrue:
		[outerAgent invalidateRectangle:
			(0 @ newBounds bottom corner: visual innerBounds corner)].
)
) : (
)
class VerticalVisualSequenceAgent forVisual: v = NullColoredAgent forVisual: v (
(* Takes care of vertical visual sequences, most importantly to optimize their display by only painting those children that intersect the update rectangle. *)
) (
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	| myUpdateRect updateTop updateBottom myOrigin |
	(needsPaintingRect: parentRelativeUpdateRect) ifTrue:
		[ | rectToPaint |
		rectToPaint:: visual bounds intersect: parentRelativeUpdateRect.
		(isColor: visual color)
			ifTrue: [paintSolid: rectToPaint on: hdc translatedBy: parentOrigin]
			ifFalse: [paintGradient: rectToPaint on: hdc translatedBy: parentOrigin]].
	myUpdateRect:: parentRelativeUpdateRect
		translateBy: visual origin negated.
	updateTop:: myUpdateRect top.
	updateBottom:: myUpdateRect bottom.
	myOrigin:: parentOrigin + visual origin.
	childrenDo:
		[:each <Agent> | | eachBounds |
		eachBounds:: each visual bounds.
		eachBounds bottom > updateTop ifTrue:
			[eachBounds top > updateBottom ifTrue: [^self].
			each
				contributeToWM_PAINTOn: hdc
				inside: myUpdateRect
				translatedBy: myOrigin]]
)
) : (
)
class ViewportAgent forVisual: v = Agent forVisual: v (
(* Maps Brazil Viewport visuals. A visual is mapped to two windows: the outer one that provides scrollbars and manages scrolling and the inner one holding the actual content of the viewport. This allows to easily scroll the content by simply moving the inner window. *)
|
	protected innerAgent = InnerSubAgent inside: self.
	public outerAgent = OuterSubAgent inside: self.
	protected currentBounds
	private scrollbarHeightCached
	private scrollbarWidthCached
|) (
class InnerSubAgent inside: outerAgent <VewportAgent> = (
(* Manages the inner window of the viewport. *)
|
	private owner = outerAgent.
	public handle ::= 0.

	protected inputManager = WindowContentManager forAgent: outerAgent.
	protected messageDispatchTable = Map new.
	lastMS ::= 0.

	(* Capture this frequently used function locally for speed. *)
	protected apiInvalidateRect = api InvalidateRect.
	private backbuffer
	private backbufferSize
|populateDispatchTable) (
private bufferForSize: paintSize hdc: hdc = (
	(* Returns the retained backbuffer, growing it 2x as necessary *)

	backbuffer ifNil: [
		backbufferSize:: paintSize * 2.
		backbuffer:: compatibleBitmapFor: hdc size: backbufferSize.
		^backbuffer.
	].

	(backbufferSize y < (paintSize y) or: [backbufferSize x < (paintSize x)]) ifTrue: [
		api DeleteObject value: backbuffer.
		backbufferSize:: paintSize * 2.
		backbuffer:: compatibleBitmapFor: hdc size: backbufferSize.
	].

	^backbuffer.
)
compatibleBitmapFor: hdc size: size = (
	^api CreateCompatibleBitmap value: hdc value: size x value: size y
)
public createWindow = (
	windowsSession viewportContentCarrierWindowClass createWindowForAgent: self.
)
public destroyWindow = (
	handle ~= 0 ifTrue: [
		api DestroyWindow value: handle.
		api DeleteObject value: backbuffer.
		handle: 0
	]
)
public dwExStyle ^<Integer> = (
	^api WS_EX_TRANSPARENT
)
public dwStyle ^<Integer> = (
	(* We keep the window always visible because its effective visibility is handled by the outer window. *)
	^owner api WS_CHILD
	| owner api WS_VISIBLE
	| owner api WS_CLIPCHILDREN
	| owner api WS_CLIPSIBLINGS
)
public initialWindowBounds ^<Rectangle> = (
	^0 @ 0 extent: owner visual virtualExtent
)
public invalidateRectangle: rectangle <Rectangle> = (
	| expanded |
	(handle ~= 0 and: [rectangle hasPositiveExtent]) ifTrue:
		[expanded:: rectangle origin extent: rectangle extent + 1.
		owner api RECT newC freeAfter:
			[:rect |
			rect initializeFromRectangle: expanded.
			apiInvalidateRect value: handle value: rect address value: 0]]
)
invalidateWindow = (
	handle = 0 ifFalse:
		[apiInvalidateRect value: handle value: 0 value: 0]
)
public parentHandle ^<Integer> = (
	(* The handle to use as the parent window. *)
	^owner outerAgent handle ifNil: [error: 'no parent handle']
)
populateDispatchTable = (
	register: {self. #processWM_ERASEBKGND:}
		asHandlerFor: owner api WM_ERASEBKGND.
	register: {self. useDoubleBuffering
				ifTrue: [#processWM_PAINTDoubleBuffered:]
				ifFalse: [#processWM_PAINTUnbuffered:]}
		asHandlerFor: owner api WM_PAINT.

	register: {inputManager. #processWM_COMMAND:}
		asHandlerFor: owner api WM_COMMAND.
	register: {inputManager. #processWM_NOTIFY:}
		asHandlerFor: owner api WM_NOTIFY.
	register: {inputManager. #processWM_MOUSEMOVE:}
		asHandlerFor: owner api WM_MOUSEMOVE.
	register: {inputManager. #processWM_MOUSELEAVE:}
		asHandlerFor: owner api WM_MOUSELEAVE.
	register: {inputManager. #processWM_LBUTTONDOWN:}
		asHandlerFor: owner api WM_LBUTTONDOWN.
	register: {inputManager. #processWM_LBUTTONUP:}
		asHandlerFor: owner api WM_LBUTTONUP.
)
public processWM_ERASEBKGND: args <WindowProc> = (
	(* -- for layout debugging: fill the window with a loud obnoxious color -- *)
(*	| hdc hbrush |
	hdc:: args wParam.
	hbrush:: api CreateSolidBrush unsignedValue:
		NewspeakGlobalState Graphics Color yellow asColorref.
	hbrush = 0 ifTrue:
		[api reportError: 'CreateSolidBrush() failed'.
		^0].
	api RECT newC freeAfter:
		[:buffer | | ok |
		ok:: api GetClientRect unsignedValue: handle value: buffer address.
		api FillRect value: hdc value: buffer address value: hbrush]. *)
	(* -- end for layout debugging -- *)
	^1 (* erased *)
)
public processWM_PAINTDoubleBuffered: args <WindowProc> = (
	(* Handle the WM_PAINT request with double-buffering. *)
	(* ^processWM_PAINTUnbuffered: args *)

	| paintstruct paintSize hdc hdcMem hbmMem hOld |

	(* Begin paint *)
	paintstruct:: owner api PAINTSTRUCT newC.
	hdc:: owner api BeginPaint unsignedValue: handle value: paintstruct address.
	paintSize:: paintstruct paintRectangle extent.

	(* Create HDC for backbuffer *)
	hdcMem:: api CreateCompatibleDC value: hdc.
	hbmMem:: bufferForSize: paintSize hdc: hdc.
	hOld:: api SelectObject value: hdcMem value: hbmMem.

	(* Evaluate paint contributions *)
	owner
		contributeToInnerWM_PAINTOnBuffer: hdcMem
		inside: paintstruct paintRectangle.

	(* Blit backbuffer to HDC *)
	api BitBlt
		value: hdc
		value: paintstruct paintRectangle origin x value: paintstruct paintRectangle origin y
		value: paintSize x value: paintSize y
		value: hdcMem
		value: 0 value: 0
		value: owner api SRCCOPY.

	(* Wrap things up in reverse order. *)
	api SelectObject value: hdcMem value: hOld.
	api DeleteDC value: hdcMem.
	api EndPaint value: handle value: paintstruct address.
	paintstruct free.

	^0
)
public processWM_PAINTUnbuffered: args <WindowProc> = (
	| paintstruct hdc |
	paintstruct:: owner api PAINTSTRUCT newC.
	hdc:: owner api BeginPaint unsignedValue: handle value: paintstruct address.
	owner
		contributeToInnerWM_PAINTOn: hdc
		inside: paintstruct paintRectangle.
	owner api EndPaint value: handle value: paintstruct address.
	paintstruct free.
	^0
)
public processWindowsMessage: args <WindowProc> ^<Integer> = (
	| message handler |
	message:: args message.
	handler:: messageDispatchTable at: message ifAbsent: [^invokeDefWindowProc: args].
	^(handler at: 1) perform: (handler at: 2) with: args
)
register: receiverSelectorTuple asHandlerFor: messageCode <Integer> = (
	messageDispatchTable at: messageCode put: receiverSelectorTuple
)
public releaseMouseGrabFrom: agent <Agent> = (
	inputManager releaseMouseGrabFrom: agent
)
public resetForNewImageSession = (
	handle:: 0
)
public setMouseGrabTo: agent <Agent> = (
	inputManager setMouseGrabTo: agent
)
public setWindowBounds: newBounds <Rectangle> = (
	handle ~= 0 ifTrue:
		[owner api MoveWindow
			value: handle
			value: newBounds left asInteger
			value: newBounds top asInteger
			value: newBounds width asInteger
			value: newBounds height asInteger
			value: 1 (* update after move *)]
)
public title ^<String> = (
	(* The title to use on the Windows window. *)
	^''
)
public updateControlsByHandle = (
	inputManager updateControlsByHandle.
)
public windowArtifactBounds ^<Rectangle> = (
	^api RECT newC freeAfter:
		[:rect | | ok |
		ok:: api GetClientRect unsignedValue: handle value: rect address.
		ok = 0 ifTrue:
			[api reportError: 'GetClientRect() failed'.
			^0@0 extent: 0@0].
		rect asRectangle]
)
) : (
)
class OuterSubAgent inside: outerAgent <ViewportAgent> = (
(* Manages the outer window of a viewport. The class of this window is registered with a null background brush, and it handles WM_ERASEBKGND to make the color set in the visual. *)
|
	private owner = outerAgent.
	public handle ::= 0.
|) (
public createWindow = (
	windowsSession viewportWindowClass createWindowForAgent: self.
)
public destroyWindow = (
	handle ~= 0 ifTrue:
		[owner api DestroyWindow value: handle.
		handle: 0]
)
public dwExStyle ^<Integer> = (
	^0
)
public dwStyle ^<Integer> = (
	^owner api WS_CHILD
	| owner api WS_CLIPCHILDREN
	| owner api WS_CLIPSIBLINGS
	| (owner visual allowsHorizontalScrolling
		ifTrue: [owner api WS_HSCROLL]
		ifFalse: [0])
	| (owner visual allowsVerticalScrolling
		ifTrue: [owner api WS_VSCROLL]
		ifFalse: [0])
)
hideWindow = (
	handle ~= 0 ifTrue:
		[owner api ShowWindow value: handle value: api SW_HIDE]
)
public initialWindowBounds ^<Rectangle> = (
	^owner initialOuterWindowBounds.
)
public invalidateRectangle: rectangle <Rectangle> = (
	| expanded |
	handle = 0 ifFalse:
		[expanded:: rectangle origin extent: rectangle extent + 1.
		owner api RECT newC freeAfter:
			[:rect |
			rect initializeFromRectangle: expanded.
			api InvalidateRect value: handle value: rect address value: 0]]
)
invalidateWindow = (
	handle = 0 ifFalse:
		[owner api InvalidateRect value: handle value: 0 value: 0]
)
public matchScrollbarRange = (
	| desired available optimalPosition |
	desired: owner visual virtualExtent.
	available:: owner visual innerExtent max: 0 @ 0.
	optimalPosition:: (owner visual scrollPosition min: desired - available) max: 0 @ 0.
	owner visual scrollPosition = optimalPosition ifFalse:
		[owner visual scrollPosition: optimalPosition].
	api SCROLLINFO newC freeAfter:
		[:scrollinfo |
		scrollinfo
			fMask: api SIF_ALL;
			nMin: 0.
		owner visual allowsHorizontalScrolling ifTrue:
			[scrollinfo
				nMax: desired x;
				nPage: available x;
				nPos: optimalPosition x.
			api SetScrollInfo
				value: handle
				value: api SB_HORZ
				value: scrollinfo address
				value: 1].
		owner visual allowsVerticalScrolling ifTrue:
			[scrollinfo
				nMax: desired y;
				nPage: available y;
				nPos: optimalPosition y.
			api SetScrollInfo
				value: handle
				value: api SB_VERT
				value: scrollinfo address
				value: 1].
		]
)
paintUncoveredBackgroundOn: hdc <Integer>
with: hbrush <Integer>
inside: myBounds <Rectangle> = (
	| contentBounds |
	contentBounds:: owner innerWindowBounds.
	contentBounds bottom < myBounds bottom ifTrue:
		[api RECT newC freeAfter:
			[:buffer |
			buffer
				left: myBounds left;
				top: contentBounds bottom;
				right: myBounds right;
				bottom: myBounds bottom.
			api FillRect value: hdc value: buffer address value: hbrush]].
	contentBounds right < myBounds right ifTrue:
		[api RECT newC freeAfter:
			[:buffer |
			buffer
				left: contentBounds right;
				top: myBounds top;
				right: myBounds right;
				bottom: myBounds bottom.
			api FillRect value: hdc value: buffer address value: hbrush]].
)
public parentHandle ^<Integer> = (
	(* Answer the handle to use as the parent of the outer window. *)
	^owner parent handle ifNil: [error: 'no parent handle']
)
public processWM_ERASEBKGND: args <WindowProc> ^<Integer> = (
	| hdc hbrush |
	hdc:: args wParam.
	hbrush:: api CreateSolidBrush unsignedValue: owner visualsColorref.
(*	hbrush:: api CreateSolidBrush unsignedValue:
		NewspeakGlobalState Graphics Color red asColorref.	*)
	hbrush = 0 ifTrue:
		[api reportError: 'CreateSolidBrush() failed'.
		^0].
	api RECT newC freeAfter:
		[:rect | | ok |
		ok:: api GetClientRect unsignedValue: args hwnd value: rect address.
		ok = 0 ifTrue:
			[api reportError: 'GetClientRect() failed'.
			^0].
		paintUncoveredBackgroundOn: hdc with: hbrush inside: rect asRectangle].
	api DeleteObject value: hbrush.
	^1 (* erased *)
)
public processWM_HSCROLL: args <WindowProc> ^<Integer> = (
	| command thumbPosition success target |
	command: args wParamLoWord.
	command > 5 ifTrue: [^0].
	api SCROLLINFO newC freeAfter:
		[:scrollinfo |
		scrollinfo fMask: 16r10.
		success:: api GetScrollInfo
			boolValue: handle
			value: api SB_HORZ
			value: scrollinfo address.
		thumbPosition: scrollinfo nTrackPos].
	target:: transformScrollValue: owner visual scrollPosition x
		by: command
		thumbPosition: thumbPosition
		pageSize: owner visual innerExtent x
		maxValue: owner visual virtualExtent x.
	success ifTrue:
		[owner visual scrollPosition:
			(target @ owner visual scrollPosition y)].
	^0
)
public processWM_VSCROLL: args <WindowProc> ^<Integer> = (
	| command thumbPosition success target |
	command: args wParamLoWord.
	command > 5 ifTrue: [^0].
	api SCROLLINFO newC freeAfter:
		[:scrollinfo |
		scrollinfo fMask: 16r10.
		success:: api GetScrollInfo
			boolValue: handle
			value: api SB_VERT
			value: scrollinfo address.
		thumbPosition: scrollinfo nTrackPos].
	target:: transformScrollValue: owner visual scrollPosition y
		by: command
		thumbPosition: thumbPosition
		pageSize: owner visual innerExtent y
		maxValue: owner visual virtualExtent y.
	success ifTrue:
		[owner visual scrollPosition:
			(owner visual scrollPosition x @ target)].
	^0
)
public processWindowsMessage: args <WindowProc> ^<Integer> = (
	args message = api WM_ERASEBKGND ifTrue:
		[^processWM_ERASEBKGND: args].
	args message = api WM_HSCROLL ifTrue:
		[^processWM_HSCROLL: args].
	args message = api WM_VSCROLL ifTrue:
		[^processWM_VSCROLL: args].
	^owner invokeDefWindowProc: args
)
public resetForNewImageSession = (
	handle:: 0
)
public setWindowBounds: newBounds <Rectangle> = (
	handle ~= 0 ifTrue:
		[owner api MoveWindow
			value: handle
			value: newBounds left asInteger
			value: newBounds top asInteger
			value: newBounds width asInteger
			value: newBounds height asInteger
			value: 1 (* update after move *)]
)
public showWindow = (
	handle ~= 0 ifTrue:
		[owner api ShowWindow value: handle value: api SW_SHOW.
		owner api UpdateWindow value: handle]
)
protected smallScrollStep = (
	^20
)
public title ^<String> = (
	(* The title to use on the Windows window. *)
	^''
)
transformScrollValue: position <Integer>
by: command <Integer>
thumbPosition: thumbPosition <Integer>
pageSize: pageSize <Integer>
maxValue: maxValue <Integer>
^<Integer> = (
	command = 0 (* step back *) ifTrue:
		[^position - smallScrollStep max: 0].
	command = 1 (* step forward *) ifTrue:
		[^position + smallScrollStep min: maxValue - pageSize].
	command = 2 (* page back *) ifTrue:
		[^position - pageSize max: 0].
	command = 3 (* page forward *) ifTrue:
		[^position + pageSize min: maxValue - pageSize].
	(command = 4 or: [command = 5]) (* thumb *) ifTrue:
		[^thumbPosition].
	^position
)
) : (
)
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual visibleA to: self ~ #matchVisualsVisibility:.
	map: visual scrollPositionH to: [:newOrigin | scrollTo: newOrigin].
)
public contributeToInnerWM_PAINTOn: hdc <Integer>
inside: parentRelativeRect <Rectangle> = (
(* This is a companion of contributeToWM_PAINT..., but this one is received from the inner agent rather than from up the hierarchy, and for this one we do want to tell the children to paint things. *)
(* -- original code -- *)
	visual color isTransparent ifFalse:
		[fillRectangle: parentRelativeRect on: hdc withSolidColor: visual color asColor].
(* -- debugging -- *)
	(* graphics clear: (windowsSession gdiPlus Color orange). *)
(* -- end -- *)
(* NewspeakGlobalState System MessageTally spyOn: [ *)
	childrenDo:
		[:each |
		each
			contributeToWM_PAINTOn: hdc
			inside: parentRelativeRect
			translatedBy: 0 @ 0]
)
public contributeToInnerWM_PAINTOnBuffer: hdc <Integer> inside: parentRelativeRect <Rectangle> = (
	(* Same as non-buffered version, except translated so that children reference 0@0 of back buffer *)

	visual color isTransparent ifFalse: [
		fillRectangle: (0@0 extent: parentRelativeRect extent)
		on: hdc
		withSolidColor: visual color asColor
	].

	childrenDo: [:each | each
		contributeToWM_PAINTOn: hdc
		inside: parentRelativeRect
		translatedBy: (parentRelativeRect origin negated)
	]
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
	(* We don't recurse into the children as our subtree does its own paining in response to its own WM_PAINT. However, we provide a companion message for the benefit of the inner agent. *)
)
public createArtifactsForSubtree = (
	super createArtifactsForSubtree.
	innerAgent updateControlsByHandle.
)
public createOwnArtifacts = (
	(* outerAgent must be created first because the inner one needs its handle. *)
	outerAgent createWindow.
	innerAgent createWindow.
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	innerAgent destroyWindow.
	outerAgent destroyWindow.
)
public handle ^<Integer> = (
	^innerAgent handle
)
public hostWindowAgent ^<Agent | nil> = (
	^self
)
public initialOuterWindowBounds = (
	^parent rectangleRelativeToHostWindow: visual bounds
)
public innerWindowBounds = (
	^innerAgent windowArtifactBounds translateBy: visual scrollPosition negated
)
invalidate = (
	innerAgent invalidateWindow
)
public invalidateRectangle: rectangle <Rectangle> = (
	innerAgent invalidateRectangle: rectangle
)
invalidateWindow = (
	innerAgent invalidateWindow
)
public invokeDefWindowProc: args <WindowProc> ^<Integer> = (
	(* Even though this agent owns no windows it provides this method for the benefit of the inner agents. *)
	^api DefWindowProc
		unsignedValue: args hwnd
		value: args message
		value: args wParam
		value: args lParam
)
public matchScrollbarRange = (
	outerAgent matchScrollbarRange
)
matchVisualsBounds = (
	| newBounds |
	newBounds:: parent rectangleRelativeToHostWindow: visual bounds.
	newBounds = currentBounds ifTrue: [^self].
	currentBounds: newBounds.
	outerAgent setWindowBounds: currentBounds.
	setInnerWindowBounds.
	matchScrollbarRange.
)
public matchVisualsVisibility: shouldBeVisible <Boolean> = (
	shouldBeVisible
		ifTrue: [outerAgent showWindow]
		ifFalse: [outerAgent hideWindow]
)
public noteBeginningOfBoundsChangeAndProvideEndContinuation = (
	areBoundsChanging: true.
	^[ setInnerWindowBounds.
		areBoundsChanging: false]
)
public noticeChangeInChildAgentStructure = (
	super noticeChangeInChildAgentStructure.
	innerAgent updateControlsByHandle.
)
public noticeChangeInNaturalExtent = (
	setInnerWindowBounds
)
public rectangleRelativeToHostWindow: rect <Rectangle> ^<Rectangle> = (
	(* By request (presumably) from a child, translate the rectangle to be relative to whatever visual that provides the host reference frame for the child. This rectangle is in our coordinate system. *)
	^rect
)
public releaseMouseGrabFrom: agent <Agent> = (
	innerAgent releaseMouseGrabFrom: agent
)
scrollTo: newOrigin <Point> = (
	innerAgent setWindowBounds:
		(newOrigin negated extent: visual virtualExtent).
	matchScrollbarRange
)
public scrollbarHeight ^<Integer> = (
	^scrollbarHeightCached ifNil:
		[scrollbarHeightCached:: windowsSession systemMetrics scrollbarHeight.
		scrollbarHeightCached]
)
public scrollbarWidth = (
	^scrollbarWidthCached ifNil:
		[scrollbarWidthCached:: windowsSession systemMetrics scrollbarWidth.
		scrollbarWidthCached]
)
setInnerWindowBounds = (
	| newBounds corner |
	newBounds:: visual scrollPosition negated extent: visual virtualExtent.
	innerAgent setWindowBounds: newBounds.
	(* Now invalidate any exposed portions of the outer window to ensure
	no visual garbage is left over. *)
	corner:: visual innerExtent.
	newBounds corner x < corner x ifTrue: (* exposed on the right *)
		[outerAgent invalidateRectangle:
			(newBounds corner x @ 0 corner: corner)].
	newBounds corner y < corner y ifTrue: (* exposed at the bottom *)
		[outerAgent invalidateRectangle:
			(0 @ newBounds corner y corner: corner)].
)
public setMouseGrabTo: agent <Agent> = (
	innerAgent setMouseGrabTo: agent
)
public visualsColorref ^<Integer> = (
	(* Return the color of the visual as a WIndows COLORREF. Provided for the benefit of inner agents to keep their hands out of the visual's direct innards. *)
	^visual color asColorref
)
) : (
)
class WindowAgent forVisual: visual = AgentWithHandle forVisual: visual (
(* This agent takes care of mapping a Brazil Window visual to a Windows artifact. It is also a very important player in Windows mapping scheme in general, as it dispatches WM_COMMAND notifications to their appropriate controls, coordinates painting of soft widgets and delivers mouse events to them. *)
|
	protected inputManager = WindowContentManager forAgent: self.
	protected lockVisualBoundsMatching ::= false.
	protected messageDispatchTable = Map new.
	protected paintstruct <PAINTSTRUCT>
	private backbuffer
	private backbufferSize
|populateDispatchTable) (
bringToFront = (
	(* To do; unimplemented. *)
)
private bufferForSize: paintSize hdc: hdc = (
	(* Returns the retained backbuffer, growing it 2x as necessary *)

	backbuffer ifNil: [
		backbufferSize:: paintSize * 2.
		backbuffer:: compatibleBitmapFor: hdc size: backbufferSize.
		^backbuffer.
	].

	(backbufferSize y < (paintSize y) or: [backbufferSize x < (paintSize x)]) ifTrue: [
		api DeleteObject value: backbuffer.
		backbufferSize:: paintSize * 2.
		backbuffer:: compatibleBitmapFor: hdc size: backbufferSize.
	].

	^backbuffer.
)
public close = (
	windowsSession enableAll.
	destroy.
	visual mappedWindowClosed.
)
compatibleBitmapFor: hdc size: size = (
	^api CreateCompatibleBitmap value: hdc value: size x value: size y
)
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual titleA to: self ~ #matchVisualsTitle:.
	map: visual visibleA to: self ~ #matchVisualsVisibility:.
	map: visual menuBarMenuA to: self ~ #setMenuBarMenu:.
)
public createArtifactsForSubtree = (
	super createArtifactsForSubtree.
	inputManager updateControlsByHandle.
)
public createOwnArtifacts = (
	windowClass createWindowForAgent: self.
	(* The receiver gets the handle of its window from the class while the call above is in progress.
	From this point on the receiver starts receiving Windows messages for its window as the
	#processMessage: message. *)
	handle isNil ifTrue:
		[error: 'no WM_NCCREATE received for the new window']
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	handle ifNotNil: [
		unregisterHandlerFor: api WM_DESTROY. (* need this because we don't want the WM_DESTROY sent as a side effect of the window being destroyed to cause the window unmapping code to run again. *)
		(api DestroyWindow signedValue: handle) ~= 0 ifTrue: [
			api DeleteObject value: backbuffer.
			handle: nil
		]
	]
)
disableAllOther = (
	windowsSession disableAll.
	handle ifNotNil:
		[:hwnd |
		api EnableWindow boolValue: hwnd value: 1].
)
public dwExStyle ^<Integer> = (
	(* The style bits to pass to CreateWindowEx as dwExStyle when creating the artifacts for this agent. *)
	^0
)
public dwStyle ^<Integer> = (
	(* The style bits to pass to CreateWindowEx as dwStyle when creating the artifacts for this agent. *)
	^api WS_OVERLAPPEDWINDOW
	| api WS_CLIPCHILDREN
)
hostWindowAgent ^<Agent | nil> = (
	^self
)
public initialWindowBounds ^<Rectangle> = (
	^innerToOuter: visual bounds.
)
innerToOuter: rect <Rectangle> = (
	^withOriginAndCornerCorrectionsDo:
		[:oc :cc |
		rect origin + oc corner: rect corner + cc]
)
invalidate = (
	^invalidateWindow
)
public invalidateRectangle: rectangle <Rectangle> = (
	| expanded |
	rectangle hasPositiveExtent ifFalse: [^self].
	expanded:: rectangle origin extent: rectangle extent + 1.
	handle ifNotNil:
		[:hwnd |
		api RECT newC freeAfter:
			[:rect |
			rect initializeFromRectangle: expanded.
			api InvalidateRect value: hwnd value: rect address value: 0]]
)
public invokeDefWindowProc: args <WindowProc> = (
	^api DefWindowProc
		unsignedValue: args hwnd
		value: args message
		value: args wParam
		value: args lParam
)
public isOpen = (
	ifHandleValid: [^true].
	^false
)
public matchVisualsBounds = (
	| outerBounds |
	(lockVisualBoundsMatching == true or: [handle isNil]) ifTrue:
		[^self].
	outerBounds:: innerToOuter: visual bounds.
	api MoveWindow
		value: handle
		value: outerBounds left asInteger
		value: outerBounds top asInteger
		value: outerBounds width asInteger
		value: outerBounds height asInteger
		value: 1
)
public matchVisualsTitle: newTitle <String> = (
	setWindowText: newTitle
)
public matchVisualsVisibility: shouldBeVisible <Boolean> = (
	handle ifNotNil:
		[shouldBeVisible
			ifTrue:
				[api ShowWindow value: handle value: api SW_SHOW.
				api UpdateWindow value: handle]
			ifFalse:
				[api ShowWindow value: handle value: api SW_HIDE]]
)
public modalOpenWhileFalse: doneValueProvider = (
	^modalOpenWhileFalse: doneValueProvider afterOpening: []
)
public modalOpenWhileFalse: doneValueProvider afterOpening: setupBlock = (
	disableAllOther.
	setupBlock value.
	NsFFISessionManager soleInstance drainEventsWhileFalse: [doneValueProvider value or: [visual agent isNil]].
	visual close
)
public noticeChangeInChildAgentStructure = (
	super noticeChangeInChildAgentStructure.
	inputManager updateControlsByHandle.
)
public outerToInner: rect <Rectangle> = (
	^withOriginAndCornerCorrectionsDo:
		[:oc :cc |
		rect origin - oc corner: rect corner - cc]
)
paintBackgroundIn: rectangle on: hdc = (
	fillRectangle: rectangle
	on: hdc
	withSolidColor: (Color gray: 0.9)
)
paintBackgroundIn: rectangle using: graphics = (
	| gdip |
	gdip:: windowsSession gdiPlus.
	graphics clear: (gdip Color a: 255 r: 236 g: 233 b: 216).
)
public parentHandle ^<Integer> = (
	(* Windows class sends this message to find out the handle to use as the parent window handle. WindowAgent represents a top level window and thus it has no parent with a handle. *)
	^0
)
populateDispatchTable = (
	register: {self. #processWM_CREATE:} asHandlerFor: api WM_CREATE.
	register: {self. #processWM_CLOSE:} asHandlerFor: api WM_CLOSE.
	register: {self. #processWM_DESTROY:} asHandlerFor: api WM_DESTROY.
	register: {self. #processWM_NCDESTROY:} asHandlerFor: api WM_NCDESTROY.
	register: {self. #processWM_ERASEBKGND:} asHandlerFor: api WM_ERASEBKGND.
	register: {self. useDoubleBuffering
			ifTrue: [#processWM_PAINTDoubleBuffered:]
			ifFalse: [#processWM_PAINTUnbuffered:]}
		asHandlerFor: api WM_PAINT.
	register: {self. #processWM_WINDOWPOSCHANGED:} asHandlerFor: api WM_WINDOWPOSCHANGED.

	register: {inputManager. #processWM_COMMAND:} asHandlerFor: api WM_SYSCOMMAND.
	register: {inputManager. #processWM_COMMAND:} asHandlerFor: api WM_COMMAND.
	register: {inputManager. #processWM_NOTIFY:} asHandlerFor: api WM_NOTIFY.
	register: {inputManager. #processWM_LBUTTONDOWN:} asHandlerFor: api WM_LBUTTONDOWN.
	register: {inputManager. #processWM_LBUTTONUP:} asHandlerFor: api WM_LBUTTONUP.
	register: {inputManager. #processWM_MOUSELEAVE:} asHandlerFor: api WM_MOUSELEAVE.
	register: {inputManager. #processWM_MOUSEMOVE:} asHandlerFor: api WM_MOUSEMOVE.
)
public processWM_CLOSE: args <WindowProc> = (
	NsFFISessionManager soleInstance scheduleDeferredAction:
		[visual hasPermissionToClose ifTrue:
			[close]].
	^0
)
public processWM_CREATE: args <WindowProc> = (
	paintstruct:: api PAINTSTRUCT newC.
	^0
)
processWM_DESTROY: args <WindowProc> = (
	visual mappedWindowClosed.
	^0
)
public processWM_ERASEBKGND: args <WindowProc> = (
	^1
)
public processWM_NCDESTROY: args <WindowProc> = (
	paintstruct ifNotNil:
		[paintstruct free.
		paintstruct:: nil].
	windowClass unregisterWindowForAgent: self.
	^0
)
public processWM_PAINTDoubleBuffered: args <WindowProc> = (
	(* Handle the WM_PAINT request with double-buffering. *)
	(* ^processWM_PAINTUnbuffered: args *)
	| paintSize hdc hdcMem hbmMem hOld |

	(* Begin Paint *)
	hdc:: api BeginPaint unsignedValue: handle value: paintstruct address.
	paintSize:: paintstruct paintRectangle extent.

	(* Create HDC for backbuffer *)
	hdcMem:: api CreateCompatibleDC value: hdc.
	hbmMem:: bufferForSize: paintSize hdc: hdc.
	hOld:: api SelectObject value: hdcMem value: hbmMem.

	(* Evaluate paint contributions *)
	paintBackgroundIn: (0@0 extent: paintSize) on: hdcMem.
	visual content agent
		contributeToWM_PAINTOn: hdcMem
		inside: paintstruct paintRectangle
		translatedBy: (paintstruct paintRectangle origin negated).

	(* Blit backbuffer to HDC *)
	api BitBlt
		value: hdc
		value: paintstruct paintRectangle origin x value: paintstruct paintRectangle origin y
		value: paintSize x value: paintSize y
		value: hdcMem
		value: 0 value: 0
		value: api SRCCOPY.

	(* Wrap things up in reverse order *)
	api SelectObject value: hdcMem value: hOld.
	api DeleteDC value: hdcMem.
	api EndPaint value: handle value: paintstruct address.

	^0
)
public processWM_PAINTUnbuffered: args <WindowProc> = (
	(* Handle the WM_PAINT request without double-buffering. *)
	| hdc |
	hdc:: api BeginPaint unsignedValue: handle value: paintstruct address.
	paintBackgroundIn: paintstruct paintRectangle on: hdc.
	visual content agent
		contributeToWM_PAINTOn: hdc
		inside: paintstruct paintRectangle
		translatedBy: 0 @ 0.
	api EndPaint value: handle value: paintstruct address.
	^0
)
public processWM_WINDOWPOSCHANGED: args <WindowProc> ^<Integer> = (
	| windowpos |
	windowpos:: api WINDOWPOS atAddress: args lParam.
	lockVisualBoundsMatching:: true.
	[visual resizeFromUserTo: (outerToInner: windowpos asRectangle)]
		ensure: [lockVisualBoundsMatching:: false].
	^0
	(* As per MSDN, 'If an application processes this message, it should return zero.' *)
)
public processWindowsMessage: args <WindowProc> = (
	(* This message is sent by the WindowsSession of this mapping when a Windows message is received for the window created by this agent. *)
	| message handler |
	message:: args message.
	handler:: messageDispatchTable at: message ifAbsent: [^invokeDefWindowProc: args].
	^(handler at: 1) perform: (handler at: 2) with: args
)
public rectangleRelativeToHostWindow: rect <Rectangle> ^<Rectangle> = (
	(* By request (presumably) from a child, translate the rectangle to be relative to whatever visual that provides the host reference frame for the child. *)
	^rect
)
register: receiverSelectorTuple asHandlerFor: messageCode <Integer> = (
	messageDispatchTable at: messageCode put: receiverSelectorTuple
)
public releaseMouseGrabFrom: agent <Agent> = (
	inputManager releaseMouseGrabFrom: agent
)
public setMenuBarMenu: newMenu <Menu | nil> = (
	| menuHandle builder |
	newMenu isNil
		ifTrue:
			[menuHandle: 0.
			inputManager menuItemsById: Map new]
		ifFalse:
			[builder: MenuBuilder new.
			menuHandle:: builder buildMenuBarFrom: newMenu.
			inputManager menuItemsById: builder itemsById].
	api SetMenu unsignedValue: handle value: menuHandle.
	api DrawMenuBar unsignedValue: handle.
)
public setMouseGrabTo: agent <Agent> = (
	inputManager setMouseGrabTo: agent
)
public title ^<String> = (
	^visual title
)
unregisterHandlerFor: messageCode <Integer> = (
	messageDispatchTable removeKey: messageCode
)
unregisterHandlerFor: messageName <Symbol> while: action <Block> = (
	| code handler |
	code:: api perform: messageName.
	handler:: messageDispatchTable at: code.
	messageDispatchTable removeKey: code.
	^action ensure: [messageDispatchTable at: code put: handler]
)
windowClass = (
	^windowsSession standardTopLevelWindowClass
)
protected withOriginAndCornerCorrectionsDo: action <[:Point :Point]> = (
	^api RECT newC freeAfter:
		[:rect |
		rect left: 100; top: 100; right: 500; bottom: 500.
		api AdjustWindowRect
			value: rect address
			value: dwStyle
			value: (visual menuBarMenu isNil ifTrue: [0] ifFalse: [1]).
		action
			value: (rect left - 100 ) @ (rect top - 100)
			value: (rect right - 500) @ (rect bottom - 500)]
)
xprocessWM_PAINTDoubleBuffered: args <WindowProc> = (
	(* UNUSED: the version that uses GDI+ graphics, saved for future reference. *)
	(* Handle the WM_PAINT request with double-buffering. *)
(*	| gdip hdc paintRectangle graphics |
	gdip:: windowsSession gdiPlus.
	hdc:: api BeginPaint unsignedValue: handle value: paintstruct address.
	paintRectangle:: paintstruct paintRectangle.
	graphics:: gdip Graphics fromHDC: hdc.
	[windowsSession doubleBufferingSurfaceManager
		withBitmapOfExtent: paintRectangle right @ paintRectangle bottom
		do:
			[:buffer | | memgraphics |
			memgraphics:: gdip Graphics forBitmap: buffer.
			paintBackgroundIn: paintRectangle using: memgraphics.
			[visual content agent
				contributeToWM_PAINTUsing: memgraphics
				inside: paintRectangle
				translatedBy: 0 @ 0.
			graphics drawImage: buffer at: 0 @ 0]
			ensure: [memgraphics release]]]
	ensure:
		[graphics release.
		paintstruct ifNotNil: [
			api EndPaint value: handle value: paintstruct address]].
	^0 *)
)
xprocessWM_PAINTUnbuffered: args <WindowProc> = (
	(* UNUSED: the version that uses GDI+ graphics, saved for future reference. *)
	(* Handle the WM_PAINT request without double-buffering. *)
(*	| hdc graphics |
	hdc:: api BeginPaint unsignedValue: handle value: paintstruct address.
	graphics:: windowsSession gdiPlus Graphics fromHDC: hdc.
	paintBackgroundIn: paintstruct paintRectangle using: graphics.
	visual content agent
		contributeToWM_PAINTUsing: graphics
		inside: paintstruct paintRectangle
		translatedBy: 0 @ 0.
	graphics release.
	api EndPaint value: handle value: paintstruct address.
	^0 *)
)
) : (
)
class WindowContentManager forAgent: agent = (
(* Manages mouse event and control message delivery to descendents of the owner. Used by agents that map to Windows windows containing other windows in them, such as WindowAgent and ViewportAgent`InnerSubAgent. *)
|
	owner <Agent> = agent.
	controlsByHandle ::= newControlsByHandleMap.
	public menuItemsById ::= Map new.
	lastMouseEventConsumer ::= nil.
	mouseGrabbingAgent ::= nil.

	trackingNow ::= false. (* set to true after we've requested mouse tracking for this window and before we get a corresponding leave event. *)
|) (
api ^<Win32API> = (
	(* The API module instance to use for talking to The Other Side. *)
	^owner api
)
protected captureModifierKeyState: eventInputState while: action = (
	^owner visual desktop
		ifNotNil:
			[:it | it agent setModifierKeyState: eventInputState while: action]
		ifNil:
			[action value]
)
collectControlsByHandle ^<Map[Integer,Agent]> = (
	| result |
	result:: newControlsByHandleMap.
	owner collectControlsByHandleInto: result.
	^result
)
protected createModifierKeyStateFrom: args <WindowProc> = (
	| wParam |
	wParam:: args wParam.
	^ModifierKeyState new
		shiftPressed: (wParam anyMask: api MK_SHIFT);
		controlPressed: (wParam anyMask: api MK_CONTROL)
)
private dispatchMouseEvent: args <WindowProc> using: action <Block> ^<Integer> = (
	(* Private - Find a consumer for a mouse-related WM_ message and invoke the action block with that consumer. *)
	| thisConsumer |
	thisConsumer:: findConsumerForMouseEventAt: args lParamAsPoint.
	thisConsumer == lastMouseEventConsumer ifFalse:
		[lastMouseEventConsumer notNil ifTrue:
			[lastMouseEventConsumer processMouseExit].
		thisConsumer notNil ifTrue:
			[thisConsumer processMouseEntry].
		lastMouseEventConsumer:: thisConsumer].
	thisConsumer ifNotNil: [action value: thisConsumer].
	^0
)
protected findConsumerForMouseEventAt: point <Point> ^<Agent | nil> = (
	mouseGrabbingAgent ifNotNil: [:it | ^it].
	owner childrenDo:
		[:each |
		(each findConsumerForMouseEventAt: point)
			ifNotNil: [:consumer | ^consumer]].
	^nil
)
public handle ^<Integer> = (
	(* Windows handle of this window. *)
	^owner handle
)
maybeProcessMenuItemCommand: args = (
	| item |
	args wParam.
	item:: menuItemsById
		at: args wParam
		ifAbsent: [^owner invokeDefWindowProc: args].
	item action value.
	^0
)
private newControlsByHandleMap = (
	^Map new: 20
)
public processWM_COMMAND: args <WindowProc> = (
	| controlHandle control |
	controlHandle:: args lParam.
	control:: controlsByHandle
		at: controlHandle
		ifAbsent: [^maybeProcessMenuItemCommand: args].
	^control processCommand: args wParamHiWord
)
public processWM_LBUTTONDOWN: args <WindowProc> ^<Integer> = (
	captureModifierKeyState: (createModifierKeyStateFrom: args) while:
		[dispatchMouseEvent: args using:
			[:consumer | consumer processMouseDownLeft]].
	^0
)
public processWM_LBUTTONUP: args <WindowProc> ^<Integer> = (
	captureModifierKeyState: (createModifierKeyStateFrom: args) while:
		[dispatchMouseEvent: args using:
			[:consumer | consumer processMouseUpLeft]].
	^0
)
public processWM_MOUSELEAVE: args <WindowProc> ^<Integer> = (
	captureModifierKeyState: (createModifierKeyStateFrom: args) while:
		[lastMouseEventConsumer notNil ifTrue:
			[lastMouseEventConsumer processMouseExit.
			lastMouseEventConsumer:: nil]].
	trackingNow:: false.
	^0
)
public processWM_MOUSEMOVE: args <WindowProc> ^<Integer> = (
	captureModifierKeyState: (createModifierKeyStateFrom: args) while:
		[dispatchMouseEvent: args using:
			[:consumer | consumer processMouseMove]].
	trackingNow ifFalse: [requestMouseTracking].
	^0
)
public processWM_NOTIFY: args <WindowProc> = (
	| header controlHandle control |
	header:: api NMHDR atAddress: args lParam.
	controlHandle:: header hwndFrom.
	control:: controlsByHandle
		at: controlHandle
		ifAbsent: [^owner invokeDefWindowProc: args].
	^control processNotification: header code data: header.
)
public releaseMouseGrabFrom: agent = (
	mouseGrabbingAgent == agent ifTrue:
		[mouseGrabbingAgent: nil.
		api ReleaseCapture value].
)
private requestMouseTracking = (
	| success |
	api TRACKMOUSEEVENT newC freeAfter:
		[:trackStruct |
		trackStruct
			dwFlags: 2 (* TME_LEAVE *);
			hwndTrack: handle.
		success:: api TrackMouseEvent boolValue: trackStruct address].
	success ifFalse: [api reportError: 'TrackMouseEvent() failed'].
	trackingNow:: true.
)
public setMouseGrabTo: agent = (
	mouseGrabbingAgent: agent.
	api SetCapture value: owner handle.
)
public updateControlsByHandle = (
	controlsByHandle:: collectControlsByHandle.
)
) : (
)
class WindowControlAgent forVisual: visual = AgentWithHandle forVisual: visual (
(* This is the abstract superclass of agents that represent Windows controls such as buttons and list boxes. It provides the behavior required to register the agent with the top-level window so that WM_COMMAND notifications are passed from the window to the control agent. It also implements #matchVisualsBounds to move the Windows control to match the bounds of the visual. *)
|
	protected currentBounds <Rectangle | nil> ::= 0 @ 0 extent: 0 @ 0.
	protected lastHostRelativeBounds <Rectangle | nil>
|) (
public collectControlsByHandleInto: aDictionary = (
	handle notNil ifTrue:
		[aDictionary at: handle put: self]
)
public connectOwnArtifacts = (
	super connectOwnArtifacts.
	map: visual visibleA to: self ~ #matchVisualsVisibility:.
)
controlClassName ^<String> = (
(* Answer the class name of the Windows control to create for this agent. *)
	subclassResponsibility
)
controlWindowTitle ^<String> = (
(* Answer the string to use as the title of the control window. *)
	^''
)
public createOwnArtifacts = (
	| className title windowRelativeBounds |
	className:: Alien newCString: controlClassName.
	title:: Alien newCString: controlWindowTitle asString.
	windowRelativeBounds:: visual bounds
		translateFrom: visual parent
		to: visual window.
	handle:: api CreateWindowEx
		unsignedValueWithArguments: {
			dwExStyle.
			className address.
			title address.
			dwStyle.
			windowRelativeBounds left.
			windowRelativeBounds top.
			windowRelativeBounds width.
			windowRelativeBounds height.
			parent handle.
			0.
			windowsSession applicationInstanceHandle.
			0}.
	className free.
	title free.
	handle = 0
		ifTrue:
			[api reportError: controlClassName, ' creation failed']
		ifFalse:
		 	[setControlFont]
)
public destroyOwnArtifacts = (
	super destroyOwnArtifacts.
	handle ifNotNil:
		[api DestroyWindow value: handle.
		handle:: nil]
)
public dwExStyle ^<Integer> = (
(* The dwExStyle bits to use with CreateWindowEx when creating this control. *)
	^0
)
public dwStyle ^<Integer> = (
(* The dwStyle bits to use with CreateWindowEx when creating this control. *)
	^api WS_TABSTOP
	| api WS_CHILD
	| api WS_CLIPSIBLINGS
)
matchVisualsBounds = (
	handle notNil ifTrue:
		[currentBounds:: parent rectangleRelativeToHostWindow: visual bounds.
		lastHostRelativeBounds = currentBounds ifTrue: [^self].
		lastHostRelativeBounds:: currentBounds.
		api MoveWindow valueWithArguments: {
			handle.
			currentBounds left asInteger.
			currentBounds top asInteger.
			currentBounds width asInteger.
			currentBounds height asInteger.
			1.
			}.
		]
)
public matchVisualsVisibility: shouldBeVisible <Boolean> = (
	handle ifNotNil:
		[api ShowWindow
			value: handle
			value: (shouldBeVisible
					ifTrue: [api SW_SHOW]
					ifFalse: [api SW_HIDE])]
)
public processCommand: code <Integer> ^<Integer> = (
(* Process a control command received by the parent window as WM_COMMAND. The code argument is the notification code passed as the hiword of wParam. *)
	^0
)
public processNotification: code <Integer> data: lparam <Alien> ^<Integer> = (
(* Process a control notification received by the parent window. The code argument is the code from the NMHDR structure pointed to by lparam. *)
	^0
)
protected selectControlFontInto: hdc <Integer> = (
	| hfont |
	hfont:: windowsSession fontMapper defaultControlFontHandle.
	api SelectObject value: hdc value: hfont.
)
setControlFont = (
	| hfont |
	hfont:: windowsSession fontMapper defaultControlFontHandle.
	sendMessage: api WM_SETFONT wParam: hfont lParam: 1.
)
) : (
)
class WindowsSession = (
(* Manages session-specific information such as the current application instance handle the handles of various system DLLs such as the RichEdit control. Also manages window classes. *)
|
	applicationInstanceHandle_ <Integer | nil>

	(* New classes created here should also be added to #resetForNewImageSession. *)
	public standardTopLevelWindowClass =
		(WindowClass
			name: 'BrazilWindow'
			style: api CS_HREDRAW | api CS_VREDRAW
			bg: 0)
				iconIdOrName: 2. (* the app icon stored in the vm .exe *)
	public viewportWindowClass = WindowClass
		name: 'BrazilViewport'
		style: 0
		bg: 0.
	public viewportContentCarrierWindowClass = WindowClass
		name: 'BrazilViewportContent'
		style: 0
		bg: 0.
	textMeasurerWindowClass = WindowClass
		name: 'BrazilTextMeasurer'
		style: 0
		bg: 1.
	draggedImageWindowClass = WindowClass
		name: 'BrazilDraggedImage'
		style: 0
		bg: 0.
	(* New classes created here should also be added to #resetForNewImageSession. *)

	richEdit20Handle ::= 0.
	public gdiPlus = api GDIplus new.

	public imageMapper = ImageMapper new.
	public systemMetrics = SystemMetrics usingApi: api.
	public fontMapper = FontMapper usingApi: api.
	doubleBufferingSurfaceManager = DoubleBufferingSurfaceManager new.
	public textMeasurer = TextMeasurer new.
	paraformatWithStandardTabStops = createParaformatWithStandardTabStops.
	dragCueWindow
	lastActivity ::= 0.
|gdiPlus startup.
	textMeasurer startup) (
class DoubleBufferingSurfaceManager = (
(* Responsible for managing double buffering bitmaps we use for painting things. Holds onto one bitmap and its extent. A client requests a bitmap to use by sending #withBitmapOfExtent:for:do:.

The action block is evaluated with a Bitmap instance of the extent at least equal to the requested. If the existing bitmap is large enough, it is reused. If not, the old one is released and a new one is created. The instance has an 'inUse' lock. An error is signalled if a buffer is requested while the action block of a prior #withBitmapOfExtent:for:do: request is still running. *)
|
	bitmaps
	extents
	inUse ::= false.
|) (
NOCACHEwithBitmapOfExtent: requestedExtent <Point> do: action <Block> = (
	(* For now the caching is essentially off, because of what looks like some strange interplay in GDI+ whereby using a bitmap to draw in one window seems to clip it when later drawing in another. *)
	inUse ifTrue: [^error: 'nested call to double buffering manager - bitmap in use'].
	inUse: true.
	createBitmapOfExtent: requestedExtent.
	^[action value: bitmap] ensure:
		[bitmap release.
		bitmap:: nil.
		inUse:: false]
)
ORIGwithBitmapOfExtent: requestedExtent <Point> do: action <Block> = (
	inUse ifTrue: [^error: 'nested call to double buffering manager - bitmap in use'].
	inUse: true.
	(bitmap isNil or: [extent < requestedExtent])
		ifTrue:
			[bitmap notNil ifTrue: [bitmap release].
			createBitmapOfExtent: requestedExtent].
	^[action value: bitmap] ensure: [inUse: false]
)
protected createBitmapOfExtent: requestedExtent <Point> = (
	^gdiPlus Bitmap
		width: requestedExtent x
		height: requestedExtent y
		format: 2498570 (* 32bppARGB (10 | (32 << 8) | 16r40000 | 16r20000 | 16r200000) *).
)
public resetForNewImageSession = (
	bitmaps:: nil.
	extents:: nil.
	inUse:: false.
)
withBitmapOfExtent: requestedExtent <Point> do: action <Block> = (
	(* For now the caching is in fact off, until we find out how to get GDI+ not to let what appears to be clipping for an earlier drawing affect a later one. *)
	| result bitmap |
	bitmap:: createBitmapOfExtent: requestedExtent.
	^[action value: bitmap] ensure:
		[bitmap release]
)
) : (
)
class DragCueWindow image: theImage <Form> at: initialTopLeft <Point> = (
(* Instances of this class are created to show and manage the transparent window that displays the dragged object during a drag-and-drop operation. *)
|
	image = theImage.
	topLeft ::= initialTopLeft.

	public handle ::= 0.
	protected paintstruct
|) (
public close = (
	api DestroyWindow signedValue: handle.
	handle:: 0.
	paintstruct ifNotNil:
		[paintstruct free.
		paintstruct:: nil].
)
public destroy = (
	handle ifNotNil:
		[(api DestroyWindow signedValue: handle) ~= 0 ifTrue:
			[handle: nil]]
)
public dwExStyle = (
	^api WS_EX_LAYERED
	| api WS_EX_TRANSPARENT
	| api WS_EX_TOPMOST
	| api WS_EX_NOACTIVATE
)
public dwStyle = (
	^api WS_POPUP
)
extent = (
	^image extent
)
public initialWindowBounds = (
	^topLeft - (extent // 2) extent: extent
)
public invokeDefWindowProc: args <WindowProc> = (
	^api DefWindowProc
		unsignedValue: args hwnd
		value: args message
		value: args wParam
		value: args lParam
)
public isOpen ^<Boolean> = (
	^handle ~= 0
)
public moveTo: newTopLeft <Point> = (
	topLeft:: newTopLeft.
	isOpen ifTrue:
		[api MoveWindow
			value: handle
			value: topLeft x - (image width // 2)
			value: topLeft y - (image height // 2)
			value: image width
			value: image height
			value: 1 (* update after move *)]
)
public open = (
	draggedImageWindowClass createWindowForAgent: self.
	handle = 0 ifTrue: [^api reportError: 'DragCue window creation failed'].
	paintstruct:: api PAINTSTRUCT newC.
	api ShowWindow value: handle value: api SW_SHOW.
	api SetLayeredWindowAttributes
		value: handle
		value: 0 (* color key, only used if last param is 1 *)
		value: 160 (* alpha, only used if last param is 2 *)
		value: 1.
	api UpdateWindow value: handle.
)
public parentHandle = (
	^0
)
public processWM_ERASEBKGND: args <WindowProc> = (
	^1
)
processWM_PAINT: args <WindowProc> = (
	| hdc graphics bitmap result |
	hdc:: api BeginPaint unsignedValue: handle value: paintstruct address.
(*	(Alien newCString: 'Foo!') freeAfter:
		[:cString |
		api TextOut
			value: hdc
			value: 0
			value: 0
			value: cString address
			value: 4]. *)
	graphics:: windowsSession gdiPlus Graphics fromHDC: hdc.
	bitmap:: windowsSession imageMapper map: image forGraphics: graphics.
	result:: graphics drawImage: bitmap at: 0 @ 0.
(*	result = 0 ifFalse: ['DrawImage() failed']. *)
	graphics release.
	api EndPaint value: handle value: paintstruct address.
	^0
)
public processWindowsMessage: args <WindowProc> = (
	(* This message is sent by the WindowsSession of this mapping when a Windows message is received for the window created by this agent. *)
	| message |
	message:: args message.
	message = api WM_ERASEBKGND ifTrue: [^processWM_ERASEBKGND: args].
	message = api WM_PAINT ifTrue: [^processWM_PAINT: args].
	^invokeDefWindowProc: args.
)
public resetForNewImageSession = (
	handle:: 0.
	paintstruct:: 0.
)
public title = (
	^''
)
) : (
)
class FontMapper usingApi: api_ = (
(* Manages Windows font handles corresponding to Brazil fonts. *)
|
	private api = api_.
	fontHandlesBySize = Map new.
	arialFont = FontPreference forFaceNamed: 'Arial' sizes: {10. 11. 13. 16. 20}.
	verdanaFont = FontPreference forFaceNamed: 'Verdana' sizes: {9. 10. 11. 13. 16}.
	georgiaFont = FontPreference forFaceNamed: 'Georgia' sizes: {10. 11. 13. 16. 20}.
	consolasFont = FontPreference forFaceNamed: 'Consolas' sizes: {10. 11. 13. 16. 20}.
	defaultFont ::= arialFont.
	preferredSize ::= #regular (* One of #regular #large #huge *).
	charSet
|) (
class FontPreference forFaceNamed: fn <String> sizes: sizes <Array> = (|
	public faceName = fn.
	public fontSizes = sizes.
|) (
hugeFontSizes = (
	^fontSizes * 1.5 collect: [:i | i rounded]
)
largeFontSizes = (
	^fontSizes * 1.2 collect: [:i | i rounded]
)
preferredSizes = (
	preferredSize = #large ifTrue: [^largeFontSizes].
	preferredSize = #huge  ifTrue: [^hugeFontSizes].
	^fontSizes
)
) : (
)
createFontHandleForSize: size <Integer> ^<Integer> = (
	| hfont |
	#BOGUS yourself. (* See output quality below. *)
	(Alien newCString: defaultFont faceName) freeAfter:
		[:faceName |
		hfont:: api CreateFont unsignedValueWithArguments: {
			size negated. (* height *)
			0.		(* width *)
			0.		(* escapement *)
			0.		(* orientation *)
			0.		(* weight *)
			0.		(* italic *)
			0.		(* underline *)
			0.		(* strikeout *)
			defaultCharsetId.		(* char set id *)
			0. (* output precision *)
			0.		(* clipping precision *)
			api NONANTIALIASED_QUALITY. (* output quality. Note: DEFAULT_QUALITY or PROOF_QUALITY should be used here, but currently that causes bad rendering in GDI+ device contexts. Don't know if this is a genuine Windows flaw or just us not initializing something the right way. *)
			0.		(* pitch and family *)
			faceName address}.
		hfont = 0 ifTrue: [^api reportError: 'CreateFont() failed']].
	^hfont
)
defaultCharsetId ^<Integer> = (
(*
	      Map codepage to charset. Source for codepages: https://en.wikipedia.org/wiki/Code_page. Source for charset: WinGDI.h
*)
	|codepage|
	charSet isNil ifTrue: [
		codepage:: api KernelDLL GetACP unsignedValue.
		charSet:: ({
			1250 -> 238. (* EASTEUROPE_CHARSET *)
			1251 -> 204. (* RUSSIAN_CHARSET *)
			1253 -> 161. (* GREEK_CHARSET *)
			1254 -> 162. (* TURKISH_CHARSET *)
			1255 -> 177. (* HEBREW_CHARSET *)
			1256 -> 178. (* ARABIC_CHARSET *)
			1257 -> 186. (* BALTIC_CHARSET *)
			1258 -> 222. (* VIETNAMESE_CHARSET *)
			874 -> 163. (* THAI_CHARSET *)}
				detect: [:elt| elt key = codepage] ifNone: [0 -> 0]) value.
	].
	^charSet
)
public defaultControlFontHandle ^<Integer> = (
	^handleForFont: Font normal
)
defaultFontSizesMap = (
	^defaultFont fontSizes
)
private fontSizesMap = (
	(* Return a five-element array defining pixel sizes of Windows fonts to use as mappings of Brazil fonts in the following order: tiny, small, normal, large, huge. *)
	^defaultFontSizesMap
)
public handleForFont: font <Font> = (
	| translatedSize |
	translatedSize:: fontSizesMap at: font sizeX.
	^fontHandlesBySize
		at: translatedSize
		ifAbsentPut: [createFontHandleForSize: translatedSize]
)
public resetForNewImageSession = (
	charSet:: nil.
	fontHandlesBySize keys do: [:each | fontHandlesBySize removeKey: each]
)
) : (
)
class ImageMapper = (
(* Translates Squeak Image instances to GDI+ cached bitmaps and maintains a cache of translated bitmaps. Only supports 32-bit ARGB images. *)
|
	bitmapsByImage ::= IdentityMap new: 100.
|) (
public map: image <Form> forGraphics: graphics <Graphics> ^<CachedBitmap> = (
	^bitmapsByImage
		at: image
		ifAbsentPut:
			(* [translateImage: image forGraphics: graphics] *)
			[translateToBitmap: image using: gdiPlus]
)
public resetForNewImageSession = (
	bitmapsByImage:: IdentityMap new: 100
)
private translateImage: image <Form> forGraphics: graphics <Graphics> ^<CachedBitmap> = (
	| gdip bitmap cached |
	gdip:: gdiPlus.
	bitmap:: translateToBitmap: image using: gdip.
	cached:: gdip CachedBitmap bitmap: bitmap graphics: graphics.
	bitmap release.
	^cached
)
private translateToBitmap: image <Form> using: gdip <GDIplus> ^<Bitmap> = (
	(* Create and answer a Bitmap equivalent to the image. The sender is responsible for releasing the bitmap. The alien representing the static bits allocated here to hold the image are retained by the bitmap and released by it later. *)
	| byteSize staticBits imageBits result |
	image depth ~= 32 ifTrue: [error: 'Invalid image depth'].
	image unhibernate. (* This is needed to ensure that the image bits are indeed a Bitmap with valid data in ARGB format and not some compressed crap. *)
	imageBits:: image bits.
	byteSize:: imageBits byteSize.
	staticBits:: Alien rawNewC: byteSize.
	staticBits replaceFrom: 1 to: byteSize with: imageBits startingAt: 1.
	result:: gdip Bitmap
		width: image width
		height: image height
		stride: image width * 4
		format: 2498570 (* 32bppARGB (10 | (32 << 8) | 16r40000 | 16r20000 | 16r200000) *)
		bits: staticBits. (* now owned by the Bitmap; will be released by it *)
	^result
)
) : (
)
class SystemMetrics usingApi: api_ <Win32API> = (
(* Provides access to system metrics such as scrollbar sizes etc. *)
|
	private api = api_.
|) (
public desktopBounds ^<Rectangle> = (
	(* The bounds of the main screen. *)
	| width height |
	width:: api GetSystemMetrics unsignedValue: api SM_CXSCREEN.
	height:: api GetSystemMetrics unsignedValue: api SM_CYSCREEN.
	^0 @ 0 extent: width @ height
)
public scrollbarHeight ^<Integer> = (
	(* The height of a horizontal scrollbar in pixels. *)
	| result |
	result:: api GetSystemMetrics signedValue: api SM_CYHSCROLL.
	result = 0 ifTrue: [^api reportError: 'GetSystemMetrics() failed'].
	^result
)
public scrollbarWidth ^<Integer> = (
	(* The width of a vertical scrollbar in pixels. *)
	| result |
	result:: api GetSystemMetrics signedValue: api SM_CXVSCROLL.
	result = 0 ifTrue: [^api reportError: 'GetSystemMetrics() failed'].
	^result
)
virtualDesktopBounds ^<Rectangle> = (
	(* The virtual desktop is the rectangle containing all physical screens. *)
	| width height |
	width:: api GetSystemMetrics unsignedValue: api SM_CXVIRTUALSCREEN.
	height:: api GetSystemMetrics unsignedValue: api SM_CYVIRTUALSCREEN.
	^0 @ 0 extent: width @ height
)
workArea ^<Rectangle> = (
	(* SPI_GETWORKAREA: Retrieves the size of the work area on the primary display monitor. The work area is the portion of the screen not obscured by the system taskbar or by application desktop toolbars. (MSDN) *)
	^api RECT newC freeAfter:
		[:rect | | result |
		result:: api SystemParametersInfo
			unsignedValue: api SPI_GETWORKAREA
			value: 0
			value: rect address
			value: 0.
		result = 0
			ifTrue:
				[api reportError: 'SystemParametersInfo() failed'.
				0 @ 0 extent: 1024 @ 768]
			ifFalse:
				[rect asRectangle]]
)
) : (
)
class TextMeasurer = (
(* Manages an invisible window with a text control that we use to measure natural extent of rich edit controls. An instance used for that is maintained by WindowsSession. *)
|
	public handle ::= 0.
	public textEditorHandle ::= 0.
	protected requestResizeContinuation
|) (
createTextEditor = (
	| eventMask hfont |
	ensureRichEdit20Loaded.
	(Alien newCString: 'RICHEDIT20A') freeAfter:
		[:className |
		textEditorHandle:: api CreateWindowEx unsignedValueWithArguments: {
			api WS_EX_CLIENTEDGE.
			className address.
			0.
			api WS_VISIBLE | api WS_CHILD | api ES_MULTILINE.
			0.
			0.
			10000.
			10000.
			handle.
			0.
			applicationInstanceHandle.
			0}.
		].
	textEditorHandle = 0 ifTrue:
		[api reportError: 'TextMeasurer control creation failed'].
	eventMask:: sendMessage: api EM_GETEVENTMASK wParam: 0 lParam: 0.
	sendMessage: api EM_SETEVENTMASK
		wParam: 0
		lParam: eventMask
				| api ENM_REQUESTRESIZE
				| api ENM_CHANGE
				| api ENM_KEYEVENTS.
	hfont:: fontMapper defaultControlFontHandle.
	sendMessage: api WM_SETFONT wParam: hfont lParam: 1.
)
public destroy = (
	handle ifNotNil:
		[(api DestroyWindow signedValue: handle) ~= 0 ifTrue:
			[handle: nil]]
)
public dwExStyle = (
	^0
)
public dwStyle = (
	^api WS_OVERLAPPEDWINDOW
)
public initialWindowBounds = (
	^0 @ 0 extent: 10000 @ 10000
)
public invokeDefWindowProc: args <WindowProc> = (
	^api DefWindowProc
		unsignedValue: args hwnd
		value: args message
		value: args wParam
		value: args lParam
)
public measureText: text <String> heightForWidth: width <Number> ^<Number> = (
	setEditorText: text.
	setEditorWidth: width.
	^requestEditorCurrentNaturalHeight
)
public parentHandle = (
	^0
)
public processWM_NOTIFY: args = (
	| header requested |
	header:: api NMHDR atAddress: args lParam.
	header code = api EN_REQUESTRESIZE ifTrue:
		[requestResizeContinuation notNil ifTrue:
			[requested:: (api REQRESIZE atAddress: header address) asRectangle.
			requestResizeContinuation value: requested]
		].
	^0
)
public processWindowsMessage: args <WindowProc> = (
	(* This message is sent by the WindowsSession of this mapping when a Windows message is received for the window created by this agent. *)
	args message = api WM_NOTIFY ifTrue:
		[^processWM_NOTIFY: args].
	^invokeDefWindowProc: args.
)
requestEditorCurrentNaturalHeight ^<Number> = (
	| answer |
	answer:: 0.
	requestResizeContinuation:: [:desiredRect | answer:: desiredRect height].
	sendMessage: api EM_REQUESTRESIZE wParam: 0 lParam: 0.
	requestResizeContinuation:: nil.
	^answer
)
public resetForNewImageSession = (
	handle:: 0.
	textEditorHandle:: 0.
	requestResizeContinuation:: nil.
)
sendMessage: msg <Integer> wParam: wParam <Integer> lParam: lParam <Integer> ^<Integer> = (
	(* Send a Windows message to the agent's Windows window. *)
	^api SendMessage
		unsignedValue: textEditorHandle
		value: msg
		value: wParam
		value: lParam
)
setEditorText: newText <String | Text> = (
	(Alien newCString: newText asString) freeAfter:
		[:cString |
		sendMessage: api WM_SETTEXT
		wParam: 0
		lParam: cString address].
	newText isText ifTrue:
		[TextDecorator decorateControlWithHandle: textEditorHandle accordingTo: newText].
)
setEditorWidth: width <Number> = (
	api MoveWindow
		value: textEditorHandle
		value: 0 (* x *)
		value: 0 (* y *)
		value: width
		value: 10000 (* height *)
		value: 0 (* don't redraw *)
)
public startup = (
	textMeasurerWindowClass createWindowForAgent: self.
	handle = 0 ifTrue: [api reportError: 'TextMeasurer window creation failed'].
	createTextEditor.
(*	api ShowWindow value: handle value: api SW_SHOW. *)
)
public title = (
	^'BrazilTextMeasurer'
)
) : (
)
class WindowClass name: theName <String> style: styleBits <Integer> bg: theBrush = (
(* Represents a Windows window class, manages its registration and dispatches Windows notifications to agent instances open as windows of this class. *)
|
	name <String> = theName.
	style <Integer> = styleBits.
	bgBrush <Integer> = theBrush.
	public iconIdOrName

	classAtom <Integer> ::= 0.
	className <Alien>
	windowProc <Callback>
	classStruct <Alien>

	public agentsByHandle ::= Map new: 10.
	lastHandle
	lastAgent
	agentBeingCreated

	 (* Bound locally for dispatch speed: *)
	defWindowProc = api DefWindowProc.
	createWindowEx = api CreateWindowEx.
|) (
public createWindowForAgent: agent <Agent> = (
	| title bounds handle |
	ensureRegistration.
	agentBeingCreated:: agent.
	title:: agent title asAlien.
	bounds:: agent initialWindowBounds.
	handle:: createWindowEx
		unsignedValue: agent dwExStyle (* dwExStyle *)
		value: className address (* lpClassName *)
		value: title address (* lpWindowName *)
		value: agent dwStyle (* dwStyle *)
		value: bounds left
		value: bounds top
		value: bounds width
		value: bounds height
		value: agent parentHandle
		value: 0 (* hMenu *)
		value: applicationInstanceHandle (* hInstance *)
		value: 0. (* lParam *)
	(* The window gets registered in the agentsByHandle dictionary
	by #dispatchMessage: on receipt of WM_NCCREATE. *)
	title free.
	handle = 0 ifTrue: [api reportError: 'CreateWindowEx failed']
)
dispatchMessage: args <WindowProc> ^<Integer> = (
	^dispatchMessageUnsafe: args
)
dispatchMessageUnsafe: args <WindowProc> ^<Integer> = (
	(* This is the body of the callback registered as this class's window function. We find the agent corresponding to the window handle we got in args and let the real object process the message. This runs as a callback which makes it unsafe in the sense that an unhandled exception will lead to a catastrophic crash. *)

	| handle |
	lastActivity:: Time millisecondClockValue.
	handle:: args hwnd.

	(* The most common case: same window as the last time. *)
	lastHandle = handle ifTrue:
		[^lastAgent processWindowsMessage: args].

	(* Second most common case: an existing window. *)
	(agentsByHandle at: handle ifAbsent: [nil]) ifNotNil:
		[:agent |
		lastHandle:: handle.
		lastAgent:: agent.
		^agent processWindowsMessage: args].

	(* Least common case: the window being created whose handle we haven't registered yet. *)
	(agentBeingCreated notNil and: [args message = (* WM_NCCREATE *) 129]) ifTrue:
		[lastHandle:: handle.
		lastAgent:: agentBeingCreated.
		agentsByHandle at: handle put: agentBeingCreated.
		agentBeingCreated handle: handle.
		agentBeingCreated:: nil.
		^lastAgent processWindowsMessage: args].

	(* Ideally we are not supposed to fall through to here,
	but this is Windows and we are making no assumptions. *)
	^defWindowProc
		unsignedValue: args hwnd
		value: args message
		value: args wParam
		value: args lParam
)
ensureRegistration = (
	isRegistered ifFalse:
		[setupClassName.
		setupWindowProc.
		setupClassStruct.
		registerWindowClass]
)
isRegistered ^<Boolean> = (
	^classAtom ~= 0
)
loadIcon = (
	^iconIdOrName
		ifNil: [loadApplicationIcon]
		ifNotNil: [iconIdOrName isString
			ifTrue: [loadIconWithName: iconIdOrName]
			ifFalse: [loadIconWithId: iconIdOrName]]
)
loadIconWithId: iconId <Integer> = (
	(* Get a handle to the icon with the given integer ID stored in this application. *)
	| iconHandle |
	iconHandle:: api LoadIcon
		unsignedValue: applicationInstanceHandle
		value: (iconId bitAnd: 16rFFFF).
	iconHandle = 0 ifTrue: [api reportError: 'LoadIcon failed'].
	^iconHandle
)
loadIconWithName: iconName <String> = (
	(* Get a handle to the icon with the given name stored in this application. *)
	^(Alien newCString: iconName) freeAfter:
		[:cString | | iconHandle |
		iconHandle:: api LoadIcon
			unsignedValue: applicationInstanceHandle
			value: cString.
		iconHandle = 0 ifTrue: [api reportError: 'LoadIcon failed'].
		iconHandle]
)
protected registerWindowClass = (
	| result |
	api UnregisterClass value: className address value: applicationInstanceHandle.
	result:: api RegisterClass unsignedValue: classStruct address.
	result = 0 ifTrue: [^api reportError: 'RegisterClass failed'].
	classAtom:: result
)
public resetForNewImageSession = (
	classAtom:: 0.
	className:: nil.
	windowProc:: nil.
	classStruct:: nil.
	agentsByHandle do: [:each | each resetForNewImageSession].
	agentsByHandle:: Map new: 10.
	agentBeingCreated:: nil.
	lastHandle:: nil.
	lastAgent:: nil.
)
protected setupClassName = (
	className:: Alien newCString: name.
)
protected setupClassStruct = (
	classStruct:: api WNDCLASS newC.
	classStruct
		style: style;
		lpfnWndProc: windowProc thunk asUnsignedLong;
		hInstance: applicationInstanceHandle;
		hIcon: loadIcon;
		hCursor: loadArrowCursor;
		hbrBackground: bgBrush;
		lpszClassName: className address.
)
protected setupWindowProc = (
	windowProc::
		api Callback
			block: [:args :result | result returnInteger: (dispatchMessage: args)]
			stdcallArgsClass: api WindowProc
)
protected unregisterWindowClass = (
	api UnregisterClass value: className address value: applicationInstanceHandle.
)
public unregisterWindowForAgent: agent <WindowAgent> = (
	agentsByHandle removeKey: agent handle ifAbsent: [^self].
	agent handle: nil
)
) : (
)
api = (
	^outer BrazilMappingForWin32 api
)
public applicationInstanceHandle ^<Integer> = (
	(* Return Windows instance handle (i.e. hInstance) for this application. *)
	^applicationInstanceHandle_ ifNil:
		[applicationInstanceHandle_:: api GetModuleHandle unsignedValue: 0.
		applicationInstanceHandle_]
)
createParaformatWithStandardTabStops = (
	| twipsPerStop totalStops paraformat |
	twipsPerStop:: 360. (* 1/4 inch; 1440 twips = 1 inch *)
	totalStops:: 32.
	paraformat:: api PARAFORMAT new.
	paraformat
		dwMask: api PFM_TABSTOPS;
		cTabCount: totalStops.
	1 to: totalStops do:
		[:index |
		paraformat rgxTabsAt: index put: index * twipsPerStop].
	^paraformat
)
public disableAll = (
	| isWindow isWindowVisible |
	isWindow:: api IsWindow.
	isWindowVisible:: api IsWindowVisible.
	topLevelWindowsDo:
		[:hwnd |
		((isWindow boolValue: hwnd) and: [isWindowVisible  boolValue: hwnd]) ifTrue:
			[api EnableWindow boolValue: hwnd value: 0]].
	squeakWindowHandle ifNotNil:
		[:hwnd | api EnableWindow boolValue: hwnd value: 0].
)
public enableAll = (
	| isWindow isWindowVisible |
	isWindow:: api IsWindow.
	isWindowVisible:: api IsWindowVisible.
	topLevelWindowsDo:
		[:hwnd |
		((isWindow boolValue: hwnd) and: [isWindowVisible  boolValue: hwnd]) ifTrue:
			[api EnableWindow boolValue: hwnd value: 1]].
	squeakWindowHandle ifNotNil:
		[:hwnd | api EnableWindow boolValue: hwnd value: 1].
)
public ensureRichEdit20Loaded = (
	richEdit20Handle = 0 ifTrue:
		[(Alien newCString: 'Riched20.dll') freeAfter:
			[:dllName |
			richEdit20Handle:: api LoadLibrary unsignedValue: dllName address]].
	richEdit20Handle = 0 ifTrue:
		[error: 'failed to load Riched20.dll'].
)
getStockWhiteBrush = (
	^api GetStockObject unsignedValue: api WHITE_BRUSH
)
loadApplicationIcon = (
	^api LoadIcon unsignedValue: 0 value: api IDI_APPLICATION
)
loadArrowCursor = (
	^api LoadCursor unsignedValue: 0 value: api IDC_ARROW
)
logError: ex <Error> = (
	| signaler |
	signaler:: ex signalerContext.
	Transcript
		cr;
		nextPutAll: Time now printString;
		nextPutAll: ': ';
		nextPutAll: (safePrintStringOf: ex);
		nextPutAll: ' (dumped to log file)'.
	dumpError: ex toLog: 'brazilErrors.log'.
	Transcript flush
)
public moveDragCueTo: point = (
	dragCueWindow ifNotNil: [dragCueWindow moveTo: point]
)
public placeDragCue: image <Form> at: topLeft <Point> = (
	dragCueWindow ifNotNil: [dragCueWindow close].
	dragCueWindow:: DragCueWindow image: image at: topLeft.
	dragCueWindow open
)
public removeDragCue = (
	dragCueWindow ifNotNil:
		[dragCueWindow close.
		dragCueWindow:: nil].
)
public resetForContinuingImageSession= (

	textMeasurer destroy.
	dragCueWindow ifNotNil: [:it | it destroy].

	standardTopLevelWindowClass unregisterWindowClass.
	viewportWindowClass unregisterWindowClass.
	viewportContentCarrierWindowClass unregisterWindowClass.
	textMeasurerWindowClass unregisterWindowClass.
	draggedImageWindowClass unregisterWindowClass.
)
public resetForNewImageSession = (
	(* This message is normally sent by the containing BrazilMappingForWin32 on image restart. When this happens, any OS data in the session is invalid. *)
	applicationInstanceHandle_:: nil.
	richEdit20Handle:: 0.
	gdiPlus resetForNewImageSession.

	standardTopLevelWindowClass resetForNewImageSession.
	viewportWindowClass resetForNewImageSession.
	viewportContentCarrierWindowClass resetForNewImageSession.
	textMeasurerWindowClass resetForNewImageSession.
	draggedImageWindowClass resetForNewImageSession.

	imageMapper resetForNewImageSession.
	fontMapper resetForNewImageSession.
	doubleBufferingSurfaceManager resetForNewImageSession.
	dragCueWindow ifNotNil: [:it | it resetForNewImageSession].
	dragCueWindow:: nil.
)
public topLevelWindowsDo: action <[:Integer]> = (
	standardTopLevelWindowClass agentsByHandle keysDo: action
)
) : (
)
STILL_LEFT_TO_DO = (
(*

Clean up the implementation of current mouse input receiver and entry/exit notifications by WindowContentManager to ensure containment is handled properly. If a control A is nested inside B, entering A should not trigger the exit on B.

List box: Implement natural extent computation.

Check on list box scroll bar weirdness in Smalltalk browser example.

TextView: tab width, !colors.

Viewport:

	Gradient background is not painted.

All colored visuals (NullColoredAgent): gradients are assumed to be vertical.

Clean up error checking and reporting in GDI+ wrapper.

Think of a civilized (Brazil-level) scheme to capture input event parameters such as control and shift button states so that presenter can make navigation decision based on that information.

Rename ImageAgent to IconAgent.

Rename ActiveImageAgent to ActiveIconAgent. Ditto for ActiveImageAgentStateClasses.

Rename WindowContentManager to WindowInputManager.

Maybe optimize Agent>>mousePoint to only walk the host hierarchy, and only once.

*) error: 'documentation only'
)
appendStackToLog: filename= (
	| signaler |
	appendToLogWithTimestamp: filename using:
		[:stream |
		100 timesRepeat:
			[stream
				cr;
				nextPutAll: (safePrintStringOf: signaler).
			signaler:: signaler sender.
			signaler ifNil: [^self]]]
)
appendToLog: filename using: action = (
	(* As a debugging aid in contexts where the debugger is not available, we provide this as a means of easily dumping some information into a file. *)
	| file |
	file:: FileStream fileNamed: filename asFileName.
	file setToEnd.
	^[action value: file] ensure: [file close]
)
appendToLogWithMs: filename using: action = (
	(* As a debugging aid in contexts where the debugger is not available, we provide this as a means of easily dumping some information into a file. *)
	appendToLog: filename using:
		[:file |
		file cr; nextPutAll: Time millisecondClockValue printString; space.
		action value: file]
)
appendToLogWithTimestamp: filename using: action = (
	(* As a debugging aid in contexts where the debugger is not available, we provide this as a means of easily dumping some information into a file. *)
	appendToLog: filename using:
		[:file |
		file
			cr;
			nextPutAll: '----------------------------------------------'; cr;
			nextPutAll: TimeStamp now printString; cr;
			nextPutAll: '----------------------------------------------'.
		action value: file]
)
dumpError: ex <Error> toLog: filename= (
	| signaler |
	appendToLogWithTimestamp: filename using:
		[:stream |
		signaler:: ex signalerContext.
		stream cr; nextPutAll: (safePrintStringOf: ex).
	100 timesRepeat:
		[stream
			cr;
			nextPutAll: (safePrintStringOf: signaler).
		signaler:: signaler sender.
		signaler ifNil: [^self]]]
)
public resetForContinuingImageSession = (
)
public resetForNewImageSession = (
	api resetForNewImageSession.
	windowsSession resetForNewImageSession
)
private safePrintStringOf: object ^<String> = (
	^[object printString]
		on: Error
		do: [:ex | ex return: '<printString error>']
)
withLogFileNamed: filename do: action = (
	(* As a debugging aid in contexts where the debugger is not available, we provide this as a means of easily dumping some information into a file. *)
	| file |
	file:: FileStream fileNamed: filename asFileName.
	file print: TimeStamp now; cr.
	^[action value: file] ensure: [file close]
)
) : (
)