source: trunk/ab5.0/ablib/src/basic/prompt.sbp@ 688

'prompt.sbp


#ifndef _INC_PROMPT
#define _INC_PROMPT

Namespace ActiveBasic
Namespace Prompt
Namespace Detail

Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCSTR, cb As Long, ByRef Size As SIZE) As Long
    _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32A(hdc, psz, cb, Size)
End Function

Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCWSTR, cb As Long, ByRef Size As SIZE) As Long
    _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32W(hdc, psz, cb, Size)
End Function

Function _PromptSys_TextOut(hdc As HDC, x As Long, y As Long, psz As PCSTR, cb As Long) As Long
    _PromptSys_TextOut = TextOutA(hdc, x, y, psz, cb)
    If _PromptSys_TextOut = 0 Then Debug
End Function

Function _PromptSys_TextOut(hdc As HDC, x As Long, y As Long, psz As PCWSTR, cb As Long) As Long
    _PromptSys_TextOut = TextOutW(hdc, x, y, psz, cb)
End Function

Function _PromptSys_ImmGetCompositionString(himc As HIMC, index As DWord, pBuf As PSTR, bufLen As DWord) As Long
    _PromptSys_ImmGetCompositionString = ImmGetCompositionStringA(himc, index, pBuf, bufLen)
End Function

Function _PromptSys_ImmGetCompositionString(himc As HIMC, index As DWord, pBuf As PWSTR, bufLen As DWord) As Long
    _PromptSys_ImmGetCompositionString = ImmGetCompositionStringW(himc, index, pBuf, bufLen)
End Function

Dim _PromptSys_hWnd As HWND
Dim _PromptSys_dwThreadID As DWord
Dim _PromptSys_hInitFinish As HANDLE

'text
Type _PromptSys_CharacterInformation
    ForeColor As COLORREF
    BackColor As COLORREF
    StartPos As Long
End Type

Type _PromptSys_LineInformation
    Length As Long
    Text As *Char
    CharInfo As *_PromptSys_CharacterInformation
End Type

Dim _PromptSys_hFont As HFONT
Dim _PromptSys_FontSize As SIZE
Dim _PromptSys_InputStr[255] As Char
Dim _PromptSys_InputLen = -1 As Long
Dim _PromptSys_KeyChar As Byte
Dim _PromptSys_CurPos As POINTAPI
Dim _PromptSys_TextLine[100] As _PromptSys_LineInformation
Dim _PromptSys_NowTextColor As COLORREF
Dim _PromptSys_NowBackColor As COLORREF
Dim _PromptSys_SectionOfBufferAccess As CRITICAL_SECTION


'graphic
Dim _PromptSys_hBitmap As HBITMAP
Dim _PromptSys_hMemDC As HDC
Dim _PromptSys_ScreenSize As SIZE
Dim _PromptSys_GlobalPos As POINTAPI

Sub _PromptSys_Initialize()
    _PromptSys_hInitFinish = CreateEvent(0, FALSE, FALSE, 0)
    Dim _PromptSys_hThread = CreateThread(0, 0, AddressOf(PromptMain), 0, 0, _PromptSys_dwThreadID)
    If _PromptSys_hThread = 0 Then
        Debug
        ExitProcess(1)
    End If
    WaitForSingleObject(_PromptSys_hInitFinish, INFINITE)
End Sub

Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long)
    Dim i As Long, i2 As Long, i3 As Long
    Dim ret As Long

    Dim hOldFont = SelectObject(hDC, _PromptSys_hFont) As HFONT

    'Scroll
    Dim rc As RECT
    GetClientRect(_PromptSys_hWnd, rc)
    While (_PromptSys_CurPos.y+1) * _PromptSys_FontSize.cy > rc.bottom and _PromptSys_CurPos.y > 0
        _System_free(_PromptSys_TextLine[0].Text)
        _System_free(_PromptSys_TextLine[0].CharInfo)
        For i = 0 To 100 - 1
            _PromptSys_TextLine[i].Length = _PromptSys_TextLine[i+1].Length
            _PromptSys_TextLine[i].Text = _PromptSys_TextLine[i+1].Text
            _PromptSys_TextLine[i].CharInfo = _PromptSys_TextLine[i+1].CharInfo
        Next
        _PromptSys_TextLine[100].Length = 0
        _PromptSys_TextLine[100].Text = _System_calloc(SizeOf (Char) * 255)
        _PromptSys_TextLine[100].CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
        _PromptSys_CurPos.y--

        'Redraw
        StartLine = -1
    Wend

    i = 0' : Debug
    While i * _PromptSys_FontSize.cy < rc.bottom and i <= 100
        If StartLine=-1 or (StartLine<=i and i<=EndLine) Then
            Dim currentLineCharInfo = _PromptSys_TextLine[i].CharInfo

            Dim sz As SIZE
            i3 = _PromptSys_TextLine[i].Length
            _PromptSys_GetTextExtentPoint32(hDC, _PromptSys_TextLine[i].Text, i3, sz)

