/*
ParallelBuild.ab
ビルドバッチ8つを同時実行、1つのウィンドウに8つエディットボックスを並べて、そこへ結果を出力します。

ほか、特徴的な点
Windows.UIでのコントロール（エディットボックス）のサブクラス化
DWM下におけるGDIを用いた半透明描画 (BufferedPaint系関数の使用)
DWM下におけるタイトルバー上のアイコン・文字列の非表示
*/

#require <Classes/ActiveBasic/Windows/UI/Form.ab>
#require <Classes/ActiveBasic/Windows/UI/EditBox.ab>
#require <Classes/ActiveBasic/Windows/UI/Application.ab>

#resource "UI_Sample.rc"

Imports ActiveBasic.Windows
Imports ActiveBasic.Windows.UI
Imports System.Collections.Generic
Imports System.IO
Imports System.Threading

TypeDef HPAINTBUFFER = HANDLE

Const Enum BP_BUFFERFORMAT
    BPBF_COMPATIBLEBITMAP = 0
    BPBF_DIB = 1
    BPBF_TOPDOWNDIB = 2
    BPBF_TOPDOWNMONODIB = 3
End Enum

Const BPBF_COMPOSITED = BPBF_TOPDOWNDIB

Type BP_PAINTPARAMS
	cbSize As DWord
	dwFlags As DWord
	prcExclude As *RECT
	pBlendFunction As VoidPtr '*BLENDFUNCTION
End Type

Type MARGINS
	cxLeftWidth As Long
	cxRightWidth As Long
	cyTopHeight As Long
	cyBottomHeight As Long
End Type

Const Enum WINDOWTHEMEATTRIBUTETYPE
	WTA_NONCLIENT = 1
End Enum

Type WTA_OPTIONS
	dwFlags As DWord
	dwMask As DWord
End Type

Const WTNCA_NODRAWCAPTION = 1
Const WTNCA_NODRAWICON = 2

'API宣言ここまで

TypeDef PDwmExtendFrameIntoClientArea = *Function(hwnd As HWND, ByRef MarInset As MARGINS) As HRESULT
TypeDef PSetWindowThemeAttribute = *Function(hwnd As HWND, eAttribute As WINDOWTHEMEATTRIBUTETYPE, ByRef pvAttribute As Any, cbAttribute As DWord) As HRESULT
TypeDef PDwmIsCompositionEnabled = *Function(ByRef fEnabled As BOOL) As HRESULT
TypeDef PBeginBufferedPaint = *Function(hdcTarget As HDC, ByRef rcTarget As RECT, dwFormat As BP_BUFFERFORMAT, pPaintParams As *BP_PAINTPARAMS, ByRef hdc As HDC) As HPAINTBUFFER
TypeDef PBufferedPaintSetAlpha = *Function(hBufferedPaint As HPAINTBUFFER, ByRef rc As RECT, alpha As DWord) As HRESULT
TypeDef PBufferedPaintInit = *Function() As HRESULT
TypeDef PGetBufferedPaintBits = *Function(hBufferedPaint As HPAINTBUFFER, ByRef pbBuffer As *RGBQUAD, ByRef cxRow As Long) As HRESULT
TypeDef PEndBufferedPaint = *Function(hBufferedPaint As HPAINTBUFFER, fUpdateTarget As BOOL) As HRESULT

Const BorderWidth = 6

'コメントアウトを外すと、エディットボックス部分が不透明になる。
'#define OPAQUE_EDITBOX

Class MyForm
	Inherits Form
