t5764-diag.red

Red [
	Title:	"Diagnostic for issue #5764"
	Needs:	'View
	Usage:	{
		Compile (routines require compilation, console target so output is visible):
			red -r -t MSDOS t5764-diag.red
		Run t5764-diag.exe, wait ~8 seconds until the window closes itself,
		then post the file t5764-diag.txt (written next to the exe).
	}
]

#system-global [
	RECT!: alias struct! [left [integer!] top [integer!] right [integer!] bottom [integer!]]
	PT!: alias struct! [x [integer!] y [integer!]]
	#import [
		"user32.dll" stdcall [
			GetWindowRect: "GetWindowRect" [hwnd [integer!] rc [RECT!] return: [integer!]]
			ClientToScreen: "ClientToScreen" [hwnd [integer!] pt [PT!] return: [integer!]]
			GetWindowLongW: "GetWindowLongW" [hwnd [integer!] idx [integer!] return: [integer!]]
			IsWindowVisible: "IsWindowVisible" [hwnd [integer!] return: [integer!]]
			GetDC: "GetDC" [hwnd [integer!] return: [integer!]]
			ReleaseDC: "ReleaseDC" [hwnd [integer!] dc [integer!] return: [integer!]]
			MonitorFromWindow: "MonitorFromWindow" [hwnd [integer!] flags [integer!] return: [integer!]]
			SetWindowPos: "SetWindowPos" [hwnd [integer!] after [integer!] x [integer!] y [integer!] cx [integer!] cy [integer!] flags [integer!] return: [integer!]]
		]
		"gdi32.dll" stdcall [
			GetPixel: "GetPixel" [dc [integer!] x [integer!] y [integer!] return: [integer!]]
			GetDeviceCaps: "GetDeviceCaps" [dc [integer!] cap [integer!] return: [integer!]]
		]
		"shcore.dll" stdcall [
			GetDpiForMonitor: "GetDpiForMonitor" [mon [integer!] type [integer!] dx [int-ptr!] dy [int-ptr!] return: [integer!]]
		]
	]
]

handle-int: routine [hf [any-type!] return: [integer!] /local h [red-handle!]][
	h: as red-handle! hf
	h/value
]

get-rect: routine [
	hf		[any-type!]
	sel		[integer!]
	return:	[integer!]
	/local
		h	[red-handle!]
		rc	[RECT! value]
][
	h: as red-handle! hf
	if 0 = GetWindowRect h/value rc [return -1]
	switch sel [
		1 [rc/left]
		2 [rc/top]
		3 [rc/right]
		4 [rc/bottom]
		default [0]
	]
]

get-origin: routine [
	hf		[any-type!]
	sel		[integer!]
	return:	[integer!]
	/local
		h	[red-handle!]
		pt	[PT! value]
][
	h: as red-handle! hf
	pt/x: 0
	pt/y: 0
	ClientToScreen h/value pt
	either sel = 1 [pt/x][pt/y]
]

get-exstyle: routine [hf [any-type!] return: [integer!] /local h [red-handle!]][
	h: as red-handle! hf
	GetWindowLongW h/value -20
]

visible?: routine [hf [any-type!] return: [integer!] /local h [red-handle!]][
	h: as red-handle! hf
	IsWindowVisible h/value
]

screen-pixel: routine [x [integer!] y [integer!] return: [integer!] /local dc [integer!] c [integer!]][
	dc: GetDC 0
	c: GetPixel dc x y
	ReleaseDC 0 dc
	c
]

window-dpi: routine [
	hf		[any-type!]
	return:	[integer!]
	/local
		h	[red-handle!]
		mon	[integer!]
		dx	[integer!]
		dy	[integer!]
][
	h: as red-handle! hf
	mon: MonitorFromWindow h/value 2			;-- MONITOR_DEFAULTTONEAREST
	dx: 0
	dy: 0
	GetDpiForMonitor mon 0 :dx :dy
	dx
]

system-dpi: routine [return: [integer!] /local dc [integer!] n [integer!]][
	dc: GetDC 0
	n: GetDeviceCaps dc 88						;-- LOGPIXELSX
	ReleaseDC 0 dc
	n
]

make-topmost: routine [hf [any-type!] /local h [red-handle!]][
	h: as red-handle! hf
	SetWindowPos h/value -1 0 0 0 0 19			;-- HWND_TOPMOST, SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE
]

;-------------------------------------------------------------------

log: copy ""
emit: func [s][append log s append log newline print s]

col-r: func [c][c and 255]
col-g: func [c][(to integer! c / 256) and 255]
col-b: func [c][(to integer! c / 65536) and 255]