'           BitBlt(hDC,_
'               sz.cx, i * _PromptSys_FontSize.cy, _
'               rc.right, _PromptSys_FontSize.cy, _
'               _PromptSys_hMemDC, sz.cx, i * _PromptSys_FontSize.cy, SRCCOPY)

            While i2 < i3
                SetTextColor(hDC, currentLineCharInfo[i2].ForeColor)
                If currentLineCharInfo[i2].BackColor = -1 Then
                    SetBkMode(hDC, TRANSPARENT)
                Else
'                   Debug
                    ret = SetBkMode(hDC, OPAQUE)
                    ret = SetBkColor(hDC, currentLineCharInfo[i2].BackColor)
                End If

                Dim tempLen As Long
                If _System_IsDoubleUnitChar(_PromptSys_TextLine[i].Text[i2], _PromptSys_TextLine[i].Text[i2+1]) Then
                    tempLen = 2
                Else
                    tempLen = 1
                End If
                With _PromptSys_FontSize
                    _PromptSys_TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]) As *Char, tempLen)
                End With
                i2 += tempLen
            Wend
        End If

        i++
    Wend

    SelectObject(hDC, hOldFont)
End Sub

Sub PRINT_ToPrompt(buf As String)
    OutputDebugString(ToTCStr(Ex"PRINT_ToPrompt " + buf + Ex"\r\n"))
    EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
    If buf = "あ" Then Debug
    With _PromptSys_CurPos
        Dim hdc = GetDC(_PromptSys_hWnd)
        Dim hOldFont = SelectObject(hdc, _PromptSys_hFont)
        Dim StartLine = .y As Long
        Dim bufLen = buf.Length
        Dim doubleUnitChar = False As Boolean
        'Addition
        Dim i2 = 0 As Long, i3 As Long
        For i2 = 0 To ELM(bufLen)
            If buf[i2] = &h0d Then 'CR \r
                _PromptSys_TextLine[.y].Length = .x
                .x = 0
            ElseIf buf[i2] = &h0a Then 'LF \n
                _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
                .y++
            Else
                Dim currentLineCharInfo = _PromptSys_TextLine[.y].CharInfo
                _PromptSys_TextLine[.y].Text[.x] = buf[i2]
                currentLineCharInfo[.x].ForeColor = _PromptSys_NowTextColor
                currentLineCharInfo[.x].BackColor = _PromptSys_NowBackColor

                If buf[i2] = &h09 Then 'tab
                    Dim tabStop = _PromptSys_FontSize.cx * 8
                    currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + _
                        tabStop - currentLineCharInfo[.x].StartPos Mod tabStop
                Else
                    If doubleUnitChar <> False Then
                        doubleUnitChar = False
                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos
                    Else
                        Dim sz As SIZE
                        Dim charLen As Long
                        If _System_IsDoubleUnitChar(buf[i2], buf[i2 + 1]) Then
                            charLen = 2
                            doubleUnitChar = True
                        Else
                            charLen = 1
                        EndIf
                        Dim p = buf.StrPtr
                        _PromptSys_GetTextExtentPoint32(hdc, VarPtr(p[i2]) As *Char, charLen, sz)
                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx
                    End If
                End If
                .x++
            End If
        Next
        _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)

        'Draw the text buffer added
        'DrawPromptBuffer(hdc, StartLine, .y)
        InvalidateRect(_PromptSys_hWnd, ByVal 0, TRUE)
        UpdateWindow(_PromptSys_hWnd)
        SelectObject(hdc, hOldFont)
        ReleaseDC(_PromptSys_hWnd, hdc)
    End With
    LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