Public
	Sub MyForm()
		AddResize(AddressOf(onResize))
		AddPaintBackground(AddressOf(onPaintBackground))
		AddMessageEvent(WM_CTLCOLORSTATIC, AddressOf(onCtlColorEditBox))
		AddMessageEvent(WM_DWMCOMPOSITIONCHANGED, AddressOf(onCompositionChanged))
		edit = New List<EditBox>

		CreateForm()

		Text = "ParallelBuild"

		Dim hdc = GetDC()
		hfont = CreateFont(-MulDiv(9, GetDeviceCaps(hdc, LOGPIXELSY), 72), 0, 0, 0,
			FW_DONTCARE, FALSE, FALSE, FALSE, SHIFTJIS_CHARSET, OUT_DEFAULT_PRECIS,
			CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, FIXED_PITCH, "ＭＳ ゴシック")
		ReleaseDC(hdc)
		Dim wpFont = hfont As WPARAM

		Dim i As Long
		For i = 0 To 7
			Dim e = New EditBox
			e.AddMessageEvent(WM_PAINT, AddressOf(onPaintEditBox))
			e.Create(This, ES_MULTILINE Or ES_AUTOHSCROLL Or ES_AUTOVSCROLL Or ES_READONLY Or WS_HSCROLL Or WS_VSCROLL Or WS_VISIBLE, WS_EX_CLIENTEDGE)
			e.SendMessage(WM_SETFONT, wpFont, 0)
			e.BeginSubclass()
			edit.Add(e)
		Next

		thread = New Thread(AddressOf(ControlProcess))
		thread.Start()

		hmodUxTheme = LoadLibrary("uxtheme")
		hmodDwmApi = LoadLibrary("dwmapi")

		If hmodUxTheme <> 0 Then
			pSetWindowThemeAttribute = GetProcAddress(hmodUxTheme, ToMBStr("SetWindowThemeAttribute")) As PSetWindowThemeAttribute
			pBufferedPaintUnInit = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintUnInit")) As PBufferedPaintInit
			pBeginBufferedPaint = GetProcAddress(hmodUxTheme, ToMBStr("BeginBufferedPaint")) As PBufferedPaintInit
			pBufferedPaintSetAlpha = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintSetAlpha")) As PBufferedPaintSetAlpha
			pEndBufferedPaint = GetProcAddress(hmodUxTheme, ToMBStr("EndBufferedPaint")) As PEndBufferedPaint
			pGetBufferedPaintBits = GetProcAddress(hmodUxTheme, ToMBStr("GetBufferedPaintBits")) As PGetBufferedPaintBits
			Dim pBufferedPaintInit = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintInit")) As PBufferedPaintInit
			If pBufferedPaintInit <> 0 Then
				Dim hr = pBufferedPaintInit()
				If FAILED(hr) Then Debug
			End If
		End If

		If hmodDwmApi <> 0 Then
			pDwmIsCompositionEnabled = GetProcAddress(hmodDwmApi, ToMBStr("DwmIsCompositionEnabled")) As PDwmIsCompositionEnabled
			pDwmExtendFrameIntoClientArea = GetProcAddress(hmodDwmApi, ToMBStr("DwmExtendFrameIntoClientArea")) As PDwmExtendFrameIntoClientArea
			SendMessage(WM_DWMCOMPOSITIONCHANGED)
		End If
	End Sub

Private
	hmodUxTheme As HMODULE
	hmodDwmApi As HMODULE
	pDwmIsCompositionEnabled As PDwmIsCompositionEnabled
	pDwmExtendFrameIntoClientArea As PDwmExtendFrameIntoClientArea
	pSetWindowThemeAttribute As PSetWindowThemeAttribute
	pBufferedPaintUnInit As PBufferedPaintInit
	pBeginBufferedPaint As PBeginBufferedPaint
	pBufferedPaintSetAlpha As PBufferedPaintSetAlpha
	pEndBufferedPaint As PEndBufferedPaint
	pGetBufferedPaintBits As PGetBufferedPaintBits

	Sub onCompositionChanged(sender As Object, e As MessageArgs)
		e.Handled = True
		useDwm = False
		If pDwmIsCompositionEnabled <> 0 Then
			Dim enabled As BOOL
			If SUCCEEDED(pDwmIsCompositionEnabled(enabled)) And enabled Then
				useDwm = True
				'クライアント領域全体にガラス効果をかける。
				Dim m = [-1, 0, 0, 0] As MARGINS
				pDwmExtendFrameIntoClientArea(This, m)
				'タイトルバーのアイコン・文字列を消す。
				Dim wo As WTA_OPTIONS
				wo.dwFlags = WTNCA_NODRAWCAPTION Or WTNCA_NODRAWICON
				wo.dwMask = WTNCA_NODRAWCAPTION Or WTNCA_NODRAWICON
				pSetWindowThemeAttribute(hwnd, WTA_NONCLIENT, wo, Len(wo))
			End If
		End If
		Invalidate()
	End Sub

	Sub onDestroy(sender As Object, e As Args)
		DeleteObject(hfont)
		pBufferedPaintUnInit()
		If hmodUxTheme <> 0 Then
			FreeLibrary(hmodUxTheme)
		End If
		If hmodDwmApi <> 0 Then
			FreeLibrary(hmodDwmApi)
		End If
	End Sub

	Sub onResize(sender As Object, e As ResizeArgs)
		Dim i As Long
		For i = 0 To 7
			Dim t = edit[i]
			t.Move((i Mod 4) * (e.X \ 4) + BorderWidth, (i \ 4) * (e.Y \ 2) + BorderWidth, e.X \ 4 - BorderWidth * 2, e.Y \ 2 - BorderWidth * 2)
		Next
	End Sub

	Sub onPaintBackground(sender As Object, e As PaintBackgroundArgs)
		If useDwm Then
			Dim hdc = e.Handle
			SetBkColor(hdc, 0)
			ExtTextOut(hdc, 0, 0, ETO_OPAQUE, ClientRect, "", 0, 0)
		End If
	End Sub

	Static Const backgroundColor = RGB(255, 255, 255)
	Static Const textColor = RGB(0, 0, 0)

	Sub onCtlColorEditBox(sender As Object, e As MessageArgs)
		Dim hdc = e.WParam As HDC
		SetTextColor(hdc, textColor)
		SetBkColor(hdc, backgroundColor)
		e.LResult = GetStockObject(NULL_BRUSH) As LRESULT
		e.Handled = True
	End Sub

	Sub onPaintEditBox(sender As Object, e As MessageArgs)
		Dim alpha = &hcc As DWord
		Dim i As Long, j As Long
		If useDwm Then
			Dim edit = sender As EditBox
			Dim ps As PAINTSTRUCT
			BeginPaint(e.HWnd, ps)
			Dim hdcMem As HDC
			Dim hpb = pBeginBufferedPaint(ps.hdc, ps.rcPaint, BPBF_TOPDOWNDIB, 0, hdcMem)
			If hpb <> 0 Then
				FillRect(hdcMem, ps.rcPaint, GetStockObject(WHITE_BRUSH) As HBRUSH)
				edit.DefWndProc(WM_PRINTCLIENT, hdcMem As WPARAM, PRF_CLIENT)
