News:

Welcome to RetroCoders Community

Main Menu

Recent posts

Pages1 2 3 ... 10
#1
Oxygen Basic / chatbot Danny in OxygenBasic
Last post by ron77 - Jan 13, 2026, 11:57 PM 
' ============================================================================
' Chatbot Danny for Oxygen Basic
' Version 1.0.0 - 2025
' Converted from QB64PE by Ronen Blumberg
' Using O2's built-in Windows GUI support
' ============================================================================

$ filename "danny.exe"
uses rtl32
uses MinWin

' Additional API declarations
! WinExec lib "kernel32.dll" (char*lpCmdLine, int nCmdShow) as dword
! GetWindowTextLengthA lib "user32.dll" (sys hWnd) as int
! GetWindowTextA lib "user32.dll" (sys hWnd, sys lpString, int nMaxCount) as int
! SetWindowTextA lib "user32.dll" (sys hWnd, char*lpString) as int
! SetFocus lib "user32.dll" (sys hWnd) as sys
! MoveWindow lib "user32.dll" (sys hWnd, int x, int y, int nWidth, int nHeight, int bRepaint) as int
! DestroyWindow lib "user32.dll" (sys hWnd) as int
! CreateFontA lib "gdi32.dll" (int nHeight, int nWidth, int nEscapement, int nOrientation, int fnWeight, dword fdwItalic, dword fdwUnderline, dword fdwStrikeOut, dword fdwCharSet, dword fdwOutputPrecision, dword fdwClipPrecision, dword fdwQuality, dword fdwPitchAndFamily, char* lpszFace) as sys
! GetFocus lib "user32.dll" () as sys

% FW_NORMAL = 400
% DEFAULT_CHARSET = 1
% OUT_DEFAULT_PRECIS = 0
% CLIP_DEFAULT_PRECIS = 0
% DEFAULT_QUALITY = 0
% DEFAULT_PITCH = 0
% VK_RETURN = 0x0D
% WM_KEYDOWN = 0x0100

#lookahead

' ============================================================================
' CONSTANTS
' ============================================================================

% ID_OUTPUT = 101
% ID_INPUT  = 102
% ID_SEND   = 103
% ID_ABOUT  = 104

% WS_OVERLAPPEDWINDOW = 0x00CF0000
% WS_VISIBLE = 0x10000000
% WS_CHILD   = 0x40000000
% WS_VSCROLL = 0x00200000
% WS_BORDER  = 0x00800000
% WS_TABSTOP = 0x00010000
% WS_EX_CLIENTEDGE = 0x00000200

% ES_MULTILINE    = 0x0004
% ES_AUTOVSCROLL  = 0x0040
% ES_AUTOHSCROLL  = 0x0080
% ES_READONLY     = 0x0800

% BS_PUSHBUTTON    = 0x00000000
% BS_DEFPUSHBUTTON = 0x00000001

% BN_CLICKED = 0
% WM_COMMAND = 0x0111
% WM_SIZE    = 0x0005
% WM_CLOSE   = 0x0010
% WM_DESTROY = 0x0002
% WM_CREATE  = 0x0001
% WM_SETFONT = 0x0030
% WM_GETMINMAXINFO = 0x0024

% EM_SETSEL     = 0x00B1
% EM_REPLACESEL = 0x00C2
% EM_SCROLLCARET = 0x00B7

% COLOR_BTNFACE = 15
% DEFAULT_GUI_FONT = 17

% SW_HIDE = 0
% SW_SHOW = 5

% MIN_WIDTH  = 500
% MIN_HEIGHT = 400

' ============================================================================
' GLOBAL VARIABLES
' ============================================================================

sys hMainWnd, hOutputEdit, hInputEdit, hSendButton, hAboutButton
sys hInstance, hFont

int useTTS = 1

' Database arrays - using O2 syntax
int numSwaps = 0
string swapFind[500]
string swapReplace[500]

int numGroups = 0
int numKeywords = 0
string keywords[2000]
int keywordGroup[2000]

int numReplies = 0
string replies[5000]
int replyGroup[5000]

int numDefaults = 0
string defaultReplies[200]

int numPrayerTriggers = 0
string prayerTriggers[50]

int numPrayer1 = 0
int numPrayer2 = 0
int numPrayer3 = 0
int numPrayer4 = 0
string prayerPart1[50]
string prayerPart2[50]
string prayerPart3[50]
string prayerPart4[50]

' ============================================================================
' STRING HELPER FUNCTIONS
' ============================================================================

function LTrimStr(string s) as string
    sys i = 1
    sys ln = len(s)
    if ln = 0 then return ""
    while i <= ln
        string ch = mid(s, i, 1)
        if ch <> " " and ch <> chr(9) then exit while
        i++
    wend
    if i > ln then return ""
    return mid(s, i)
end function

function RTrimStr(string s) as string
    sys i = len(s)
    if i = 0 then return ""
    while i >= 1
        string ch = mid(s, i, 1)
        if ch <> " " and ch <> chr(9) then exit while
        i--
    wend
    if i < 1 then return ""
    return left(s, i)
end function

function TrimStr(string s) as string
    return LTrimStr(RTrimStr(s))
end function

function StartsWith(string prefix, string s) as int
    sys plen = len(prefix)
    if plen > len(s) then return 0
    if left(s, plen) = prefix then return 1
    return 0
end function

function LowerCase(string s) as string
    string result = ""
    sys i, c
    sys slen = len(s)
    for i = 1 to slen
        c = asc(mid(s, i, 1))
        if c >= 65 and c <= 90 then
            result += chr(c + 32)
        else
            result += mid(s, i, 1)
        end if
    next
    return result