End Sub

Function PromptProc(hWnd As HWND, message As DWord, wParam As WPARAM, lParam As LPARAM) As LRESULT
    Select Case message
        Case WM_CREATE
            Return _PromptWnd_OnCreate(hWnd, ByVal lParam As *CREATESTRUCT)
        Case WM_PAINT
            _PromptWnd_OnPaint(hWnd)
        Case WM_SETFOCUS
            _PromptWnd_OnSetFocus(hWnd, wParam As HWND)
        Case WM_KILLFOCUS
            _PromptWnd_OnKillForcus(hWnd, wParam As HWND)
        Case WM_KEYDOWN
            _PromptWnd_OnKeyDown(wParam As DWord, LOWORD(lParam) As DWord, HIWORD(lParam) As DWord)
        Case WM_CHAR
            _PromptWnd_OnChar(hWnd, wParam, lParam)
        Case WM_IME_COMPOSITION
            Return _PromptWnd_OnImeCompostion(hWnd, wParam, lParam)
        Case WM_DESTROY
            _PromptWnd_OnDestroy(hWnd)
        Case Else
            PromptProc = DefWindowProc(hWnd, message, wParam, lParam)
            Exit Function
    End Select
    PromptProc = 0
End Function

Function _PromptWnd_OnCreate(hwnd As HWND, ByRef cs As CREATESTRUCT) As LRESULT
    Dim hdc = GetDC(hwnd)
    With _PromptSys_ScreenSize
        _PromptSys_hBitmap = CreateCompatibleBitmap(hdc, .cx, .cy)
    End With
    _PromptSys_hMemDC = CreateCompatibleDC(hdc)
    SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap)

    'Initialize for Win9x
    ClearGraphicsScreen()

    Dim tm As TEXTMETRIC
    Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT
    GetTextMetrics(_PromptSys_hMemDC, tm)
    SelectObject(_PromptSys_hMemDC, hOldFont)
    With _PromptSys_FontSize
        .cx = tm.tmAveCharWidth
        .cy = tm.tmHeight
    End With

    '_PromptSys_hFont initialize
    Dim lf As LOGFONT
    With lf
        .lfHeight = -MulDiv(12, GetDeviceCaps(hdc, LOGPIXELSY), 72)
        .lfWidth = 0
        .lfEscapement = 0
        .lfOrientation = 0
        .lfWeight = 0
        .lfItalic = 0
        .lfUnderline = 0
        .lfStrikeOut = 0
        .lfCharSet = SHIFTJIS_CHARSET
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfQuality = DEFAULT_QUALITY
        .lfPitchAndFamily = FIXED_PITCH
        lstrcpy(.lfFaceName, ToTCStr("ＭＳ 明朝"))
    End With

    _PromptSys_hFont = CreateFontIndirect(lf)

    ReleaseDC(hwnd, hdc)

    _PromptWnd_OnCreate = 0
End Function

Sub _PromptWnd_OnPaint(hwnd As HWND)
    Dim ps As PAINTSTRUCT
    Dim hdc = BeginPaint(hwnd, ps)
    With _PromptSys_ScreenSize
        BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY)
'   With ps.rcPaint
'       BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY)
    End With
    DrawPromptBuffer(hdc, -1, 0)
    EndPaint(hwnd, ps)
End Sub

Sub _PromptWnd_OnSetFocus(hwnd As HWND, hwndOldFocus As HWND)
    If _PromptSys_InputLen <> -1 Then
        Dim himc = ImmGetContext(hwnd)
        If himc Then
            Dim CompForm As COMPOSITIONFORM
            With CompForm
                .dwStyle = CFS_POINT
                .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx
                .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy
            End With
            ImmSetCompositionWindow(himc, CompForm)

            Dim lf As LOGFONT
            GetObject(_PromptSys_hFont, Len(lf), lf)
            ImmSetCompositionFont(himc, lf)
        End If
        ImmReleaseContext(hwnd, himc)

        CreateCaret(hwnd, 0, 9, 6)
        With _PromptSys_CurPos
            SetCaretPos(_PromptSys_TextLine[.y].CharInfo[.x].StartPos, (.y + 1) * _PromptSys_FontSize.cy - 7)
        End With
        ShowCaret(hwnd)
    End If
