source: Include/basic/prompt.sbp @ 127

'prompt.sbp


#ifndef _INC_PROMPT
#define _INC_PROMPT


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

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_LogFont As LOGFONTA 'LOGFONT
Dim _PromptSys_hFont As HFONT
Dim _PromptSys_FontSize As SIZE
Dim _PromptSys_InputStr[255] As Char
Dim _PromptSys_InputLen 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


_PromptSys_InputLen = -1

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

_PromptSys_hInitFinish = CreateEvent(0, FALSE, FALSE, 0)
CreateThread(0, 0, AddressOf(PromptMain) As LPTHREAD_START_ROUTINE, 0, 0, _PromptSys_dwThreadID)
WaitForSingleObject(_PromptSys_hInitFinish, INFINITE)

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 (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
            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
                    TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]), 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' : Debug
        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 As *_PromptSys_CharacterInformation
                _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
                        GetTextExtentPoint32(hdc, VarPtr(buf.Chars[i2]), 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)
            ImmSetCompositionFontA(himc, _PromptSys_LogFont)
        End If
        ImmReleaseContext(hwnd, himc)

        CreateCaret(hwnd, 0, 9, 6)
        SetCaretPos(_PromptSys_CurPos.x * _PromptSys_FontSize.cx, (_PromptSys_CurPos.y + 1) * _PromptSys_FontSize.cy - 7)
        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)
        PRINT_ToPrompt(TempStr)
        SendMessage(hwnd, WM_SETFOCUS, 0, 0)
    End If
End Sub

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 size = ImmGetCompositionString(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
        Dim str = _System_malloc(size) As PTSTR
        If str = 0 Then
            'Debug
            Return 0
        End If
        ImmGetCompositionString(himc, GCS_RESULTSTR, str, size)
        ImmReleaseContext(hwnd, himc)

        memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), str, size)
        _PromptSys_InputLen += size

        Dim tempStr As String(str, size \ SizeOf (Char))
        _System_free(str)

        SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
        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
    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

    'LogFont initialize
    With _PromptSys_LogFont
        .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
#ifdef UNICODE
        WideCharToMultiByte(CP_ACP, 0, "ＭＳ 明朝", 5, .lfFaceName, LF_FACESIZE, 0, 0)
#else
        lstrcpy(.lfFaceName, "ＭＳ 明朝")
#endif
    End With

    _PromptSys_hFont = CreateFontIndirectA(_PromptSys_LogFont)

    '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 = "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 PCSTR, "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 Or iResult = -1 Then Exit Do
        TranslateMessage(msg)
        DispatchMessage(msg)
    Loop

    '強制的に終了する
    ExitProcess(0)

    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)

    ExitProcess(0)
End Function


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

Macro CLS()(num As Long)
    Dim i As Long

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

    If num = 1 Or num = 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 num = 2 Or num = 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 Macro

Macro 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 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)
    Dim i As Long ,i2 As Long, i3 As Long
    Dim buf As String

*InputReStart

    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(",")
            PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
            Goto *InputReStart
        ElseIf _PromptSys_InputStr[i2] = 0 Then
            If _System_InputDataPtr[i]<>0 Then
                PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
                Goto *InputReStart
            Else
                Exit While
            End If
        End If

        i2++
    Wend
End Sub

Sub PRINTUSING_ToPrompt(UsingStr As String)
    PRINT_ToPrompt(_System_GetUsingFormat(UsingStr))
End Sub

Macro 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) '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 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]

    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 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]
    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 Macro

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

    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 Macro

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

    Dim hBrush = CreateSolidBrush(GetBasicColor(BrushColor))

    Dim hDC = GetDC(_PromptSys_hWnd)
    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
    Dim hOldBrushWndDC = SelectObject(hDC, hBrush)

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

    ReleaseDC(_PromptSys_hWnd, hDC)
    SelectObject(_PromptSys_hMemDC, hOldBrush)
    SelectObject(hDC, hOldBrushWndDC)
    DeleteObject(hBrush)
End Macro


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

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 As Long

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

    i=0
    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


#endif '_INC_PROMPT