Newsqueak2
'Sudoku'

class HopscotchExtensions usingPlatform: platform = NewspeakObject (
"Copyright 2010-2011 Vadim Tsushko.

Permission is hereby granted, free of charge, to any person
 obtaining a copy of this software and associated documentation
 files (the ''Software''), to deal in the Software without
 restriction, including without limitation the rights to use,
 copy, modify, merge, publish, distribute, sublicense, and/or sell
 copies of the Software, and to permit persons to whom the
 Software is furnished to do so, subject to the following
 conditions:

 The above copyright notice and this permission notice shall be
 included in all copies or substantial portions of the Software.

 THE SOFTWARE IS PROVIDED ''AS IS'', WITHOUT WARRANTY OF ANY KIND,
 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
 OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
 HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
 OTHER DEALINGS IN THE SOFTWARE.
"
|
	private Subject = platform hopscotch core Subject.
	private Grid = platform brazil containers Grid.
	private SequenceComposer = platform hopscotch composers SequenceComposer.
	private BlankFragment = platform hopscotch fragments BlankFragment.
	private Color = platform Color.
	private Presenter = platform hopscotch core Presenter.
	api = platform Win32API Win32API platform: platform.
	Alien = platform NsFFI Alien.
	tooltipImplementation = TooltipImplementation new.
	Decorator = platform hopscotch core Decorator.
	OrderedCollection = platform collections OrderedCollection.
	
	
	
	tooltipAgent = tooltipImplementation TooltipAgent new.
	
	HopscotchWindow =  platform hopscotch core HopscotchWindow.
|
)
(

class PresenterExt onSubject: s = Presenter onSubject: s(
"Contains protocol extensions to Hopscotch Presenter. Intended to be used instead of standard Hopscotch Presenter"
)
('as yet unclassified'
fragment: aFragment <Fragment> withTooltip: tooltip <String>  ^ <Fragment>= (
	aFragment addDecorator: (tooltipImplementation TooltipDecorator new tooltipText: tooltip).
	^aFragment.
)

gridWithRows: rowCount <Integer> columns: columnCount <Integer> cellFragmentBlock: cellFragmentBlock <Block> = (
	^GridComposer rows: rowCount columns: columnCount cellFragmentBlock: cellFragmentBlock
)

noticeExposure = (
	super noticeExposure.
	tooltipAgent mapTools.
)

)

class TooltipImplementation = ()
(

class TooltipDecorator = Decorator (
|
	tooltipText
|
)
('as yet unclassified'
decorate: aVisual = (
	tooltipAgent setTooltip: tooltipText toVisual: aVisual. 	
	^aVisual.
)

)

class TOOLINFO  = (
"The TOOLINFO structure contains information about a tool in a tooltip control.

Syntax

Copy
typedef struct {
  UINT      cbSize;
  UINT      uFlags;
  HWND      hwnd;
  UINT_PTR  uId;
  RECT      rect;
  HINSTANCE hinst;
  LPTSTR    lpszText;
#if (_WIN32_IE >= 0x0300)
  LPARAM    lParam;
#endif 
#if (_WIN32_WINNT >= Ox0501)
  void      *lpReserved;
#endif 
} TOOLINFO, *PTOOLINFO, *LPTOOLINFO;"
|
	alien = Alien newC: dataSize.
	
	lpszText_
|"cbSize: dataSize."
)
('as yet unclassified'
bottom = (
	^alien unsignedLongAt: 29.
)

bottom: value <Integer> = (
	alien unsignedLongAt: 29 put: value.	
)

cbSize = (
	^alien unsignedLongAt: 1.
)

cbSize: size <Integer> = (
	alien unsignedLongAt: 1 put: size.	
)

dataSize = (
	^48
)

free = (
	alien free.
	lpszText_ notNil ifTrue: [lpszText_ free]
)

hWnd = (
	^alien unsignedLongAt: 9.
)

hWnd: value <Integer> = (
	alien unsignedLongAt: 9 put: value.	
)

hinst = (
	^alien unsignedLongAt: 33.
)

hinst: value <Integer> = (
	alien unsignedLongAt: 33 put: value.	
)

lParam = (
	^alien unsignedLongAt: 41.
)

lParam: value <Integer> = (
	alien unsignedLongAt: 41 put: value.	
)

left = (
	^alien unsignedLongAt: 17.
)

left: value <Integer> = (
	alien unsignedLongAt: 17 put: value.	
)

lpReserved = (
	^alien unsignedLongAt: 45.
)

lpReserved: value <Integer> = (
	alien unsignedLongAt: 45 put: value.	
)

lpszText = (
	^alien unsignedLongAt: 37.
)

lpszText: value <Integer> = (
	alien unsignedLongAt: 37 put: value.	
)

pointer = (
	^alien pointer
)

rect = (
	
)

right = (
	^alien unsignedLongAt: 25.
)

right: value <Integer> = (
	alien unsignedLongAt: 25 put: value.	
)

setText: text <ByteString> = (	
	lpszText_:: Alien newCString: text.
	lpszText: lpszText_ address.
)

top = (
	^alien unsignedLongAt: 21.
)

top: value <Integer> = (
	alien unsignedLongAt: 21 put: value.	
)

uFlags = (
	^alien unsignedLongAt: 5.
)

uFlags: value <Integer> = (
	alien unsignedLongAt: 5 put: value.	
)

uId = (
	^alien unsignedLongAt: 13.
)

uId: value <Integer> = (
	alien unsignedLongAt: 13 put: value.	
)

)

class TooltipAgent = (
	|
	windowHandle	
	tools = OrderedCollection new.
	handle
	nextId::=1.|
	
)
(

class Tool = (
"Represents individual TOOL as for TTM_ADDTOOL, TTM_DELTOOL messages"
|
	visual
	id
	tooltipText
|
)
('as yet unclassified'
parentHandle = (
	^visual agent parent handle
)

setId = (
	visualHasHandle ifTrue: [id:: visual agent handle]
		ifFalse: [id:: nextId. nextId:: nextId+1].
)

visualHasHandle = (
	^visual agent handle ~~ visual agent parent handle
)

)'as yet unclassified'
clearTools = (
	tools do: [:tool| unmapTool: tool].
	tools:: OrderedCollection new.
	nextId:: 1.
)

controlClassName = (
	^'tooltips_class32'
)

createOnWindow: window = (
	| className title windowRelativeBounds |
	className:: Alien newCString: controlClassName.
	windowHandle:: window agent handle.
	title:: Alien newCString: '' asString.
	handle:: api CreateWindowEx
		unsignedValueWithArguments: {
			0.
			className address.
			title address.
			dwStyle.
			0.
			0.
			0.
			0.
			windowHandle.
			0.
			window agent windowsSession applicationInstanceHandle.
			0}.
	className free.
	title free.
	handle = 0
		ifTrue:
			[api reportError: controlClassName, ' creation failed']
)

destroyOwnArtifacts = (
	handle ifNotNil:
		[api DestroyWindow value: handle.
		handle:: nil].
	tools:: OrderedCollection new.
)

dwStyle = (
	^1 "TTS_ALWAYSTIP"	
)

initCommonControls = (
"
typedef struct tagINITCOMMONCONTROLSEX {
  DWORD dwSize;
  DWORD dwICC;
}

BOOL  InitCommonControlsEx(
  __in  const LPINITCOMMONCONTROLSEX lpInitCtrls
);
ICC_WIN95_CLASSES 255
"
	|INITCOMMONCONTROLSEX r|
	
	INITCOMMONCONTROLSEX:: Alien newC: 8.
	INITCOMMONCONTROLSEX signedLongAt: 1 put: 8.
	INITCOMMONCONTROLSEX signedLongAt: 5 put: ICC_WIN95_CLASSES.
	(Alien lookup: 'InitCommonControlsEx' inLibrary: 'comctl32.dll')
	primFFICallResult: ( r:: Alien new: 4)
	with: INITCOMMONCONTROLSEX pointer.
	INITCOMMONCONTROLSEX free.
	(r boolAt: 1) ifFalse: [error: 'Error in InitCommonControlsEx function']
)

mapTool: tool = (
|toolInfo result rect|	
handle ~~ nil ifFalse: [createOnWindow: tool visual window].
toolInfo:: TOOLINFO new.
toolInfo hWnd: tool parentHandle.
toolInfo setText: tool tooltipText.
toolInfo uId: tool id.
tool visualHasHandle
		ifTrue: [toolInfo uFlags: TTF_SUBCLASS | TTF_IDISHWND]
		ifFalse: [toolInfo uFlags: TTF_SUBCLASS.
				rect:: tool visual agent parent rectangleRelativeToHostWindow: tool 				visual bounds.
				toolInfo top: rect top.
				toolInfo left: rect left.
				toolInfo bottom: rect bottom.
				toolInfo right: rect right.].
sendMessage: TTM_ADDTOOL wParam: 0 lParam: toolInfo pointer.
toolInfo free.
)

mapTools = (
	tools do: [:tool| tool id: tool visual agent handle. mapTool: tool].
)

sendMessage:  msg <Integer> wParam: wParam <Integer> lParam: lParam <Integer> ^<Integer> = (
	api SendMessage
	unsignedValue: handle
	value: msg
	value: wParam
	value: lParam
)

setTooltip: tooltip <String> toVisual: aVisual = (
|tool|	
tool:: Tool new.
tool visual: aVisual.
tool tooltipText: tooltip.
tools add: tool.
)

unmapTool: tool  = (
|toolInfo result|	
toolInfo:: TOOLINFO new.
toolInfo uFlags: TTF_IDISHWND|TTF_SUBCLASS.
toolInfo hWnd: tool parentHandle.
toolInfo uId: tool id.
sendMessage: TTM_DELTOOL wParam: 0 lParam: toolInfo pointer.
toolInfo free.
)

)'as yet unclassified'
ICC_WIN95_CLASSES = (
	^255
)

TTF_IDISHWND = (
	^1
)

TTF_SUBCLASS = (
	^16
)

TTM_ADDTOOL = (
	^WM_USER + 4
)

TTM_DELTOOL  = (
	^WM_USER + 5
)

TTS_ALWAYSTIP = (
	^1
)

WM_USER = (
	^1024
)

)

class SampleSubject onModel: m = Subject onModel: m (
)
('as yet unclassified'
createPresenter = (
	^SamplePresenter onSubject: self.	
)

)

class GridComposer rows: rowCount columns: columnCount cellFragmentBlock: cellBlock = SequenceComposer(
|
	rowCount = rowCount.
	columnCount = columnCount.
	cellBlock = cellBlock.
	defaultCellExtent
	grid
|childrenX:: Array new: rowCount * columnCount.
(1 to: rowCount) do: [:r|
					(1 to: columnCount) do: [:c| atRow: r column: c put: (cellBlock value: r value: c)]].
)
('as yet unclassified'
atRow: row column: column ^<Fragment>= (
	| index |
	index:: indexForRow: row column: column.
	^childrenX at: index
)

atRow: row column: column put: newFragment <Fragment>= (
	| index |
	newFragment isNil ifTrue: [^self].
	index:: indexForRow: row column: column.
	childrenX at: index put: newFragment.
	newFragment parent: self.
	hasVisual ifTrue:
		[visual at: column @ row put: newFragment visual]
)

createVisual = (
	grid:: Grid rows: rowCount columns: columnCount.	
	(1 to: rowCount) do: [:row|
					(1 to: columnCount) do: [:col| grid at: col @ row put: (atRow: row column: col) visual.
											     defaultCellExtent notNil 
													ifTrue: [grid extentAt: col @row is: defaultCellExtent]]].
	^grid
)

indexForRow: row column: column = (
	^((row-1) * columnCount) + column
)

)

class HopscotchWindowExt = HopscotchWindow (
""
|
|
)
('as yet unclassified'
addToolbarItemsTo: toolbar = (

	pastButton:: buildDropDown: [selectFromPast].
	toolbar add: (wrapToAlignToBottomCenter: pastButton).
	toolbar addBlankSize: 3.
	backButton:: toolbar add: buildBackButton.
	forwardButton:: toolbar add: buildForwardButton.
	toolbar addBlankSize: 3.
	futureButton:: buildDropDown: [selectFromFuture].
	toolbar add: (wrapToAlignToBottomCenter: futureButton).
	
	toolbar addBlankSize: 10.

	toolbar add: buildHistoryButton.
	toolbar addBlankSize: 2.

	homeButton:: toolbar add: buildHomeButton.

	toolbar addBlankSize: 10.	
	toolbar add: buildRefreshButton.
	toolbar addBlankSize: 2.
	toolbar add: buildNewButton.

	
	showOutline ifTrue:
		[toolbar addBlankSize: 10.
		toolbar add: buildToggleOutlineButton]

)

buildBackButton  = (
	| button|
	button:: super buildBackButton.
	tooltipAgent setTooltip: 'Go Back' toVisual: button.
	^button 
)

buildForwardButton  = (
	| button|
	button:: super buildForwardButton .
	tooltipAgent setTooltip: 'Go Forward' toVisual: button.
	^button 
)

buildHistoryButton = (
	| button|
	button:: super buildHistoryButton.
	tooltipAgent setTooltip: 'Browse history' toVisual: button.
	^button 
)

buildHomeButton  = (
	| button|
	button:: super buildHomeButton .
	tooltipAgent setTooltip: 'Go Home' toVisual: button.
	^button 
)

buildNewButton  = (
	| button|
	button:: super buildNewButton.
	tooltipAgent setTooltip: 'Create New Window' toVisual: button.
	^button 
)

buildRefreshButton  = (
	| button|
	button:: super buildRefreshButton.
	tooltipAgent setTooltip: 'Refresh Window' toVisual: button.
	^button 
)

respondToClose = (
	tooltipAgent destroyOwnArtifacts.
	super respondToClose.
)

) : (
'as yet unclassified'
openSubject: aSubject <Subject> = (
	^openSubjectFromBlock: [:instance | aSubject]
)

openSubjectFromBlock: aBlock = (
	^(withSubjectFromBlock: aBlock) open
)

withSubjectFromBlock: aBlock = (

	| instance |
	#BOGUS yourself. "copied from HopscotchShell"

	instance:: self new.
	instance subject: (aBlock value: instance).
	^instance
)

)

class SamplePresenter onSubject: s = PresenterExt onSubject: s (
|
	btn
|
)
('as yet unclassified'
clearTooltips = (
	tooltipAgent clearTools.
)

definition = (
	btn:: (button: 'With tooltip' action: [nothing]) .
	^column: { blank: 100. row: {blank: 100. fragment: (label: 'Label1') withTooltip: 'Tooltip for first label'.
button: 'Clear Tooltips' action: [clearTooltips].
		   fragment: btn withTooltip: 'Tooltip for button'.}.
		blank: 50.
		fragment: (label: 'Label2') withTooltip: 'Tooltip for label 2'.
	}.	

)

))