end function

function RandomInt(int maxVal) as int
    static sys seed = 0
    if seed = 0 then seed = GetTickCount()
    seed = (seed * 1103515245 + 12345) and 0x7FFFFFFF
    return (seed mod maxVal) + 1
end function

function IsolatePunctuation(string text) as string
    string result = ""
    string punctuation = "?!<>,."
    sys i
    sys tlen = len(text)
    
    for i = 1 to tlen
        string c = mid(text, i, 1)
        if instr(punctuation, c) > 0 then
            if len(result) > 0 and right(result, 1) <> " " then result += " "
            result += c + " "
        else
            result += c
        end if
    next
    
    ' Clean multiple spaces
    string cleaned = ""
    int prevSpace = 0
    sys rlen = len(result)
    for i = 1 to rlen
        string c = mid(result, i, 1)
        if c = " " then
            if prevSpace = 0 then cleaned += c : prevSpace = 1
        else
            cleaned += c : prevSpace = 0
        end if
    next
    return cleaned
end function

' ============================================================================
' DATABASE LOADING
' ============================================================================

sub ProcessDatabaseLine(string rawLine, byref int currentGroup)
    string ln = TrimStr(rawLine)
    sys iPos
    string part1, part2
    
    if len(ln) = 0 then return
    if StartsWith("###", ln) then return
    if StartsWith("===", ln) then return
    if StartsWith("---", ln) then return
    
    if StartsWith("s:", ln) then
        iPos = instr(ln, ">")
        if iPos > 3 then
            part1 = TrimStr(mid(ln, 3, iPos - 3))
            part2 = TrimStr(mid(ln, iPos + 1))
            numSwaps++ : swapFind[numSwaps] = part1 : swapReplace[numSwaps] = part2
        end if
    elseif StartsWith("k:", ln) then
        if currentGroup = 0 or numReplies > 0 then
            if numKeywords > 0 and keywordGroup[numKeywords] = currentGroup and currentGroup > 0 then
                int hasReplies = 0, ri
                for ri = 1 to numReplies
                    if replyGroup[ri] = currentGroup then hasReplies = 1 : exit for
                next
                if hasReplies then currentGroup++ : numGroups = currentGroup
            else
                currentGroup++ : numGroups = currentGroup
            end if
        end if
        numKeywords++
        keywords[numKeywords] = " " + LowerCase(TrimStr(mid(ln, 3))) + " "
        keywordGroup[numKeywords] = currentGroup
    elseif StartsWith("r:", ln) then
        if currentGroup > 0 then
            numReplies++ : replies[numReplies] = TrimStr(mid(ln, 3)) : replyGroup[numReplies] = currentGroup
        end if
    elseif StartsWith("d1:", ln) then
        numDefaults++ : defaultReplies[numDefaults] = TrimStr(mid(ln, 4))
    elseif StartsWith("c6:", ln) then
        numPrayerTriggers++ : prayerTriggers[numPrayerTriggers] = LowerCase(TrimStr(mid(ln, 4)))
    elseif StartsWith("p1:", ln) then
        numPrayer1++ : prayerPart1[numPrayer1] = TrimStr(mid(ln, 4))
    elseif StartsWith("p2:", ln) then
        numPrayer2++ : prayerPart2[numPrayer2] = TrimStr(mid(ln, 4))
    elseif StartsWith("p3:", ln) then
        numPrayer3++ : prayerPart3[numPrayer3] = TrimStr(mid(ln, 4))
    elseif StartsWith("p4:", ln) then
        numPrayer4++ : prayerPart4[numPrayer4] = TrimStr(mid(ln, 4))
    end if
end sub

sub LoadDatabase()
    int currentGroup = 0
    
    numSwaps = 0 : numGroups = 0 : numKeywords = 0 : numReplies = 0
    numDefaults = 0 : numPrayerTriggers = 0
    numPrayer1 = 0 : numPrayer2 = 0 : numPrayer3 = 0 : numPrayer4 = 0
    
    string fileContent = getfile("database.txt")
    if len(fileContent) = 0 then
        mbox "Cannot load database.txt file!"
        return
    end if
    
    ' Process file directly without storing all lines in array
    sys fileLen = len(fileContent)
    sys lineStart = 1
    sys i
    int lineCount = 0
    
    ' Use instr to find newlines instead of checking each character
    sys pos = 1
    sys nextNewline
    
    while pos <= fileLen
        nextNewline = instr(pos, fileContent, chr(10))
        if nextNewline = 0 then nextNewline = fileLen + 1
        
        sys lineLen = nextNewline - pos
        if lineLen > 0 then
            string ln = mid(fileContent, pos, lineLen)
            ' Remove CR if present
            if right(ln, 1) = chr(13) then
                ln = left(ln, len(ln) - 1)
            end if
            lineCount++
            ProcessDatabaseLine(ln, currentGroup)
        end if
        pos = nextNewline + 1
    wend
end sub

' ============================================================================
' CHATBOT LOGIC
' ============================================================================

function CheckPrayerTrigger(string userInput) as int
    string lowerInput = LowerCase(userInput)
    int i
    for i = 1 to numPrayerTriggers
        if instr(lowerInput, prayerTriggers[i]) > 0 then return 1
    next
    return 0
end function