End Sub

Sub _PromptWnd_OnKillForcus(hwnd As HWND, hwndNewFocus As HWND)
    HideCaret(hwnd)
    DestroyCaret()
End Sub

Sub _PromptWnd_OnKeyDown(vk As DWord, repeat As DWord, flags As DWord)
    If _PromptSys_InputLen = -1 Then
        _PromptSys_KeyChar = vk As Byte
    End If
End Sub

Sub _PromptWnd_OnDestroy(hwnd As HWND)
    DeleteDC(_PromptSys_hMemDC)
    DeleteObject(_PromptSys_hBitmap)

    PostQuitMessage(0)
End Sub

Sub _PromptWnd_OnChar(hwnd As HWND, wParam As WPARAM, lParam As LPARAM)
    Dim TempStr As String
    If _PromptSys_InputLen <> -1 Then
        If wParam = VK_BACK Then
            If _PromptSys_InputLen Then
                _PromptSys_InputLen--
                _PromptSys_InputStr[_PromptSys_InputLen] = 0

                _PromptSys_CurPos.x--
                With _PromptSys_CurPos
                    _PromptSys_TextLine[.y].Text[.x] = 0
                End With
            End If
        ElseIf wParam = VK_RETURN Then
            _PromptSys_InputStr[_PromptSys_InputLen] = 0
            _PromptSys_InputLen = -1
            TempStr = Ex"\r\n"
        ElseIf wParam = &H16 Then
/*
            'Paste Command(Use Clippboard)
            OpenClipboard(hwnd)
            Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL
            If hGlobal = 0 Then Exit Sub
            Dim pTemp = GlobalLock(hGlobal) As PCSTR
#ifdef UNICODE 'A版ウィンドウプロシージャ用
            Dim tempSizeA = lstrlenA(pTemp)
            Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1
            TempStr = ZeroString(tempSizeW)
            MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW)
#else
            TempStr = ZeroString(lstrlen(pTemp) + 1)
            lstrcpy(StrPtr(TempStr), pTemp)
#endif
            memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length)
            _PromptSys_InputLen += TempStr.Length

            GlobalUnlock(hGlobal)
            CloseClipboard()
*/
        Else
            Dim t = wParam As TCHAR
            TempStr = New String(VarPtr(t), 1)
            _PromptSys_InputStr[_PromptSys_InputLen] = TempStr[0]
            _PromptSys_InputLen++
        End If

        SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
        ActiveBasic.Prompt.Detail.PRINT_ToPrompt(TempStr)
        SendMessage(hwnd, WM_SETFOCUS, 0, 0)
    End If
End Sub

Function _PromptWnd_GetCompositionStringW(himc As HIMC, ByRef rpsz As PWSTR) As Long
    Dim size = ImmGetCompositionStringW(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
    rpsz = GC_malloc(size) As PWSTR
    If rpsz = 0 Then
        'Debug
        Return 0
    End If
    Return ImmGetCompositionStringW(himc, GCS_RESULTSTR, rpsz, size)
End Function

Function _PromptWnd_GetCompositionStringA(himc As HIMC, ByRef rpsz As PSTR) As Long
    Dim size = ImmGetCompositionStringA(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
    rpsz = GC_malloc(size) As PSTR
    If rpsz = 0 Then
        'Debug
        Return 0
    End If
    Return ImmGetCompositionStringA(himc, GCS_RESULTSTR, rpsz, size)
End Function

Function _PromptWnd_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT
    If (lp And GCS_RESULTSTR) <> 0 Then
        Dim himc = ImmGetContext(hwnd)
        If himc = 0 Then
            'Debug
            Return 0
        End If
        Dim tempStr = Nothing As String
        Dim str As *Char
#ifdef UNICODE
        Dim osver = System.Environment.OSVersion
        With osver
            ' GetCompositionStringW is not implimented in Windows 95
            If .Version.Major = 4 And .Version.Minor = 0 And .Platform = System.PlatformID.Win32Windows Then
                Dim strA As PCSTR
                Dim sizeA = _PromptWnd_GetCompositionStringA(himc, strA)
                tempStr = New String(strA, sizeA As Long)
            Else
                Dim size = _PromptWnd_GetCompositionStringW(himc, str)
                tempStr = New String(str, (size \ SizeOf (WCHAR)) As Long)
            End If
        End With
#else
        Dim size = _PromptWnd_GetCompositionStringA(himc, str)
        tempStr = New String(str, size As Long)
#endif
        ImmReleaseContext(hwnd, himc)

        ActiveBasic.Strings.ChrCopy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), tempStr.StrPtr, tempStr.Length As SIZE_T)
        _PromptSys_InputLen += tempStr.Length

        SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
        ActiveBasic.Prompt.Detail.PRINT_ToPrompt(tempStr)
        SendMessage(hwnd, WM_SETFOCUS, 0, 0)

        _PromptWnd_OnImeCompostion = 0
    Else
        _PromptWnd_OnImeCompostion = DefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp)
    End If
