source: branch/egtra-stream-without-en_dec/basic/prompt.sbp@ 673

Last change on this file since 673 was 635, checked in by NoWest, 16 years ago

名前空間への入れ忘れの修正と
ConsoleクラスのResetColorのバグへ対応。
正しい動作かご確認ください。

File size: 27.1 KB
Line 
1'prompt.sbp
2
3
4#ifndef _INC_PROMPT
5#define _INC_PROMPT
6
7Namespace ActiveBasic
8Namespace Prompt
9Namespace Detail
10
11Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCSTR, cb As Long, ByRef Size As SIZE) As Long
12 _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32A(hdc, psz, cb, Size)
13End Function
14
15Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCWSTR, cb As Long, ByRef Size As SIZE) As Long
16 _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32W(hdc, psz, cb, Size)
17End Function
18
19Function _PromptSys_TextOut(hdc As HDC, x As Long, y As Long, psz As PCSTR, cb As Long) As Long
20 _PromptSys_TextOut = TextOutA(hdc, x, y, psz, cb)
21 If _PromptSys_TextOut = 0 Then Debug
22End Function
23
24Function _PromptSys_TextOut(hdc As HDC, x As Long, y As Long, psz As PCWSTR, cb As Long) As Long
25 _PromptSys_TextOut = TextOutW(hdc, x, y, psz, cb)
26End Function
27
28Function _PromptSys_ImmGetCompositionString(himc As HIMC, index As DWord, pBuf As PSTR, bufLen As DWord) As Long
29 _PromptSys_ImmGetCompositionString = ImmGetCompositionStringA(himc, index, pBuf, bufLen)
30End Function
31
32Function _PromptSys_ImmGetCompositionString(himc As HIMC, index As DWord, pBuf As PWSTR, bufLen As DWord) As Long
33 _PromptSys_ImmGetCompositionString = ImmGetCompositionStringW(himc, index, pBuf, bufLen)
34End Function
35
36Dim _PromptSys_hWnd As HWND
37Dim _PromptSys_dwThreadID As DWord
38Dim _PromptSys_hInitFinish As HANDLE
39
40'text
41Type _PromptSys_CharacterInformation
42 ForeColor As COLORREF
43 BackColor As COLORREF
44 StartPos As Long
45End Type
46
47Type _PromptSys_LineInformation
48 Length As Long
49 Text As *Char
50 CharInfo As *_PromptSys_CharacterInformation
51End Type
52
53Dim _PromptSys_hFont As HFONT
54Dim _PromptSys_FontSize As SIZE
55Dim _PromptSys_InputStr[255] As Char
56Dim _PromptSys_InputLen = -1 As Long
57Dim _PromptSys_KeyChar As Byte
58Dim _PromptSys_CurPos As POINTAPI
59Dim _PromptSys_TextLine[100] As _PromptSys_LineInformation
60Dim _PromptSys_NowTextColor As COLORREF
61Dim _PromptSys_NowBackColor As COLORREF
62Dim _PromptSys_SectionOfBufferAccess As CRITICAL_SECTION
63
64
65'graphic
66Dim _PromptSys_hBitmap As HBITMAP
67Dim _PromptSys_hMemDC As HDC
68Dim _PromptSys_ScreenSize As SIZE
69Dim _PromptSys_GlobalPos As POINTAPI
70
71Sub _PromptSys_Initialize()
72 _PromptSys_hInitFinish = CreateEvent(0, FALSE, FALSE, 0)
73 Dim _PromptSys_hThread = CreateThread(0, 0, AddressOf(PromptMain), 0, 0, _PromptSys_dwThreadID)
74 If _PromptSys_hThread = 0 Then
75 Debug
76 ExitProcess(1)
77 End If
78 WaitForSingleObject(_PromptSys_hInitFinish, INFINITE)
79End Sub
80
81Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long)
82 Dim i As Long, i2 As Long, i3 As Long
83 Dim ret As Long
84
85 Dim hOldFont = SelectObject(hDC, _PromptSys_hFont) As HFONT
86
87 'Scroll
88 Dim rc As RECT
89 GetClientRect(_PromptSys_hWnd, rc)
90 While (_PromptSys_CurPos.y+1) * _PromptSys_FontSize.cy > rc.bottom and _PromptSys_CurPos.y > 0
91 _System_free(_PromptSys_TextLine[0].Text)
92 _System_free(_PromptSys_TextLine[0].CharInfo)
93 For i = 0 To 100 - 1
94 _PromptSys_TextLine[i].Length = _PromptSys_TextLine[i+1].Length
95 _PromptSys_TextLine[i].Text = _PromptSys_TextLine[i+1].Text
96 _PromptSys_TextLine[i].CharInfo = _PromptSys_TextLine[i+1].CharInfo
97 Next
98 _PromptSys_TextLine[100].Length = 0
99 _PromptSys_TextLine[100].Text = _System_calloc(SizeOf (Char) * 255)
100 _PromptSys_TextLine[100].CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
101 _PromptSys_CurPos.y--
102
103 'Redraw
104 StartLine = -1
105 Wend
106
107 i = 0' : Debug
108 While i * _PromptSys_FontSize.cy < rc.bottom and i <= 100
109 If StartLine=-1 or (StartLine<=i and i<=EndLine) Then
110 Dim currentLineCharInfo = _PromptSys_TextLine[i].CharInfo
111
112 Dim sz As SIZE
113 i3 = _PromptSys_TextLine[i].Length
114 _PromptSys_GetTextExtentPoint32(hDC, _PromptSys_TextLine[i].Text, i3, sz)
115
116' BitBlt(hDC,_
117' sz.cx, i * _PromptSys_FontSize.cy, _
118' rc.right, _PromptSys_FontSize.cy, _
119' _PromptSys_hMemDC, sz.cx, i * _PromptSys_FontSize.cy, SRCCOPY)
120
121 While i2 < i3
122 SetTextColor(hDC, currentLineCharInfo[i2].ForeColor)
123 If currentLineCharInfo[i2].BackColor = -1 Then
124 SetBkMode(hDC, TRANSPARENT)
125 Else
126' Debug
127 ret = SetBkMode(hDC, OPAQUE)
128 ret = SetBkColor(hDC, currentLineCharInfo[i2].BackColor)
129 End If
130
131 Dim tempLen As Long
132 If _System_IsDoubleUnitChar(_PromptSys_TextLine[i].Text[i2], _PromptSys_TextLine[i].Text[i2+1]) Then
133 tempLen = 2
134 Else
135 tempLen = 1
136 End If
137 With _PromptSys_FontSize
138 _PromptSys_TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]) As *Char, tempLen)
139 End With
140 i2 += tempLen
141 Wend
142 End If
143
144 i++
145 Wend
146
147 SelectObject(hDC, hOldFont)
148End Sub
149
150Sub PRINT_ToPrompt(buf As String)
151 OutputDebugString(ToTCStr(Ex"PRINT_ToPrompt " + buf + Ex"\r\n"))
152 EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
153 If buf = "あ" Then Debug
154 With _PromptSys_CurPos
155 Dim hdc = GetDC(_PromptSys_hWnd)
156 Dim hOldFont = SelectObject(hdc, _PromptSys_hFont)
157 Dim StartLine = .y As Long
158 Dim bufLen = buf.Length
159 Dim doubleUnitChar = False As Boolean
160 'Addition
161 Dim i2 = 0 As Long, i3 As Long
162 For i2 = 0 To ELM(bufLen)
163 If buf[i2] = &h0d Then 'CR \r
164 _PromptSys_TextLine[.y].Length = .x
165 .x = 0
166 ElseIf buf[i2] = &h0a Then 'LF \n
167 _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
168 .y++
169 Else
170 Dim currentLineCharInfo = _PromptSys_TextLine[.y].CharInfo
171 _PromptSys_TextLine[.y].Text[.x] = buf[i2]
172 currentLineCharInfo[.x].ForeColor = _PromptSys_NowTextColor
173 currentLineCharInfo[.x].BackColor = _PromptSys_NowBackColor
174
175 If buf[i2] = &h09 Then 'tab
176 Dim tabStop = _PromptSys_FontSize.cx * 8
177 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + _
178 tabStop - currentLineCharInfo[.x].StartPos Mod tabStop
179 Else
180 If doubleUnitChar <> False Then
181 doubleUnitChar = False
182 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos
183 Else
184 Dim sz As SIZE
185 Dim charLen As Long
186 If _System_IsDoubleUnitChar(buf[i2], buf[i2 + 1]) Then
187 charLen = 2
188 doubleUnitChar = True
189 Else
190 charLen = 1
191 EndIf
192 Dim p = buf.StrPtr
193 _PromptSys_GetTextExtentPoint32(hdc, VarPtr(p[i2]) As *Char, charLen, sz)
194 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx
195 End If
196 End If
197 .x++
198 End If
199 Next
200 _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
201
202 'Draw the text buffer added
203 'DrawPromptBuffer(hdc, StartLine, .y)
204 InvalidateRect(_PromptSys_hWnd, ByVal 0, TRUE)
205 UpdateWindow(_PromptSys_hWnd)
206 SelectObject(hdc, hOldFont)
207 ReleaseDC(_PromptSys_hWnd, hdc)
208 End With
209 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
210End Sub
211
212Function PromptProc(hWnd As HWND, message As DWord, wParam As WPARAM, lParam As LPARAM) As LRESULT
213 Select Case message
214 Case WM_CREATE
215 Return _PromptWnd_OnCreate(hWnd, ByVal lParam As *CREATESTRUCT)
216 Case WM_PAINT
217 _PromptWnd_OnPaint(hWnd)
218 Case WM_SETFOCUS
219 _PromptWnd_OnSetFocus(hWnd, wParam As HWND)
220 Case WM_KILLFOCUS
221 _PromptWnd_OnKillForcus(hWnd, wParam As HWND)
222 Case WM_KEYDOWN
223 _PromptWnd_OnKeyDown(wParam As DWord, LOWORD(lParam) As DWord, HIWORD(lParam) As DWord)
224 Case WM_CHAR
225 _PromptWnd_OnChar(hWnd, wParam, lParam)
226 Case WM_IME_COMPOSITION
227 Return _PromptWnd_OnImeCompostion(hWnd, wParam, lParam)
228 Case WM_DESTROY
229 _PromptWnd_OnDestroy(hWnd)
230 Case Else
231 PromptProc = DefWindowProc(hWnd, message, wParam, lParam)
232 Exit Function
233 End Select
234 PromptProc = 0
235End Function
236
237Function _PromptWnd_OnCreate(hwnd As HWND, ByRef cs As CREATESTRUCT) As LRESULT
238 Dim hdc = GetDC(hwnd)
239 With _PromptSys_ScreenSize
240 _PromptSys_hBitmap = CreateCompatibleBitmap(hdc, .cx, .cy)
241 End With
242 _PromptSys_hMemDC = CreateCompatibleDC(hdc)
243 SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap)
244
245 'Initialize for Win9x
246 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH
247 With _PromptSys_ScreenSize
248 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
249 End With
250 SelectObject(_PromptSys_hMemDC, hOldBrush)
251
252 Dim tm As TEXTMETRIC
253 Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT
254 GetTextMetrics(_PromptSys_hMemDC, tm)
255 SelectObject(_PromptSys_hMemDC, hOldFont)
256 With _PromptSys_FontSize
257 .cx = tm.tmAveCharWidth
258 .cy = tm.tmHeight
259 End With
260
261 '_PromptSys_hFont initialize
262 Dim lf As LOGFONT
263 With lf
264 .lfHeight = -MulDiv(12, GetDeviceCaps(hdc, LOGPIXELSY), 72)
265 .lfWidth = 0
266 .lfEscapement = 0
267 .lfOrientation = 0
268 .lfWeight = 0
269 .lfItalic = 0
270 .lfUnderline = 0
271 .lfStrikeOut = 0
272 .lfCharSet = SHIFTJIS_CHARSET
273 .lfOutPrecision = OUT_DEFAULT_PRECIS
274 .lfClipPrecision = CLIP_DEFAULT_PRECIS
275 .lfQuality = DEFAULT_QUALITY
276 .lfPitchAndFamily = FIXED_PITCH
277 lstrcpy(.lfFaceName, ToTCStr("MS 明朝"))
278 End With
279
280 _PromptSys_hFont = CreateFontIndirect(lf)
281
282 ReleaseDC(hwnd, hdc)
283
284 _PromptWnd_OnCreate = 0
285End Function
286
287Sub _PromptWnd_OnPaint(hwnd As HWND)
288 Dim ps As PAINTSTRUCT
289 Dim hdc = BeginPaint(hwnd, ps)
290 With _PromptSys_ScreenSize
291 BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY)
292' With ps.rcPaint
293' BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY)
294 End With
295 DrawPromptBuffer(hdc, -1, 0)
296 EndPaint(hwnd, ps)
297End Sub
298
299Sub _PromptWnd_OnSetFocus(hwnd As HWND, hwndOldFocus As HWND)
300 If _PromptSys_InputLen <> -1 Then
301 Dim himc = ImmGetContext(hwnd)
302 If himc Then
303 Dim CompForm As COMPOSITIONFORM
304 With CompForm
305 .dwStyle = CFS_POINT
306 .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx
307 .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy
308 End With
309 ImmSetCompositionWindow(himc, CompForm)
310
311 Dim lf As LOGFONT
312 GetObject(_PromptSys_hFont, Len(lf), lf)
313 ImmSetCompositionFont(himc, lf)
314 End If
315 ImmReleaseContext(hwnd, himc)
316
317 CreateCaret(hwnd, 0, 9, 6)
318 With _PromptSys_CurPos
319 SetCaretPos(_PromptSys_TextLine[.y].CharInfo[.x].StartPos, (.y + 1) * _PromptSys_FontSize.cy - 7)
320 End With
321 ShowCaret(hwnd)
322 End If
323End Sub
324
325Sub _PromptWnd_OnKillForcus(hwnd As HWND, hwndNewFocus As HWND)
326 HideCaret(hwnd)
327 DestroyCaret()
328End Sub
329
330Sub _PromptWnd_OnKeyDown(vk As DWord, repeat As DWord, flags As DWord)
331 If _PromptSys_InputLen = -1 Then
332 _PromptSys_KeyChar = vk As Byte
333 End If
334End Sub
335
336Sub _PromptWnd_OnDestroy(hwnd As HWND)
337 DeleteDC(_PromptSys_hMemDC)
338 DeleteObject(_PromptSys_hBitmap)
339
340 PostQuitMessage(0)
341End Sub
342
343Sub _PromptWnd_OnChar(hwnd As HWND, wParam As WPARAM, lParam As LPARAM)
344 Dim TempStr As String
345 If _PromptSys_InputLen <> -1 Then
346 If wParam = VK_BACK Then
347 If _PromptSys_InputLen Then
348 _PromptSys_InputLen--
349 _PromptSys_InputStr[_PromptSys_InputLen] = 0
350
351 _PromptSys_CurPos.x--
352 With _PromptSys_CurPos
353 _PromptSys_TextLine[.y].Text[.x] = 0
354 End With
355 End If
356 ElseIf wParam = VK_RETURN Then
357 _PromptSys_InputStr[_PromptSys_InputLen] = 0
358 _PromptSys_InputLen = -1
359 TempStr = Ex"\r\n"
360 ElseIf wParam = &H16 Then
361/*
362 'Paste Command(Use Clippboard)
363 OpenClipboard(hwnd)
364 Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL
365 If hGlobal = 0 Then Exit Sub
366 Dim pTemp = GlobalLock(hGlobal) As PCSTR
367#ifdef UNICODE 'A版ウィンドウプロシージャ用
368 Dim tempSizeA = lstrlenA(pTemp)
369 Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1
370 TempStr = ZeroString(tempSizeW)
371 MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW)
372#else
373 TempStr = ZeroString(lstrlen(pTemp) + 1)
374 lstrcpy(StrPtr(TempStr), pTemp)
375#endif
376 memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length)
377 _PromptSys_InputLen += TempStr.Length
378
379 GlobalUnlock(hGlobal)
380 CloseClipboard()
381*/
382 Else
383 Dim t = wParam As TCHAR
384 TempStr = New String(VarPtr(t), 1)
385 _PromptSys_InputStr[_PromptSys_InputLen] = TempStr[0]
386 _PromptSys_InputLen++
387 End If
388
389 SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
390 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(TempStr)
391 SendMessage(hwnd, WM_SETFOCUS, 0, 0)
392 End If
393End Sub
394
395Function _PromptWnd_GetCompositionStringW(himc As HIMC, ByRef rpsz As PWSTR) As Long
396 Dim size = ImmGetCompositionStringW(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
397 rpsz = GC_malloc(size) As PWSTR
398 If rpsz = 0 Then
399 'Debug
400 Return 0
401 End If
402 Return ImmGetCompositionStringW(himc, GCS_RESULTSTR, rpsz, size)
403End Function
404
405Function _PromptWnd_GetCompositionStringA(himc As HIMC, ByRef rpsz As PSTR) As Long
406 Dim size = ImmGetCompositionStringA(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
407 rpsz = GC_malloc(size) As PSTR
408 If rpsz = 0 Then
409 'Debug
410 Return 0
411 End If
412 Return ImmGetCompositionStringA(himc, GCS_RESULTSTR, rpsz, size)
413End Function
414
415Function _PromptWnd_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT
416 If (lp And GCS_RESULTSTR) <> 0 Then
417 Dim himc = ImmGetContext(hwnd)
418 If himc = 0 Then
419 'Debug
420 Return 0
421 End If
422 Dim tempStr = Nothing As String
423 Dim str As *Char
424#ifdef UNICODE
425 Dim osver = System.Environment.OSVersion
426 With osver
427 ' GetCompositionStringW is not implimented in Windows 95
428 If .Version.Major = 4 And .Version.Minor = 0 And .Platform = System.PlatformID.Win32Windows Then
429 Dim strA As PCSTR
430 Dim sizeA = _PromptWnd_GetCompositionStringA(himc, strA)
431 tempStr = New String(strA, sizeA As Long)
432 Else
433 Dim size = _PromptWnd_GetCompositionStringW(himc, str)
434 tempStr = New String(str, (size \ SizeOf (WCHAR)) As Long)
435 End If
436 End With
437#else
438 Dim size = _PromptWnd_GetCompositionStringA(himc, str)
439 tempStr = New String(str, size As Long)
440#endif
441 ImmReleaseContext(hwnd, himc)
442
443 ActiveBasic.Strings.ChrCopy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), tempStr.StrPtr, tempStr.Length As SIZE_T)
444 _PromptSys_InputLen += tempStr.Length
445
446 SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
447 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(tempStr)
448 SendMessage(hwnd, WM_SETFOCUS, 0, 0)
449
450 _PromptWnd_OnImeCompostion = 0
451 Else
452 _PromptWnd_OnImeCompostion = DefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp)
453 End If
454End Function
455
456Function PromptMain(data As VoidPtr) As DWord
457 Dim i As Long
458 'Allocate
459 For i = 0 To 100
460 With _PromptSys_TextLine[i]
461 .Length = 0
462 .Text = _System_calloc(SizeOf (Char) * 255)
463 .CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
464 End With
465 Next
466
467 'Current Colors initialize
468 _PromptSys_NowTextColor = RGB(255, 255, 255)
469 _PromptSys_NowBackColor = RGB(0, 0, 0)
470
471 'Setup
472 With _PromptSys_ScreenSize
473 .cx = GetSystemMetrics(SM_CXSCREEN)
474 .cy = GetSystemMetrics(SM_CYSCREEN)
475 End With
476
477 'Critical Section
478 InitializeCriticalSection(_PromptSys_SectionOfBufferAccess)
479
480 'Regist Prompt Class
481 Dim wcl As WNDCLASSEX
482 ZeroMemory(VarPtr(wcl), Len(wcl))
483 With wcl
484 .cbSize = Len(wcl)
485 .hInstance = GetModuleHandle(0)
486 .style = CS_HREDRAW Or CS_VREDRAW' or CS_DBLCLKS
487 .hIcon = LoadImage(0, MAKEINTRESOURCE(IDI_APPLICATION), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
488 .hIconSm = LoadImage(0, MAKEINTRESOURCE(IDI_WINLOGO), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
489 .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
490 .lpszClassName = ToTCStr("PROMPT")
491 .lpfnWndProc = AddressOf(PromptProc)
492 .hbrBackground = GetStockObject(BLACK_BRUSH)
493 End With
494 Dim atom = RegisterClassEx(wcl)
495
496 'Create Prompt Window
497 _PromptSys_hWnd = CreateWindowEx(WS_EX_CLIENTEDGE, atom As ULONG_PTR As LPCTSTR, ToTCStr("BASIC PROMPT"), _
498 WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
499 0, 0, wcl.hInstance, 0)
500 ShowWindow(_PromptSys_hWnd, SW_SHOW)
501 UpdateWindow(_PromptSys_hWnd)
502 SetEvent(_PromptSys_hInitFinish)
503 Dim msg As MSG
504 Do
505 Dim iResult = GetMessage(msg, 0, 0, 0)
506 If iResult = 0 Then
507 System.Environment.ExitCode = msg.wParam As Long
508 Exit Do
509 ElseIf iResult = -1 Then
510 Exit Do
511 End If
512 TranslateMessage(msg)
513 DispatchMessage(msg)
514 Loop
515
516 '強制的に終了する
517 End
518
519 EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
520
521 For i = 0 to 100
522 _System_free(_PromptSys_TextLine[i].Text)
523 _System_free(_PromptSys_TextLine[i].CharInfo)
524 Next
525
526 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
527
528 DeleteCriticalSection(_PromptSys_SectionOfBufferAccess)
529
530 End
531End Function
532
533'Prompt text command functoins
534
535Sub Cls(n As Long)
536 Dim i As Long
537
538 'When parameter was omitted, num is set to 1
539 If n = 0 Then n = 1
540
541 If n = 1 Or n = 3 Then
542 'Clear the text screen
543 For i = 0 To 100
544 With _PromptSys_TextLine[i]
545 .Text[0] = 0 '_System_FillChar(_PromptSys_TextLine[i].Text, -1 As Char, 0)
546 .Length = 0
547 End With
548 Next
549 With _PromptSys_CurPos
550 .x = 0
551 .y = 0
552 End With
553 End If
554
555 If n = 2 Or n = 3 Then
556 'Clear the graphics screen
557 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH))
558 With _PromptSys_ScreenSize
559 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
560 End With
561 SelectObject(_PromptSys_hMemDC, hOldBrush)
562 End If
563
564 'Redraw
565 InvalidateRect(_PromptSys_hWnd, ByVal 0, 0)
566End Sub
567
568Sub Color(textColorCode As Long, backColorCode As Long)
569 _PromptSys_NowTextColor = GetBasicColor(textColorCode)
570 If backColorCode = -1 Then
571 _PromptSys_NowBackColor = -1
572 Else
573 _PromptSys_NowBackColor = GetBasicColor(backColorCode)
574 End If
575End Sub
576
577Sub INPUT_FromPrompt(showStr As String)
578*InputReStart
579
580 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(showStr)
581
582 'Input by keyboard
583 _PromptSys_InputLen = 0
584 SendMessage(_PromptSys_hWnd, WM_SETFOCUS, 0, 0)
585 While _PromptSys_InputLen <> -1
586 Sleep(10)
587 Wend
588 SendMessage(_PromptSys_hWnd, WM_KILLFOCUS, 0, 0)
589
590 'Set value to variable
591 Const comma = &h2c As Char 'Asc(",")
592 Dim broken = ActiveBasic.Strings.Detail.Split(New String(_PromptSys_InputStr), comma)
593 Dim i As Long
594 For i = 0 To ELM(broken.Count)
595 If _System_InputDataPtr[i] = 0 Then
596 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
597 Goto *InputReStart
598 End If
599 _System_Input_SetArgument(_System_InputDataPtr[i], _System_InputDataType[i], broken.Item[i])
600 Next
601
602 If _System_InputDataPtr[i]<>0 Then
603 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
604 Goto *InputReStart
605 End If
606End Sub
607
608Sub Locate(x As Long, y As Long)
609 If x < 0 Then x = 0
610 If y < 0 Then y = 0
611 If y > 100 Then y = 100
612 With _PromptSys_CurPos
613 .x = x
614 .y = y
615 End With
616
617 Dim i = _PromptSys_TextLine[y].Length
618 If i < x Then
619 ActiveBasic.Strings.ChrFill(VarPtr(_PromptSys_TextLine[y].Text[i]), x - i, &h20 As Char) 'Asc(" ")
620 Dim i2 As Long
621 For i2 = i To ELM(x)
622 _PromptSys_TextLine[y].CharInfo[i2].BackColor = -1
623 Next
624 _PromptSys_TextLine[y].Length = x
625 End If
626End Sub
627
628'Prompt graphic command functions
629
630Sub Circle(x As Long , y As Long, radius As Long, ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
631 Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
632
633 Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
634 Dim hBrush As HBRUSH
635 If bFill Then
636 hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
637 Else
638 hBrush = GetStockObject(NULL_BRUSH)
639 End If
640
641 Dim hDC = GetDC(_PromptSys_hWnd)
642 Dim hOldPenDC = SelectObject(hDC, hPen)
643 Dim hOldBrushDC = SelectObject(hDC, hBrush)
644 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
645 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
646
647 Dim radi2 As Long
648 If Aspect<1 Then
649 radi2=(CDbl(radius)*Aspect) As Long
650 Else
651 radi2=radius
652 radius=(CDbl(radius)/Aspect) As Long
653 End If
654
655 If StartPos=0 And EndPos=0 Then
656 Ellipse(hDC,x-radius,y-radi2,x+radius,y+radi2)
657 Ellipse(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2)
658 Else
659 Dim sw As Boolean
660 StartPos *=StartPos
661 EndPos *=EndPos
662
663 If StartPos<0 Or EndPos<0 Then
664 sw = True
665 Else
666 sw = False
667 End If
668
669 StartPos = Math.Abs(StartPos)
670 EndPos = Math.Abs(EndPos)
671
672 If StartPos<=78.5 Then
673 i1=78
674 i2=Int(StartPos)
675 ElseIf StartPos<=235.5 Then
676 StartPos -= 78.5
677 i1=78-Int(StartPos)
678 i2=78
679 ElseIf StartPos<=392.5 Then
680 StartPos -= 235.5
681 i1=-78
682 i2=78-Int(StartPos)
683 ElseIf StartPos<=549.5 Then
684 StartPos -= 392.5
685 i1=-78+Int(StartPos)
686 i2=-78
687 ElseIf StartPos<=628 Then
688 StartPos -= 549.5
689 i1=78
690 i2=-78+Int(StartPos)
691 End If
692
693 If EndPos<=78.5 Then
694 i3=78
695 i4=Int(EndPos)
696 ElseIf EndPos<=235.5 Then
697 EndPos -= 78.5
698 i3=78-Int(EndPos)
699 i4=78
700 ElseIf EndPos<=392.5 Then
701 EndPos -= 235.5
702 i3=-78
703 i4=78-Int(EndPos)
704 ElseIf EndPos<=549.5 Then
705 EndPos -= 392.5
706 i3=-78+Int(EndPos)
707 i4=-78
708 ElseIf EndPos<=628 Then
709 EndPos -= 549.5
710 i3=78
711 i4=-78+Int(EndPos)
712 End If
713
714 If sw Then
715 Pie(hDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
716 Pie(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
717 Else
718 Arc(hDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
719 Arc(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
720 End If
721 End If
722
723 SelectObject(hDC, hOldPenDC)
724 SelectObject(hDC, hOldBrushDC)
725 ReleaseDC(_PromptSys_hWnd, hDC)
726 SelectObject(_PromptSys_hMemDC, hOldPen)
727 SelectObject(_PromptSys_hMemDC, hOldBrush)
728 DeleteObject(hPen)
729 If bFill Then DeleteObject(hBrush)
730End Sub
731
732Sub Line(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long, ColorCode As Long, fType As Long, BrushColor As Long)
733 Dim temp As Long
734
735 If sx = &H80000000 And sy = &H80000000 Then
736 With _PromptSys_GlobalPos
737 sx = .x
738 sy = .y
739 End With
740 End If
741
742 If bStep Then
743 ex += sx
744 ey += sy
745 Else
746 If fType Then
747 'ラインの場合(四角形でない場合)
748 If sx>ex Then
749 temp=ex
750 ex=sx
751 sx=temp
752 End If
753 If sy>ey Then
754 temp=ey
755 ey=sy
756 sy=temp
757 End If
758 End If
759 End If
760
761 Dim hdc = GetDC(_PromptSys_hWnd)
762 Dim hPen = CreatePen(PS_SOLID, 1, GetBasicColor(ColorCode))
763 Dim hBrush As HBRUSH
764 If fType=2 Then
765 hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
766 Else
767 hBrush = GetStockObject(NULL_BRUSH)
768 End If
769
770 SelectObject(hdc, hPen)
771 SelectObject(hdc, hBrush)
772 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
773 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
774
775 Select Case fType
776 Case 0
777 'line
778 MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
779 LineTo(_PromptSys_hMemDC,ex,ey)
780 SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode))
781 MoveToEx(hdc,sx,sy,ByVal NULL)
782 LineTo(hdc,ex,ey)
783 SetPixel(hdc,ex,ey,GetBasicColor(ColorCode))
784 Case Else
785 'Rectangle
786 Rectangle(hdc,sx,sy,ex+1,ey+1)
787 Rectangle(_PromptSys_hMemDC,sx,sy,ex+1,ey+1)
788 End Select
789
790 ReleaseDC(_PromptSys_hWnd,hdc)
791 SelectObject(_PromptSys_hMemDC,hOldPen)
792 SelectObject(_PromptSys_hMemDC,hOldBrush)
793 DeleteObject(hPen)
794 If fType = 2 Then DeleteObject(hBrush)
795 With _PromptSys_GlobalPos
796 .x = ex
797 .y = ey
798 End With
799End Sub
800
801Sub PSet(x As Long, y As Long, ColorCode As Long)
802 Dim hdc = GetDC(_PromptSys_hWnd)
803 SetPixel(hdc, x, y, GetBasicColor(ColorCode))
804 SetPixel(_PromptSys_hMemDC, x, y, GetBasicColor(ColorCode))
805 ReleaseDC(_PromptSys_hWnd, hdc)
806 With _PromptSys_GlobalPos
807 .x = x
808 .y = y
809 End With
810End Sub
811
812Sub Paint(x As Long, y As Long, BrushColor As Long, LineColor As Long)
813 Dim hbr = CreateSolidBrush(GetBasicColor(BrushColor))
814
815 Dim hdc = GetDC(_PromptSys_hWnd)
816 Dim hbrOld = SelectObject(_PromptSys_hMemDC, hbr)
817 Dim hbrOldWndDC = SelectObject(hdc, hbr)
818
819 ExtFloodFill(hdc, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
820 ExtFloodFill(_PromptSys_hMemDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
821
822 ReleaseDC(_PromptSys_hWnd, hdc)
823 SelectObject(_PromptSys_hMemDC, hbrOld)
824 SelectObject(hdc, hbrOldWndDC)
825 DeleteObject(hbr)
826End Sub
827
828Function Inkey$() As String
829 If _PromptSys_KeyChar=0 Then
830 Inkey$=""
831 Else
832 Inkey$=Chr$(_PromptSys_KeyChar)
833 End If
834 _PromptSys_KeyChar=0
835End Function
836
837Function Input$(length As Long) As String
838 Dim i = 0 As Long
839
840 If length<=0 Then
841 Input$=""
842 Exit Function
843 End If
844
845 While 1
846 If _PromptSys_KeyChar Then
847 Input$=Input$+Chr$(_PromptSys_KeyChar)
848 _PromptSys_KeyChar=0
849 i++
850 If i >= length Then
851 Exit While
852 End If
853 End If
854 Sleep(1)
855 Wend
856End Function
857
858End Namespace 'Detail
859
860Function OwnerWnd() As HWND
861 Return Detail._PromptSys_hWnd
862End Function
863
864End Namespace 'Prompt
865End Namespace 'ActiveBasic
866
867'----------------------
868' Prompt text Commands
869'----------------------
870
871Sub PRINT_ToPrompt(s As String)
872 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(s)
873End Sub
874
875Macro CLS()(num As Long)
876 ActiveBasic.Prompt.Detail.Cls(num)
877End Macro
878
879Macro COLOR(TextColorCode As Long)(BackColorCode As Long)
880 ActiveBasic.Prompt.Detail.Color(TextColorCode, BackColorCode)
881End Macro
882
883'---------- Defined in "command.sbp" ----------
884'Dim _System_InputDataPtr[_System_MAX_PARMSNUM] As VoidPtr
885'Dim _System_InputDataType[_System_MAX_PARMSNUM] As DWord
886'----------------------------------------------
887Sub INPUT_FromPrompt(ShowStr As String)
888 ActiveBasic.Prompt.Detail.INPUT_FromPrompt(ShowStr)
889End Sub
890
891/* TODO: _System_GetUsingFormatを用意して実装する
892Sub PRINTUSING_ToPrompt(UsingStr As String)
893 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(_System_GetUsingFormat(UsingStr))
894End Sub
895*/
896
897Macro LOCATE(x As Long, y As Long)
898 ActiveBasic.Prompt.Detail.Locate(x, y)
899End Macro
900
901
902'-------------------
903' Graphics Commands
904'-------------------
905
906Macro CIRCLE(x As Long , y As Long, radius As Long)(ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
907 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
908 'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2]
909 ActiveBasic.Prompt.Detail.Circle(x, y, radius, ColorCode, StartPos, EndPos, Aspect, bFill, BrushColor)
910End Macro
911
912Macro LINE(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long)(ColorCode As Long, fType As Long, BrushColor As Long)
913 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
914 'Line (sx,sy)-[STEP](ex,ey),[ColorCode],[B/Bf],[BrushColor]
915 ActiveBasic.Prompt.Detail.Line(sx, sy, bStep, ex, ey, ColorCode, fType, BrushColor)
916End Macro
917
918Macro PSET(x As Long, y As Long)(ColorCode As Long)
919 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
920 'PSet (x,y),ColorCode
921 ActiveBasic.Prompt.Detail.PSet(x, y, ColorCode)
922End Macro
923
924Macro PAINT(x As Long, y As Long, BrushColor As Long)(ByVal LineColor As Long)
925 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
926 'Paint (x,y),BrushColor,LineColor
927 ActiveBasic.Prompt.Detail.Paint(x, y, BrushColor, LineColor)
928End Macro
929
930
931'-----------
932' Functions
933'-----------
934
935Function Inkey$() As String
936 Return ActiveBasic.Prompt.Detail.Inkey$()
937End Function
938
939Function Input$(length As Long) As String
940 Return ActiveBasic.Prompt.Detail.Input$(length)
941End Function
942
943ActiveBasic.Prompt.Detail._PromptSys_Initialize()
944
945#endif '_INC_PROMPT
Note: See TracBrowser for help on using the repository browser.