#ifdef OPAQUE_EDITBOX
				pBufferedPaintSetAlpha(hpb, ps.rcPaint, 255)
#else
				Dim cxRow As Long
				Dim p As *RGBQUAD
				pGetBufferedPaintBits(hpb, p, cxRow)
				Dim pdw = p As *DWord
				For i = 0 To ELM(ps.rcPaint.bottom - ps.rcPaint.top)
					For j = 0 To ELM(ps.rcPaint.right - ps.rcPaint.left)
						Dim rgb = pdw[i * cxRow + j] And &h00ffffff
						If rgb = textColor Then 'ClearType下で試すと、rgb <> backgroundColorよりこのほうが綺麗。
							pdw[i * cxRow + j] Or= &hff000000
						Else
							With p[i * cxRow + j]
								.rgbReserved = alpha As Byte
								.rgbRed = ((.rgbRed * alpha) >> 8) As Byte
								.rgbGreen = ((.rgbGreen * alpha) >> 8) As Byte
								.rgbBlue = ((.rgbBlue * alpha) >> 8) As Byte
							End With
						End If
					Next
				Next
#endif
				pEndBufferedPaint(hpb, TRUE)
			End If
			EndPaint(e.HWnd, ps)
			e.Handled = True
		Else
			e.Handled = False
		End If
	End Sub

	Sub ControlProcess()
		Dim buildCmd[7] As PCTSTR
		buildCmd[0] = "build_basic_static_library(32bit - debug - unicode).bat"
		buildCmd[1] = "build_basic_static_library(32bit - debug).bat"
		buildCmd[2] = "build_basic_static_library(32bit - release - unicode).bat"
		buildCmd[3] = "build_basic_static_library(32bit - release).bat"
		buildCmd[4] = "build_basic_static_library(64bit - debug - unicode).bat"
		buildCmd[5] = "build_basic_static_library(64bit - debug).bat"
		buildCmd[6] = "build_basic_static_library(64bit - release - unicode).bat"
		buildCmd[7] = "build_basic_static_library(64bit - release).bat"
		Dim pathBase = "P:\PROGRAMS\ablib\ab5.0\ablib\build_batch\"
		Dim hProcess[7] As HANDLE
		Dim hPipe[7] As HANDLE
		Dim i As Long
		For i = 0 To 7
			CreateBuildProcess(hProcess[i], hPipe[i], pathBase, buildCmd[i])
		Next
		Dim buf[4095] As CHAR
		For i = 0 To 7
			WaitForSingleObject(hProcess[i], INFINITE)
			Dim readSize As DWord
			ReadFile(hPipe[i], buf, Len(buf), VarPtr(readSize), ByVal 0)
			Dim s = New String(buf, readSize As Long)
			edit[i].SendMessage(WM_SETTEXT, 0, ToTCStr(s) As LPARAM)
			CloseHandle(hProcess[i])
			CloseHandle(hPipe[i])
		Next
	End Sub

	Sub CreateBuildProcess(ByRef hProcess As HANDLE, ByRef hPipeOutput As HANDLE, cmdPath As String, cmdLine As PCSTR)
		Dim hPipeRead As HANDLE, hPipeWrite As HANDLE
		Dim sa As SECURITY_ATTRIBUTES
		sa.nLength = Len(sa)
		sa.lpSecurityDescriptor = 0
		sa.bInheritHandle = TRUE
		If CreatePipe(hPipeRead, hPipeWrite, VarPtr(sa), 0) = FALSE Then
			ThrowWithLastError()
		End If
		Dim si As STARTUPINFO
		Dim pi As PROCESS_INFORMATION
		si.cb = Len(si)
		si.dwFlags = STARTF_USESTDHANDLES
		si.hStdInput = GetStdHandle(STD_INPUT_HANDLE)
		si.hStdOutput = hPipeWrite
		si.hStdError = hPipeWrite
		If CreateProcess(0, ToTCStr(Ex"\q" & cmdPath & cmdLine & Ex"\q"), ByVal 0, ByVal 0, TRUE, CREATE_NO_WINDOW, 0, ToTCStr(cmdPath), si, pi) = FALSE Then
			ThrowWithLastError()
		End If
		CloseHandle(pi.hThread)
		hPipeOutput = hPipeRead
		hProcess = pi.hProcess
	End Sub

	edit As List<EditBox>
	thread As Thread
	hfont As HFONT
	useDwm As Boolean
End Class

Control.Initialize(GetModuleHandle(0))

Dim f = New MyForm
Application.Run(f)