function GeneratePrayer() as string
    string prayer = ""
    if numPrayer1 > 0 then prayer = prayerPart1[RandomInt(numPrayer1)]
    if numPrayer2 > 0 then
        if len(prayer) > 0 then prayer += " "
        prayer += prayerPart2[RandomInt(numPrayer2)]
    end if
    if numPrayer3 > 0 then
        if len(prayer) > 0 then prayer += " "
        prayer += prayerPart3[RandomInt(numPrayer3)]
    end if
    if numPrayer4 > 0 then
        if len(prayer) > 0 then prayer += " "
        prayer += prayerPart4[RandomInt(numPrayer4)]
    end if
    return prayer
end function

function SwapWords(string text) as string
    string result = ""
    string separators = " ,.!?;:" + chr(9) + chr(10) + chr(13)
    string currentWord = ""
    sys i
    int j, found
    sys tlen = len(text)
    
    for i = 1 to tlen
        string c = mid(text, i, 1)
        if instr(separators, c) > 0 then
            if len(currentWord) > 0 then
                found = 0
                for j = 1 to numSwaps
                    if LowerCase(currentWord) = LowerCase(swapFind[j]) then
                        result += swapReplace[j] : found = 1 : exit for
                    end if
                next
                if found = 0 then result += currentWord
                currentWord = ""
            end if
            result += c
        else
            currentWord += c
        end if
    next
    
    if len(currentWord) > 0 then
        found = 0
        for j = 1 to numSwaps
            if LowerCase(currentWord) = LowerCase(swapFind[j]) then
                result += swapReplace[j] : found = 1 : exit for
            end if
        next
        if found = 0 then result += currentWord
    end if
    return result
end function

sub FindAllKeywordMatches(string userInput, int *matches, byref int numMatches)
    string lowerInput = LowerCase(userInput)
    int foundGroups[500]
    int i, g
    numMatches = 0
    for i = 1 to 500 : foundGroups[i] = 0 : next
    for i = 1 to numKeywords
        g = keywordGroup[i]
        if foundGroups[g] = 0 then
            if instr(lowerInput, keywords[i]) > 0 then
                foundGroups[g] = 1 : numMatches++ : matches[numMatches] = g
            end if
        end if
    next
end sub

function GetReply(int groupId, string processedInput, string originalInput) as string
    string groupReplies[200]
    int numGroupReplies = 0, i
    string reply, lowerOriginal, kw, rest
    sys keywordPos, kwLen
    
    if groupId <= 0 or groupId > numGroups then
        if numDefaults > 0 then return defaultReplies[RandomInt(numDefaults)]
        return "I don't know what to say."
    end if
    
    for i = 1 to numReplies
        if replyGroup[i] = groupId then
            numGroupReplies++ : groupReplies[numGroupReplies] = replies[i]
        end if
    next
    
    if numGroupReplies = 0 then
        if numDefaults > 0 then return defaultReplies[RandomInt(numDefaults)]
        return "I don't know what to say."
    end if
    
    reply = groupReplies[RandomInt(numGroupReplies)]
    
    if right(reply, 1) = "*" then
        sys rlen = len(reply)
        reply = left(reply, rlen - 1)
        lowerOriginal = " " + LowerCase(originalInput) + " "
        for i = 1 to numKeywords
            if keywordGroup[i] = groupId then
                kw = keywords[i]
                keywordPos = instr(lowerOriginal, kw)
                if keywordPos > 0 then
                    kwLen = len(kw)
                    rest = mid(lowerOriginal, keywordPos + kwLen)
                    rest = TrimStr(rest)
                    if len(rest) > 0 then
                        rest = SwapWords(rest)
                        reply += " " + rest
                    end if
                    exit for
                end if
            end if
        next
    end if
    return reply
end function

function ProcessInput(string userInput) as string
    string processedInput, originalInput, lowerInput
    int matches[100], numMatches, i
    string reply, combinedReply, lastChar
    
    originalInput = userInput
    processedInput = IsolatePunctuation(userInput)
    processedInput = " " + TrimStr(processedInput) + " "
    lowerInput = LowerCase(processedInput)
    
    if CheckPrayerTrigger(userInput) then return GeneratePrayer()
    
    FindAllKeywordMatches(processedInput, @matches, numMatches)
    
    if numMatches = 0 then
        if numDefaults > 0 then return defaultReplies[RandomInt(numDefaults)]
        return "I don't know what to say."
    end if
    
    if numMatches > 16 then
        return "That's a lot to think about! Let's focus on one thing at a time."
    end if
    
    if numMatches = 1 then return GetReply(matches[1], processedInput, originalInput)
    
    combinedReply = ""
    for i = 1 to numMatches
        if i > 3 then exit for
        reply = GetReply(matches[i], processedInput, originalInput)
        if len(combinedReply) > 0 then
            lastChar = right(combinedReply, 1)
            if instr(".!?", lastChar) = 0 then combinedReply += "."
            combinedReply += " "
        end if
        combinedReply += reply
    next
    return combinedReply
end function

' ============================================================================
' TEXT-TO-SPEECH
' ============================================================================