End Function

Function PromptMain(data As VoidPtr) As DWord
    Dim i As Long
    'Allocate
    For i = 0 To 100
        With _PromptSys_TextLine[i]
            .Length = 0
            .Text = _System_calloc(SizeOf (Char) * 255)
            .CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
        End With
    Next

    'Current Colors initialize
    _PromptSys_NowTextColor = RGB(255, 255, 255)
    _PromptSys_NowBackColor = RGB(0, 0, 0)

    'Setup
    With _PromptSys_ScreenSize
        .cx = GetSystemMetrics(SM_CXSCREEN)
        .cy = GetSystemMetrics(SM_CYSCREEN)
    End With

    'Critical Section
    InitializeCriticalSection(_PromptSys_SectionOfBufferAccess)

    'Regist Prompt Class
    Dim wcl As WNDCLASSEX
    ZeroMemory(VarPtr(wcl), Len(wcl))
    With wcl
        .cbSize = Len(wcl)
        .hInstance = GetModuleHandle(0)
        .style = CS_HREDRAW Or CS_VREDRAW' or CS_DBLCLKS
        .hIcon = LoadImage(0, MAKEINTRESOURCE(IDI_APPLICATION), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
        .hIconSm = LoadImage(0, MAKEINTRESOURCE(IDI_WINLOGO), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
        .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
        .lpszClassName = ToTCStr("PROMPT")
        .lpfnWndProc = AddressOf(PromptProc)
        .hbrBackground = GetStockObject(BLACK_BRUSH)
    End With
    Dim atom = RegisterClassEx(wcl)

    'Create Prompt Window
    _PromptSys_hWnd = CreateWindowEx(WS_EX_CLIENTEDGE, atom As ULONG_PTR As LPCTSTR, ToTCStr("BASIC PROMPT"), _
        WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
        0, 0, wcl.hInstance, 0)
    ShowWindow(_PromptSys_hWnd, SW_SHOW)
    UpdateWindow(_PromptSys_hWnd)
    SetEvent(_PromptSys_hInitFinish)
    Dim msg As MSG
    Do
        Dim iResult = GetMessage(msg, 0, 0, 0)
        If iResult = 0 Then
            System.Environment.ExitCode = msg.wParam As Long
            Exit Do
        ElseIf iResult = -1 Then
            Exit Do
        End If
        TranslateMessage(msg)
        DispatchMessage(msg)
    Loop

    '強制的に終了する
    End

    EnterCriticalSection(_PromptSys_SectionOfBufferAccess)

    For i = 0 to 100
        _System_free(_PromptSys_TextLine[i].Text)
        _System_free(_PromptSys_TextLine[i].CharInfo)
    Next

    LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)

    DeleteCriticalSection(_PromptSys_SectionOfBufferAccess)

    End
End Function

Sub ClearGraphicsScreen()
    Dim rc As RECT
    With rc
        .left = 0
        .top = 0
        .right = _PromptSys_ScreenSize.cx
        .bottom = _PromptSys_ScreenSize.cy
    End With
    SetBkColor(_PromptSys_hMemDC, 0)
    ExtTextOut(_PromptSys_hMemDC, 0, 0, ETO_OPAQUE, rc, "", 0, 0) '矩形塗り潰しはExtTextOutが速いらしい
End Sub

'Prompt text command functoins

Sub Cls(n As Long)
    Dim i As Long

    'When parameter was omitted, num is set to 1
    If n = 0 Then n = 1

    If n = 1 Or n = 3 Then
        'Clear the text screen
        For i = 0 To 100
            With _PromptSys_TextLine[i]
                .Text[0] = 0 '_System_FillChar(_PromptSys_TextLine[i].Text, -1 As Char, 0)
                .Length = 0
            End With
        Next
        With _PromptSys_CurPos
            .x = 0
            .y = 0
        End With
    End If

    If n = 2 Or n = 3 Then
        'Clear the graphics screen
        ClearGraphicsScreen()
    End If

    'Redraw
    InvalidateRect(_PromptSys_hWnd, ByVal 0, 0)
End Sub

Sub Color(textColorCode As Long, backColorCode As Long)
    _PromptSys_NowTextColor = GetBasicColor(textColorCode)
    If backColorCode = -1 Then
        _PromptSys_NowBackColor = -1
    Else
        _PromptSys_NowBackColor = GetBasicColor(backColorCode)
    End If
End Sub

Sub INPUT_FromPrompt(showStr As String)
*InputReStart

    ActiveBasic.Prompt.Detail.PRINT_ToPrompt(showStr)

    'Input by keyboard
    _PromptSys_InputLen = 0
    SendMessage(_PromptSys_hWnd, WM_SETFOCUS, 0, 0)
    While _PromptSys_InputLen <> -1
        Sleep(10)
    Wend
    SendMessage(_PromptSys_hWnd, WM_KILLFOCUS, 0, 0)

    'Set value to variable
    Const comma = &h2c As Char 'Asc(",")
    Dim broken = ActiveBasic.Strings.Detail.Split(New String(_PromptSys_InputStr), comma)
    Dim i As Long
    For i = 0 To ELM(broken.Count)
        If _System_InputDataPtr[i] = 0 Then
            ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
            Goto *InputReStart
        End If
        _System_Input_SetArgument(_System_InputDataPtr[i], _System_InputDataType[i], broken.Item[i])
    Next

    If _System_InputDataPtr[i]<>0 Then
        ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
        Goto *InputReStart
    End If
End Sub

Sub Locate(x As Long, y As Long)
    If x < 0 Then x = 0
    If y < 0 Then y = 0
    If y > 100 Then y = 100
    With _PromptSys_CurPos
        .x = x
        .y = y
    End With

    Dim i = _PromptSys_TextLine[y].Length
    If i < x Then
        ActiveBasic.Strings.ChrFill(VarPtr(_PromptSys_TextLine[y].Text[i]), x - i, &h20 As Char) 'Asc(" ")
        Dim i2 As Long
        For i2 = i To ELM(x)
            _PromptSys_TextLine[y].CharInfo[i2].BackColor = -1
        Next
        _PromptSys_TextLine[y].Length = x
    End If
End Sub

'Prompt graphic command functions

Sub Circle(x As Double, y As Double, radius As Double, ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
    Dim hPen = CreatePen(PS_SOLID, 1, GetBasicColor(ColorCode))
    Dim hBrush As HBRUSH
    If bFill Then
        hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
    Else
        hBrush = GetStockObject(NULL_BRUSH)
    End If

    Dim hdc = GetDC(_PromptSys_hWnd)
    Dim hOldPenDC = SelectObject(hdc, hPen)
    Dim hOldBrushDC = SelectObject(hdc, hBrush)
    Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)

    Dim yRadius As Double
    Dim xRadius As Double
    If Aspect = 1 Then
        yRadius = radius
        xRadius = radius
    ElseIf Aspect < 1 Then
        yRadius = radius * Aspect
        xRadius = radius
    Else
        yRadius = radius
        xRadius = radius / Aspect
    End If

    Dim x1 = (x - xRadius) As Long
    Dim x2 = (x + xRadius) As Long
    Dim y1 = (y - yRadius) As Long
    Dim y2 = (y + yRadius) As Long

    If StartPos = 0 And EndPos = 0 Then
        Ellipse(hdc, x1, y1, x2, y2)
        Ellipse(_PromptSys_hMemDC, x1, y1, x2, y2)
    Else
        Dim isPie As Boolean
        If StartPos < 0 Or EndPos < 0 Then
            isPie = True
            StartPos = Math.Abs(StartPos)
            EndPos = Math.Abs(EndPos)
        Else
            isPie = False
        End If

        Dim scaleRadial = (x + y) * 0.5
        Dim startX = (x + ActiveBasic.Math.Cos(StartPos) * scaleRadial) As Long
        Dim startY = (y - ActiveBasic.Math.Sin(StartPos) * scaleRadial) As Long
        Dim endX = (x + ActiveBasic.Math.Cos(EndPos) * scaleRadial) As Long
        Dim endY = (y - ActiveBasic.Math.Sin(EndPos) * scaleRadial) As Long

        If isPie Then
            Pie(hdc, x1, y1, x2, y2, startX, startY, endX, endY)
            Pie(_PromptSys_hMemDC, x1, y1, x2, y2, startX, startY, endX, endY)
        Else
            Arc(hdc, x1, y1, x2, y2, startX, startY, endX, endY)
            Arc(_PromptSys_hMemDC, x1, y1, x2, y2, startX, startY, endX, endY)
        End If
    End If

    SelectObject(hdc, hOldPenDC)
    SelectObject(hdc, hOldBrushDC)
    ReleaseDC(_PromptSys_hWnd, hdc)
    SelectObject(_PromptSys_hMemDC, hOldPen)
    SelectObject(_PromptSys_hMemDC, hOldBrush)
    DeleteObject(hPen)
    If bFill Then DeleteObject(hBrush)
End Sub

Sub 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)
    Dim temp As Long

    If sx = &H80000000 And sy = &H80000000 Then
        With _PromptSys_GlobalPos
            sx = .x
            sy = .y
        End With
    End If

    If bStep Then
        ex += sx
        ey += sy
    Else
        If fType Then
            'ラインの場合（四角形でない場合）
            If sx>ex Then
                temp=ex
                ex=sx
                sx=temp
            End If
            If sy>ey Then
                temp=ey
                ey=sy
                sy=temp
            End If
        End If
    End If

    Dim hdc = GetDC(_PromptSys_hWnd)
    Dim hPen = CreatePen(PS_SOLID, 1, GetBasicColor(ColorCode))
    Dim hBrush As HBRUSH
    If fType=2 Then
        hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
    Else
        hBrush = GetStockObject(NULL_BRUSH)
    End If

    SelectObject(hdc, hPen)
    SelectObject(hdc, hBrush)
    Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)

    Select Case fType
        Case 0
            'line
            MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
            LineTo(_PromptSys_hMemDC,ex,ey)
            SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode))
            MoveToEx(hdc,sx,sy,ByVal NULL)
            LineTo(hdc,ex,ey)
            SetPixel(hdc,ex,ey,GetBasicColor(ColorCode))
        Case Else
            'Rectangle
            Rectangle(hdc,sx,sy,ex+1,ey+1)
            Rectangle(_PromptSys_hMemDC,sx,sy,ex+1,ey+1)
    End Select

    ReleaseDC(_PromptSys_hWnd,hdc)
    SelectObject(_PromptSys_hMemDC,hOldPen)
    SelectObject(_PromptSys_hMemDC,hOldBrush)
    DeleteObject(hPen)
    If fType = 2 Then DeleteObject(hBrush)
    With _PromptSys_GlobalPos
        .x = ex
        .y = ey
    End With
