source: Include/basic/prompt.sbp@ 258

'prompt.sbp


#ifndef _INC_PROMPT
#define _INC_PROMPT

#require <api_imm.sbp>
#require <Classes/System/Math.ab>
#require <Classes/System/Environment.ab>

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)
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 *StrChar
    CharInfo As *_PromptSys_CharacterInformation
End Type

Dim _PromptSys_hFont As HFONT
Dim _PromptSys_FontSize As SIZE
Dim _PromptSys_InputStr[255] As StrChar
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

Dim _System_OSVersionInfo As OSVERSIONINFO


'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 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 (StrChar) * 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
                    SetBkMode(hDC, OPAQUE)
                    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 *StrChar, tempLen)
                End With
                i2 += tempLen
            Wend
        End If

        i++
    Wend

    SelectObject(hDC, hOldFont)
End Sub

Sub PRINT_ToPrompt(buf As String)
    EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
    With _PromptSys_CurPos
        Dim hdc = GetDC(_PromptSys_hWnd)
        Dim hOldFont = SelectObject(hdc, _PromptSys_hFont)
        Dim StartLine As Long : StartLine = .y
        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 = 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
                        _PromptSys_GetTextExtentPoint32(hdc, VarPtr(buf.Chars[i2]) As *StrChar, charLen, sz)
                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx
/*
                        Dim buf[1023] As Char
                        wsprintf(buf, Ex"%d %d\r\n", currentLineCharInfo[.x + 1].StartPos, currentLineCharInfo[.x].StartPos + sz.cx)
                        OutputDebugString(buf)
*/
                    End If
                End If
                .x++
            End If
        Next
        _PromptSys_TextLine[.y].Length = Math.Max(_PromptSys_TextLine[.y].Length, .x)

        'Draw the text buffer added
        DrawPromptBuffer(hdc, StartLine, .y)
        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
    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH
    With _PromptSys_ScreenSize
        PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
    End With
    SelectObject(_PromptSys_hMemDC, hOldBrush)

    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

    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
            _PromptSys_InputStr[_PromptSys_InputLen] = wParam As Byte
            _PromptSys_InputLen++

            TempStr.ReSize(1)
            TempStr[0] = wParam As Char
        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 = _System_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 = _System_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 As String
        Dim str As *StrChar
#ifdef __STRING_IS_NOT_UNICODE
        Dim size = _PromptWnd_GetCompositionStringA(himc, str)
        tempStr.Assign(str, size)
#else
        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.AssignFromMultiByte(strA, sizeA)
            Else
                Dim size = _PromptWnd_GetCompositionStringW(himc, str)
                tempStr.Assign(str, size \ SizeOf (WCHAR))
            End If
        End With
#endif
        ImmReleaseContext(hwnd, himc)
        _System_free(str)

        memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), tempStr.Chars, SizeOf (StrChar) * tempStr.Length)
        _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(dwData As Long) As Long
    GetVersionEx(_System_OSVersionInfo)

    Dim i As Long
    'Allocate
    For i = 0 To 100
        With _PromptSys_TextLine[i]
            .Length = 0
            .Text = _System_calloc(SizeOf (StrChar) * 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

    '_PromptSys_hFont initialize
    Dim lf As LOGFONT
    With lf
        .lfHeight = -16
        .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)

    '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

'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 StrChar, 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
        Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH))
        With _PromptSys_ScreenSize
            PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
        End With
        SelectObject(_PromptSys_hMemDC, hOldBrush)
    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)
    Dim i As Long, i2 As Long, i3 As Long
    Dim buf 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
    i = 0
    i2 = 0
    buf = ZeroString(lstrlen(_PromptSys_InputStr))
    While 1
        i3 = 0
        While 1
            If _PromptSys_InputStr[i2] = &h2c Then
                buf.Chars[i3] = 0
                Exit While
            End If

            buf.Chars[i3] = _PromptSys_InputStr[i2]

            If _PromptSys_InputStr[i2] = 0 Then Exit While

            i2++
            i3++
        Wend

        _System_Input_SetArgument(_System_InputDataPtr[i], _System_InputDataType[i], buf, i3)

        i++
        If _System_InputDataPtr[i] = 0 and _PromptSys_InputStr[i2] = &h2c Then 'Asc(",")
            ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
            Goto *InputReStart
        ElseIf _PromptSys_InputStr[i2] = 0 Then
            If _System_InputDataPtr[i]<>0 Then
                ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
                Goto *InputReStart
            Else
                Exit While
            End If
        End If

        i2++
    Wend
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
        _System_FillChar(VarPtr(_PromptSys_TextLine[y].Text[i]), x - i, &h20 As StrChar) '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 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)
    Dim i1 As Long, i2 As Long, i3 As Long, i4 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 radi2 As Long
    If Aspect<1 Then
        radi2=(CDbl(radius)*Aspect) As Long
    Else
        radi2=radius
        radius=(CDbl(radius)/Aspect) As Long
    End If

    If StartPos=0 And EndPos=0 Then
        Ellipse(hDC,x-radius,y-radi2,x+radius,y+radi2)
        Ellipse(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2)
    Else
        Dim sw As Long
        StartPos *=StartPos
        EndPos *=EndPos

        If StartPos<0 Or EndPos<0 Then
            sw=1
        Else
            sw=0
        End If

        StartPos = Abs(StartPos)
        EndPos = Abs(EndPos)

        If StartPos<=78.5 Then
            i1=78
            i2=Int(StartPos)
        ElseIf StartPos<=235.5 Then
            StartPos -= 78.5
            i1=78-Int(StartPos)
            i2=78
        ElseIf StartPos<=392.5 Then
            StartPos -= 235.5
            i1=-78
            i2=78-Int(StartPos)
        ElseIf StartPos<=549.5 Then
            StartPos -= 392.5
            i1=-78+Int(StartPos)
            i2=-78
        ElseIf StartPos<=628 Then
            StartPos -= 549.5
            i1=78
            i2=-78+Int(StartPos)
        End If

        If EndPos<=78.5 Then
            i3=78
            i4=Int(EndPos)
        ElseIf EndPos<=235.5 Then
            EndPos -= 78.5
            i3=78-Int(EndPos)
            i4=78
        ElseIf EndPos<=392.5 Then
            EndPos -= 235.5
            i3=-78
            i4=78-Int(EndPos)
        ElseIf EndPos<=549.5 Then
            EndPos -= 392.5
            i3=-78+Int(EndPos)
            i4=-78
        ElseIf EndPos<=628 Then
            EndPos -= 549.5
            i3=78
            i4=-78+Int(EndPos)
        End If

        If sw Then
            Pie(hDC,x-radius,y-radi2,x+radius,y+radi2,  x+i1,y-i2,x+i3,y-i4)
            Pie(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2,  x+i1,y-i2,x+i3,y-i4)
        Else
            Arc(hDC,x-radius,y-radi2,x+radius,y+radi2,  x+i1,y-i2,x+i3,y-i4)
            Arc(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2,  x+i1,y-i2,x+i3,y-i4)
        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

Sub PRINTUSING_ToPrompt(UsingStr As String)
    ActiveBasic.Prompt.Detail.PRINT_ToPrompt(_System_GetUsingFormat(UsingStr))
End Sub

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


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

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

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

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