sub Speak(string text)
    if useTTS = 0 then return
    if len(text) = 0 then return
    
    ' Simple clean - just replace quotes with nothing
    string cleanText = text
    sys i
    
    ' Replace problematic characters
    while instr(cleanText, chr(34)) > 0
        i = instr(cleanText, chr(34))
        cleanText = left(cleanText, i-1) + mid(cleanText, i+1)
    wend
    while instr(cleanText, "'") > 0
        i = instr(cleanText, "'")
        cleanText = left(cleanText, i-1) + mid(cleanText, i+1)
    wend
    while instr(cleanText, chr(13)) > 0
        i = instr(cleanText, chr(13))
        cleanText = left(cleanText, i-1) + " " + mid(cleanText, i+1)
    wend
    while instr(cleanText, chr(10)) > 0
        i = instr(cleanText, chr(10))
        cleanText = left(cleanText, i-1) + " " + mid(cleanText, i+1)
    wend
    
    if len(cleanText) = 0 then return
    
    string cmdLine = "voice.exe -r -1 -n " + chr(34) + "Microsoft David Desktop" + chr(34) + " -q " + chr(34) + cleanText + chr(34)
    WinExec(cmdLine, SW_HIDE)
end sub

' ============================================================================
' GUI FUNCTIONS
' ============================================================================

sub AddToOutput(string prefix, string text)
    string fullText = prefix + text + chr(13) + chr(10)
    sys textLen = GetWindowTextLengthA(hOutputEdit)
    SendMessage(hOutputEdit, EM_SETSEL, textLen, textLen)
    SendMessage(hOutputEdit, EM_REPLACESEL, 0, fullText)
    SendMessage(hOutputEdit, EM_SCROLLCARET, 0, 0)
end sub

sub HandleSend()
    int nLen = GetWindowTextLengthA(hInputEdit)
    if nLen = 0 then
        SetFocus(hInputEdit)
        return
    end if
    
    ' Get input text
    char inputBuffer[2048]
    GetWindowTextA(hInputEdit, @inputBuffer, 2048)
    string userInput = TrimStr(inputBuffer)
    
    if len(userInput) > 0 then
        AddToOutput("You: ", userInput)
        string response = ProcessInput(userInput)
        AddToOutput("Danny: ", response)
        AddToOutput("", "")
        SetWindowTextA(hInputEdit, "")
        if len(response) > 0 then
            Speak(response)
        end if
    end if
    SetFocus(hInputEdit)
end sub

sub ShowAbout()
    string txt
    txt = "Chatbot Danny" + chr(13) + chr(10)
    txt += "Version 1.0.0 - 2025" + chr(13) + chr(10) + chr(13) + chr(10)
    txt += "Developed by - Ronen Blumberg" + chr(13) + chr(10) + chr(13) + chr(10)
    txt += "A conversational chatbot based on" + chr(13) + chr(10)
    txt += "the developer's friend Danny Shaul" + chr(13) + chr(10) + chr(13) + chr(10)
    txt += "Features:" + chr(13) + chr(10)
    txt += "- Resizable window" + chr(13) + chr(10)
    txt += "- Scrollable chat history" + chr(13) + chr(10)
    txt += "- Text-to-Speech support" + chr(13) + chr(10) + chr(13) + chr(10)
    txt += "Oxygen Basic Port - 2025"
    MessageBox(hMainWnd, txt, "About Chatbot Danny", 0)
end sub

sub ResizeControls()
    RECT rc
    GetClientRect(hMainWnd, @rc)
    int w = rc.right - rc.left
    int h = rc.bottom - rc.top
    int margin = 10
    int btnW = 80, btnH = 40
    int inputH = 50
    int outputH = h - inputH - btnH - margin * 5
    
    MoveWindow(hOutputEdit, margin, margin, w - margin * 2, outputH, 1)
    MoveWindow(hInputEdit, margin, margin * 2 + outputH, w - btnW - margin * 3, inputH, 1)
    MoveWindow(hSendButton, w - btnW - margin, margin * 2 + outputH, btnW, inputH, 1)
    MoveWindow(hAboutButton, w - 60 - margin, h - btnH - margin, 60, btnH - 10, 1)
end sub

' ============================================================================
' WINDOW PROCEDURE
' ============================================================================

function WndProc(sys hwnd, wMsg, wParam, lParam) as sys callback
    select wMsg
        case WM_CREATE
            ' Create 20px font
            hFont = CreateFontA(-20, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, "Segoe UI")
            if hFont = 0 then hFont = GetStockObject(DEFAULT_GUI_FONT)
            
            hOutputEdit = CreateWindowEx(WS_EX_CLIENTEDGE, "EDIT", "",
                WS_CHILD or WS_VISIBLE or WS_VSCROLL or ES_MULTILINE or ES_AUTOVSCROLL or ES_READONLY,
                10, 10, 760, 400, hwnd, ID_OUTPUT, hInstance, 0)
            SendMessage(hOutputEdit, WM_SETFONT, hFont, 1)
            
            ' Single-line input so Enter submits
            hInputEdit = CreateWindowEx(WS_EX_CLIENTEDGE, "EDIT", "",
                WS_CHILD or WS_VISIBLE or ES_AUTOHSCROLL or WS_TABSTOP,
                10, 420, 670, 50, hwnd, ID_INPUT, hInstance, 0)
            SendMessage(hInputEdit, WM_SETFONT, hFont, 1)
            
            hSendButton = CreateWindowEx(0, "BUTTON", "Send",
                WS_CHILD or WS_VISIBLE or BS_DEFPUSHBUTTON or WS_TABSTOP,
                690, 420, 80, 50, hwnd, ID_SEND, hInstance, 0)
            SendMessage(hSendButton, WM_SETFONT, hFont, 1)
            
            hAboutButton = CreateWindowEx(0, "BUTTON", "About",
                WS_CHILD or WS_VISIBLE or BS_PUSHBUTTON,
                720, 480, 60, 30, hwnd, ID_ABOUT, hInstance, 0)
            SendMessage(hAboutButton, WM_SETFONT, hFont, 1)
            
            SetFocus(hInputEdit)
            
        case WM_SIZE
            ResizeControls()
            
        case WM_GETMINMAXINFO
            MINMAXINFO *mmi = lParam
            mmi.ptMinTrackSize.x = MIN_WIDTH
            mmi.ptMinTrackSize.y = MIN_HEIGHT
            
        case WM_COMMAND
            word wmId = loword(wParam)
            word wmEvent = hiword(wParam)
            if wmId = ID_SEND and wmEvent = BN_CLICKED then HandleSend()
            if wmId = ID_ABOUT and wmEvent = BN_CLICKED then ShowAbout()
            
        case WM_CLOSE
            DestroyWindow(hwnd)
            
        case WM_DESTROY
            PostQuitMessage(0)
            
        case else
            function = DefWindowProc(hwnd, wMsg, wParam, lParam)
            
    end select