classify: func [c [integer!] t [tuple!]][
	either all [
		60 > absolute (col-r c) - t/1
		60 > absolute (col-g c) - t/2
		60 > absolute (col-b c) - t/3
	]["MATCH"]["MISMATCH"]
]

hex6: func [c][copy skip to-string to-hex c 2]

imgR: make image! reduce [100x100 red]
imgB: make image! reduce [100x100 blue]
imgG: make image! reduce [100x100 green]

labels: [
	"image style, red img          "
	"base image + color: none, blue"
	"base image + gray bg, green   "
	"base glass + draw box, magenta"
]
expects: [255.0.0 0.0.255 0.255.0 255.0.255]

probe-face: func [f [object!] expected [tuple!] label [string!] factor [float!] ox [integer!] oy [integer!]
	/local h wl wt wr wb acx acy c1 v ecx ecy c2
][
	unless block? f/state [
		emit rejoin ["  " label " -> NOT REALIZED (state = none)"]
		exit
	]
	h: f/state/1
	wl: get-rect h 1
	wt: get-rect h 2
	wr: get-rect h 3
	wb: get-rect h 4
	acx: to integer! (wl + wr) / 2					;-- center of where the child window really is
	acy: to integer! (wt + wb) / 2
	c1: screen-pixel acx acy
	ecx: ox + to integer! factor * ((to float! f/offset/x) + ((to float! f/size/x) / 2.0))
	ecy: oy + to integer! factor * ((to float! f/offset/y) + ((to float! f/size/y) / 2.0))
	c2: screen-pixel ecx ecy
	emit rejoin [
		"  " label
		" hwnd: "     hex6 handle-int h
		" rect: "     wl "," wt ".." wr "," wb " (" wr - wl "x" wb - wt ")"
		" layered: "  either 0 <> (524288 and get-exstyle h)["Y"]["N"]	;-- WS_EX_LAYERED
		" visible: "  either 0 <> visible? h ["Y"]["N"]
	]
	emit rejoin [
		"      pixel at window center " acx "," acy ": " hex6 c1
		" [" classify c1 expected " vs " expected "]"
		" | at expected spot " ecx "," ecy ": " hex6 c2
		" [" classify c2 expected "]"
	]
]

run-pass: func [title [string!] /local wh factor ox oy i f][
	emit ""
	emit rejoin ["--- " title " ---"]
	unless block? win/state [emit "window NOT REALIZED" exit]
	wh: win/state/1
	make-topmost wh								;-- immune to other windows overlapping the sample points
	factor: (to float! window-dpi wh) / 96.0
	ox: get-origin wh 1
	oy: get-origin wh 2
	emit rejoin [
		"window hwnd: " hex6 handle-int wh
		" rect: " get-rect wh 1 "," get-rect wh 2 ".." get-rect wh 3 "," get-rect wh 4
		" client-origin: " ox "," oy
		" monitor-dpi: " window-dpi wh " (" to integer! factor * 100 "%)"
	]
	emit rejoin [
		"backdrop sanity pixel (should be FFFFFF): "
		hex6 screen-pixel ox + (to integer! factor * 225.0) oy + (to integer! factor * 115.0)
	]
	i: 1
	foreach f win/pane [
		probe-face f expects/:i labels/:i factor ox oy
		i: i + 1
	]
]

win: layout [
	title "t5764 diag"
	backdrop white
	at 10x10  image imgR
	at 120x10 base 100x100 with [image: imgB color: none]
	at 230x10 base 100x100 gray with [image: imgG]
	at 340x10 base 100x100 glass draw [fill-pen magenta pen magenta box 10x10 90x90]
]

emit rejoin ["Red version: " mold system/version "  build: " mold attempt [system/build/date]]
emit rejoin ["initial system/view/GPU?: " mold attempt [system/view/GPU?]]
emit rejoin ["system (session) DPI: " system-dpi]
emit rejoin ["screens: " mold attempt [length? system/view/screens]]

phase: 0
win/rate: 0:0:2
win/actors: object [
	on-time: func [f e][
		phase: phase + 1
		switch phase [
			1 [run-pass "PASS 1: as launched (GPU? default)"]
			2 [
				emit ""
				emit ">>> setting system/view/GPU?: no"
				attempt [system/view/GPU?: no]
			]
			3 [run-pass "PASS 2: after GPU?: no (WARP + rebuilt faces)"]
			4 [
				write %t5764-diag.txt log
				print "^/saved t5764-diag.txt - please post its content to the issue"
				unview
			]
		]
	]
]
view/options win [offset: 200x200]