End Sub

Sub PSet(x As Long, y As Long, ColorCode As Long)
    Dim hdc = GetDC(_PromptSys_hWnd)
    SetPixel(hdc, x, y, GetBasicColor(ColorCode))
    SetPixel(_PromptSys_hMemDC, x, y, GetBasicColor(ColorCode))
    ReleaseDC(_PromptSys_hWnd, hdc)
    With _PromptSys_GlobalPos
        .x = x
        .y = y
    End With
End Sub

Sub Paint(x As Long, y As Long, BrushColor As Long, LineColor As Long)
    Dim hbr = CreateSolidBrush(GetBasicColor(BrushColor))

    Dim hdc = GetDC(_PromptSys_hWnd)
    Dim hbrOld = SelectObject(_PromptSys_hMemDC, hbr)
    Dim hbrOldWndDC = SelectObject(hdc, hbr)

    ExtFloodFill(hdc, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
    ExtFloodFill(_PromptSys_hMemDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)

    ReleaseDC(_PromptSys_hWnd, hdc)
    SelectObject(_PromptSys_hMemDC, hbrOld)
    SelectObject(hdc, hbrOldWndDC)
    DeleteObject(hbr)
End Sub

Function Inkey$() As String
    If _PromptSys_KeyChar=0 Then
        Inkey$=""
    Else
        Inkey$=Chr$(_PromptSys_KeyChar)
    End If
    _PromptSys_KeyChar=0
End Function

Function Input$(length As Long) As String
    Dim i = 0 As Long

    If length<=0 Then
        Input$=""
        Exit Function
    End If

    While 1
        If _PromptSys_KeyChar Then
            Input$=Input$+Chr$(_PromptSys_KeyChar)
            _PromptSys_KeyChar=0
            i++
            If i >= length Then
                Exit While
            End If
        End If
        Sleep(1)
    Wend
End Function

End Namespace 'Detail

Function OwnerWnd() As HWND
    Return Detail._PromptSys_hWnd
End Function

End Namespace 'Prompt
End Namespace 'ActiveBasic

'----------------------
' Prompt text Commands
'----------------------

Sub PRINT_ToPrompt(s As String)
    ActiveBasic.Prompt.Detail.PRINT_ToPrompt(s)
End Sub

Macro CLS()(num As Long)
    ActiveBasic.Prompt.Detail.Cls(num)
End Macro

Macro COLOR(TextColorCode As Long)(BackColorCode As Long)
    ActiveBasic.Prompt.Detail.Color(TextColorCode, BackColorCode)
End Macro

'---------- Defined in "command.sbp" ----------
'Dim _System_InputDataPtr[_System_MAX_PARMSNUM] As VoidPtr
'Dim _System_InputDataType[_System_MAX_PARMSNUM] As DWord
'----------------------------------------------
Sub INPUT_FromPrompt(ShowStr As String)
    ActiveBasic.Prompt.Detail.INPUT_FromPrompt(ShowStr)
End Sub

/* TODO: _System_GetUsingFormatを用意して実装する
Sub PRINTUSING_ToPrompt(UsingStr As String)
    ActiveBasic.Prompt.Detail.PRINT_ToPrompt(_System_GetUsingFormat(UsingStr))
End Sub
*/

Macro LOCATE(x As Double, y As Double)
    ActiveBasic.Prompt.Detail.Locate(x As Long, y As Long)
End Macro


'-------------------
' Graphics Commands
'-------------------

Macro CIRCLE(x As Double , y As Double, radius As Double)(ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
    '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します）
    'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2]
    ActiveBasic.Prompt.Detail.Circle(x, y, radius, ColorCode, StartPos, EndPos, Aspect, bFill, BrushColor)
End Macro

Macro LINE(sx As Double, sy As Double, bStep As Long, ex As Double, ey As Double)(ColorCode As Long, fType As Long, BrushColor As Long)
    '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します）
    'Line (sx,sy)-[STEP](ex,ey),[ColorCode],[B/Bf],[BrushColor]
    ActiveBasic.Prompt.Detail.Line(sx As Long, sy As Long, bStep, ex As Long, ey As Long, ColorCode, fType, BrushColor)
End Macro

Macro PSET(x As Double, y As Double)(ColorCode As Long)
    '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します）
    'PSet (x,y),ColorCode
    ActiveBasic.Prompt.Detail.PSet(x As Long, y As Long, ColorCode)
End Macro

Macro PAINT(x As Double, y As Double, BrushColor As Long)(ByVal LineColor As Long)
    '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します）
    'Paint (x,y),BrushColor,LineColor
    ActiveBasic.Prompt.Detail.Paint(x As Long, y As Long, BrushColor, LineColor)
End Macro


'-----------
' Functions
'-----------

Function Inkey$() As String
    Return ActiveBasic.Prompt.Detail.Inkey$()
End Function

Function Input$(length As Long) As String
    Return ActiveBasic.Prompt.Detail.Input$(length)
End Function

ActiveBasic.Prompt.Detail._PromptSys_Initialize()

#endif '_INC_PROMPT