end function

' ============================================================================
' MAIN PROGRAM
' ============================================================================

sub WinMain()
    hInstance = GetModuleHandle(0)
    LoadDatabase()
    
    WndClass wc
    MSG wm
    
    wc.style = CS_HREDRAW or CS_VREDRAW
    wc.lpfnWndProc = @WndProc
    wc.cbClsExtra = 0
    wc.cbWndExtra = 0
    wc.hInstance = hInstance
    wc.hIcon = LoadIcon(0, IDI_APPLICATION)
    wc.hCursor = LoadCursor(0, IDC_ARROW)
    wc.hbrBackground = COLOR_BTNFACE + 1
    wc.lpszMenuName = 0
    wc.lpszClassName = strptr "DannyChatbot"
    
    RegisterClass(@wc)
    
    ' Center window on screen
    int wwd = 800, wht = 600
    int wtx = (GetSystemMetrics(SM_CXSCREEN) - wwd) / 2
    int wty = (GetSystemMetrics(SM_CYSCREEN) - wht) / 2
    
    hMainWnd = CreateWindowEx(0, wc.lpszClassName, "Chatbot Danny",
        WS_OVERLAPPEDWINDOW,
        wtx, wty, wwd, wht,
        0, 0, hInstance, 0)
    
    if hMainWnd = 0 then
        mbox "Unable to create window"
        return
    end if
    
    ShowWindow(hMainWnd, SW_SHOW)
    UpdateWindow(hMainWnd)
    
    ' Welcome message
    AddToOutput("Danny: ", "Hello there, how are you doing today?")
    AddToOutput("", "")
    Speak("Hello there, how are you doing today?")
    
    sys bRet
    do while bRet := GetMessage(@wm, 0, 0, 0)
        if bRet = -1 then
            exit do
        else
            ' Check for Enter key in input edit
            if wm.message = WM_KEYDOWN and wm.wParam = VK_RETURN then
                if GetFocus() = hInputEdit then
                    HandleSend()
                    continue do
                end if
            end if
            TranslateMessage(@wm)
            DispatchMessage(@wm)
        end if
    loop
end sub

WinMain()
#2
General Discussion / Re: end of year is coming :)
Last post by CharlieJV - Dec 31, 2025, 04:00 PM
Good stuff.  Happy New Year !
#3
General Discussion / end of year is coming :)
Last post by mysoft - Dec 12, 2025, 08:03 PM
hello, people, how you guys are doing? i keep forgetting to moderate this forum, giving how much stuff i'm doing

but if you guys need something, just let me know :D
#4
FreeBasic / Re: Dancer Demo
Last post by mysoft - Aug 24, 2025, 04:10 PM
Quote from: __blackjack__ on Jul 23, 2025, 08:47 PMThere is an array out of bounds error with `Cor`.  Initialising this with -1 leads to `Cor` being 15 and then this value being used as index into the just 9 element long `CP_Cores` array.
ah yeah `Cor` is to be intiialized with 1 not -1, i was puzzled since i couldnt see it here, but turns out i guess i copy pasted the code before fixing that xD
#5
GWBasic / Re: Gw Basic Game - Russian Ro...
Last post by __blackjack__ - Aug 11, 2025, 11:24 AM
That's an interesting revolver: with *7* chambers!  I'm pretty sure that wasn't the intend, given line 50 that just "empties" 6 of the chambers and that traditionally most revolvers have 6 chambers.  So B must be initialised with 1 and the random number assigned later must be in the range 1 to 6, not 0 to 6.  Also it doesn't make sense to roll the dice 6 times instead of just one.

And then there is the fact that the cylinder doesn't advance to the next chamber when pulling the trigger.  And at the start of the game the cylinder isn't rolled. That doesn't make sense for Russian roulette.

In line 180 there is a USER$ printed that isn't defined anywhere, so that's the empty string and has no effect.

It doesn't make much sense to initialise variables to values that are not used anywhere in the program.

The answer for number of bullets isn't validated.

GOTOs to the very next line number are unnecessary.

The two "blocks" of code when loading the revolver with either 1 or 2 bullets repeats some code.  It would be much shorter to load one bullet and then just check if a second one is needed.  So instead of:

220 REM ONE BULLET IN THE REVOLVER
221 GUN(3)=1
222 GOTO 240

230 REM TWO BULLETS IN THE REVOLVER
231 GUN(3)=1: GUN(6)=1
232 GOTO 240

Just:

210 GUN(3)=1: IF BULLETS=2 THEN GUN(6)=1

There are *two* REMs saying ,,start of game loop" but just one actually *is* the start of the game loop.  Well sort of because the code does jump there only when player 2 was active.  This is one of the uses of GOTO that make code harder to follow than necessary.  Instead of GOTO somewhere at the end of each action for each player, it would be better to code the actions as subroutines that end with a RETURN and have one clear main loop with one GOTO that jumps back to the start.

Then comes all the duplicated code for player 1 and player 2.  As the names in USER1$ and USER2$ are never used together somewhere in the main loop, the easiest way to get rid of half the action code is to just put the player names into an array and swap the two each loop iteration and leave just the code for player 1.

10 REM RUSSIAN ROULETTE GAME IN GW BASIC
20 REM BY RON77 (SOLO88) 2023
30 REM INITIALIZE VARIABLES
40 RANDOMIZE TIMER: DIM GUN(6),USERS$(2)

60 REM INTRO
65 FOR I=1 TO 2: ON I GOSUB 1200,1300
70 S$="RUSSIAN ROULETTE": ROW=3: GOSUB 1000
80 S$="BY RON77 (SOLO88)": ROW=5: GOSUB 1000
90 WHILE INKEY$="": WEND: IF I=1 THEN BEEP
100 NEXT: GOSUB 1200

150 FOR I=1 TO 2: PRINT "PLAYER";I;"NAME: ";: INPUT "",USERS$(I): NEXT
170 CLS
180 PRINT "ONE OR TWO BULLETS IN THE REVOLVER?"
190 INPUT "ENTER 1 OR 2: ",BULLETS
200 IF BULLETS<1 OR BULLETS>2 THEN 190
210 GUN(3)=1: IF BULLETS=2 THEN GUN(6)=1
220 GOSUB 400

240 REM START OF GAME LOOP
255 GOSUB 1200: PRINT USERS$(1);" TURN"
260 PRINT "1. ROLL THE CYLINDER"
270 PRINT "2. PULL THE TRIGGER"
280 PRINT "3. QUIT"
290 INPUT "ENTER 1, 2, OR 3: ",CHOICE
295 IF CHOICE<1 OR CHOICE>3 THEN 290
300 ON CHOICE GOSUB 400,500,600
310 SWAP USERS$(1),USERS$(2): GOTO 240

400 REM ROLL THE CYLINDER
420 B=INT(RND*6)+1: GOSUB 5060: RETURN

500 REM PULL THE TRIGGER (ADVANCES THE CYLINDER)
510 B=B+1: IF B>6 THEN B=1
520 ON GUN(B)+1 GOTO 530,540
530 GOSUB 1200: S$="LIVE": GOTO 550
540 GOSUB 1300: S$="DIED": GOSUB 550: END
550 BEEP: S$=USERS$(1)+" YOU "+S$+"!": ROW=4: GOSUB 1000
560 T!=TIMER+3: WHILE TIMER<T!: WEND: RETURN

600 REM QUIT
610 GOSUB 1200: S$=USERS$(1)+" QUIT!": ROW=4: GOSUB 1000: END

1000 REM PRINT STRING CENTERED
1010 LOCATE ROW,(80-LEN(S$))\2: PRINT S$: RETURN

1200 REM SCREEN INIT
1210 COLOR 15,0: CLS: RETURN

1300 REM SCREEN RED COLOR
1310 COLOR 4,0: CLS: RETURN

5060 FOR I=1 TO 50
5070   J=RND(I)*10000: IF J>=37 THEN PLAY "mb": SOUND J,.5
5110 NEXT: RETURN

It's not necessary by the way to model the revolver as array with six elements when distributing the bullet(s) evenly into the chambers.  Then it is enough to keep track how many trigger pulls till a bullet is reached and the possible maximum of this value for rolling the cylinder.
#6
GWBasic / Re: GW Basic - Matrix Rain by ...
Last post by __blackjack__ - Aug 08, 2025, 05:31 PM
The POKEs put the characters and the colours to the screen. Even then it is unbearably slow on a 8086 IBM PC (or clone) clocked at ~10 Mhz.  Compiled with BASCOM it is just fast enough.

From CGA cards onwards there is a 80×25 character screen in colour.  The screen memory is at 0xB8000.  Every byte at an even address has the character value and the bytes at odd addresses have the foreground and background colour of the character.

Following is a small program that shows all 256 possible characters, waits for a key press, and the colours the displayed characters in all possible combinations:

10 DEFINT A-Z:DEF SEG=&HB800
20 CLS:FOR I=0 TO 15:FOR J=0 TO 15:POKE 160*I+J*2,I*16+J:NEXT:NEXT
30 WHILE INKEY$="":WEND
40 FOR I=0 TO 15:FOR J=0 TO 15:POKE 160*I+J*2+1,I*16+J:NEXT:NEXT
50 WHILE INKEY$="":WEND

The default setting of the video cards is to use the highest bit of the background colour as flag to blink the characters (in hardware), so the first 8 colours repeat as background colour, instead of having the 8 bright colours there.
#7
FreeBasic Game Dev / Re: Ski Slope by electricwalru...
Last post by __blackjack__ - Aug 07, 2025, 09:04 AM
There's a type in line 130: T1 instead of T!.

In line 200 there's the `;` missing at the end of the print.  This leads to printing the slope and the player every other line instead of printing both on every line.

Line 70 isn't the best way to translate the original because that doesn't wait for any key but for the enter key.  A loop with INKEY$ would be better.

Just like in the original the FOR loop printing single spaces can be replaced by LOCATE.

All variables without a type suffix can be declared as integer instead of floating point.

Somehow the COLORs from the FreeBASIC version was missing. Easy to add back because GW-BASIC the same COLOR command with the same color values.

It was custom to pack more than one statement into a line.  Yes that makes the code more dense and thus sometimes harder to read, on the other hand the code now fits onto the 80x24 lines visible on screen when listed in GW-BASIC.
10 DEFINT A-Z:RANDOMIZE TIMER:COLOR 2
20 PRINT"Ski Slope Challenge By electricwalrus (2022)":PRINT
30 PRINT"Use the arrow keys to move left or right down the slope":PRINT
40 PRINT"Press any key to begin!":WHILE INKEY$="":WEND
50 CLS:S=0:SX=40:PX=SX
60 PRINT"Get Ready!":T!=TIMER+5:WHILE TIMER<T!:WEND
70 ON INT(RND*2)+1 GOTO 80,100
80 IF SX>10 THEN SX=SX-1
90 GOTO 110
100 IF SX<70 THEN SX=SX+1
110 LOCATE 24,SX-9:COLOR 11:PRINT"*                    *";
120 K$=INKEY$:IF K$=CHR$(27) THEN END
130 IF K$=CHR$(0)+CHR$(75) THEN PX=PX-1:GOTO 150
140 IF K$=CHR$(0)+CHR$(77) THEN PX=PX+1
150 D=PX-SX:IF D<-8 OR D>6 THEN 190
160 LOCATE 24,PX:COLOR 10:PRINT"!!"
170 T!=TIMER+.3:WHILE TIMER<T!:WEND
180 S=S+1:GOTO 70
190 BEEP:T!=TIMER+1:WHILE TIMER<T!:WEND
200 CLS:COLOR 6:PRINT"You crashed on the ski-field":PRINT"Score:";S:PRINT
210 COLOR 15:PRINT"Try Again in 5 seconds":GOTO 50
#8
FreeBasic Tips & Tricks / Re: a function that prints who...
Last post by __blackjack__ - Aug 05, 2025, 07:00 PM
The ELSEIF test doesn't make much sense, the message is wrong because there wasn't even an attempt to read the data, and the file isn't closed properly in that case.

If empty files should lead to a message, then just check the length of BUFFER:
SUB PrintTextFile(filename AS STRING)
    DIM buffer AS STRING, handle AS LONG = FREEFILE
    CLS
    IF OPEN(filename FOR BINARY ACCESS READ AS #handle) THEN
        PRINT "File could not be opened!"
    ELSE
        buffer = SPACE(LOF(handle))
        IF LEN(buffer) = 0 THEN
            PRINT "File is empty."
        ELSE
            GET #handle, 0, buffer
        END IF
        CLOSE #handle
        PRINT buffer;  ' Prints nothing if file was empty.
    END IF
END SUB
#9
FreeBasic Tips & Tricks / Re: split word from string tex...
Last post by __blackjack__ - Aug 05, 2025, 06:38 PM
This doesn't need to be a function returning the length of the result array because that information can be queried from the result array with UBound().
#10
FreeBasic Tips & Tricks / Re: C Code Converted to FreeBA...
Last post by __blackjack__ - Aug 05, 2025, 06:04 PM
The standard C header is named `string.h`, not `String.h`.  This may compile on Windows, but not on any system that where file names are case sensitive.  Also the `cls` command is windows specific.  And the header files `string.h` and `stdbool.h` are not needed here.

The random number generator should only be seeded once, not each time before a random number is generated.  The same remarks from FreeBASIC's RANDOMIZE documentation apply here.

Like it is at the moment it would be even possible to get the same "random" number each time.  It depends on the value of `t` which is undefined.  It could be any garbage data that's currently on the stack.  Which includes the possibility of the same values at each call.  Or even zero bytes each time if the compiler chooses to zero fill the locals.  That's not guaranteed but also not forbidden either by the C standard.  Usually, and also in FreeBASIC, the current time is used to seed the random number generator.  That would be passing a NULL pointer to `time()` in C here.

I know it is ported, so this may come from the original, but line end characters should not be printed at the start of the line but at the end.  This would be strange in BASIC too, to start each and every PRINT with a CHR$(10) and end the command in a `;` instead of using the fact that PRINT by default outputs a line end character (sequence) if not suppressed via `;`.  The messages might be printed with `puts()` instead of `printf()` in `message()`.  `puts()` puts a line ending by itself, like PRINT in BASIC.

Those multiple `getchar()` seem to be necessary because the `scanf()` pattern doesn't account for trailing whitespace characters, including the new line character from the input (or an EOF condition).  After using `scanf()` one must at least clear the input buffer up the line end or EOF.  Then there still would be inputs that start with a valid number but have trailing garbage and the code would accept this by simply ignoring the trailing garbage.  BASICs INPUT is so much more convenient.

The user input is not checked wether it is in range 1 to 4.  The code just continues with the last value of `i`, even it is not from the current user input.

`days`, `health`, and `money` should be local to the `main()` function.  Code and normal declarations of variables outside a FUNCTION or SUB in FreeBASIC is in the `main()` function in C.

The outer main loop would better be a `while` loop because then it would still work as expected if the `health` value is defined as negative before the loop.

`opening()` doesn't really warrant its own function.

The first evaluation of `input` with an `if` for each of the four cases would be a `switch` in C instead (and a SELECT CASE in FreeBASIC):
        switch (input)
        {
            case 1: result = message(BEG1, BEG2); break;
            case 2: result = message(WORK1, WORK2); break;
            case 3: result = message(PHONE1, PHONE2); break;
            case 4: result = message(DRUGS1, DRUGS2); break;
        }
But the code in each case is so regular and depends on a number that could be used as an index, that it would be much shorter to put all the messages into a two dimensional array:
static const char *MESSAGES[4][2] = {
    {BEG1, BEG2}, {WORK1, WORK2}, {PHONE1, PHONE2}, {DRUGS1, DRUGS2}
};

    ...

        result = message(MESSAGES[input - 1][0], MESSAGES[input - 1][1]);
Or if `message()` is changed to accept a pointer to a two dimensional array instead of two arguments it is just:
        result = message(MESSAGES[input - 1]);
Which also would massively simplify `message()` because the random number there could be used as index into that argument.  And the return value is the random number plus one.  So there is no `if`/`else` neccessary anymore:
int message(const char *messages[2])
{
    int randon_number = rand() % 2;
    puts(messages[randon_number]);
    return randon_number + 1;
}

But why must this return 1 and 2 instead of 0 and 1?  Then it is so simple that the function can be inlined, because then random number *is* the result.

The evaluation of `input` and `ouput` has several branches with the same code (`break`) and all not branches not leaving the loop have the increment of `days` in common.

So we end up here:
#include <stdio.h>
#include <stdlib.h>
#include <time.h>

#define BEG1 "you have been begging all day for food and/or money but nothing"
#define BEG2 "you succeeded in getting some food and money from kind people"

#define WORK1 "you tried to find work but you where rejected everywhere you went"
#define WORK2 "you found work and after 2 weeks got your frist salery! you are off the streets! yay!"

#define PHONE1 "you phone family or friends you used to know but no one answers"
#define PHONE2 "you phone your parents - they come and get you and you are safe at home - you are off the streets - yay!"

#define DRUGS1 "you buy cheap alchohol and booze to try and forget your troubles, pass out and wake up at hospital"
#define DRUGS2 "you get OD from bad alchohol and drugs and you die on the streets - RIP :( GAME OVER"


static const char * const MESSAGES[][2] = {
    {BEG1, BEG2}, {WORK1, WORK2}, {PHONE1, PHONE2}, {DRUGS1, DRUGS2}
};


void skip_to_end_of_line(void)
{
    char ch;
    while ((ch = getchar()) != '\n' && ch != EOF);
}


int main()
{
    int days = 1, health = 50, money = 55;
    int i, input, result;
    
    srand((unsigned int) time(NULL));
    while (health >= 0)
    {
        printf(
            "\nyou are on the streets for %i days\n"
            "you have %i health, %i money\n",
            days, health, money
        );
        puts(
            "choose what to do:\n"
            "1. beg for money or food\n"
            "2. try to find work or a job\n"
            "3. phone someone for help\n"
            "4. buy some street drugs/alcohol to forget your troubles"
        );
        /*
        * TODO This still accepts input like "3some stuff thats not digits" by
        *      simply ignoring the part where the digits stop up to the end of
        *      the line.
        */
        for (;;)
        {
            i = scanf("%d", &input);
            skip_to_end_of_line();
            if (i == 1 && input >=1 && input <= 4)
            {
                break;
            }
            puts("Error! Wrong input. Try again.");
        }

        result = rand() % 2;
        puts(MESSAGES[input - 1][result]);

        if (result == 1)
        {
            if (input != 1)
            {
                break;
            }
            health += 25;
            money += 30;
        }
        else
        {
            health -= 5;
            money -= 10;
        }
        days++;
        skip_to_end_of_line();
    }
    skip_to_end_of_line();
    return 0;
}

And that ported back to FreeBASIC should not need the C runtime.  Porting a C program to FreeBASIC should not be 1:1 to end up with a C program just disguised as FreeBASIC but with an idiomatic FreeBASIC program.  This is true of almost all ports from language A to language B, unless really only the Syntax is different and not also the idioms.

Here is my attempt of a back port:
Randomize Timer

Dim Messages(..., ...) As Const String = { _
    {"you have been begging all day for food and/or money but nothing", _
     "you succeeded in getting some food and money from kind people"}, _
    {"you tried to find work but you where rejected everywhere you went", _
     "you found work and after 2 weeks got your frist salery! you are off the streets! yay!"}, _
    {"you phone family or friends you used to know but no one answers", _
     "you phone your parents - they come and get you and you are safe at home - you are off the streets - yay!"}, _
    {"you buy cheap alchohol and booze to try and forget your troubles, pass out and wake up at hospital", _
     "you get OD from bad alchohol and drugs and you die on the streets - RIP :( GAME OVER"}}

Dim days As Integer = 1, health As Integer = 50, money As Integer = 55
Dim answer As Integer, result As Integer

Do While health >= 0
    Print
    Print "you are on the streets for"; days; " days"
    Print "you have"; health; " health,"; money; " money"
    
    Print "choose what to do:"
    Print "1. beg for money or food"
    Print "2. try to find work or a job"
    Print "3. phone someone for help"
    Print "4. buy some street drugs/alcohol to forget your troubles"
    Do
        Input answer
        If answer >= 1 And answer <= 4 Then Exit Do
        Print "Error! Wrong input. Try again."
    Loop
    
    result = Int(Rnd * 2)
    Print Messages(answer - 1, result)
    
    If result = 1 Then
        If answer <> 1 Then Exit Do
        health += 25: money -= 30
    Else
        health -= 5: money -= 10
    End If
    days += 1
    GetKey
Loop
GetKey
Pages1 2 3 ... 10