Asm example 32 / 64 bit

[Frank Brübach]

Code Select Expand

' 32 bit and 64 bit example, go, 18-08-2024, fbruebach
' if you want to compile please use: menu: compile/run compiling 64-bit
'
take kons

''32 Bit version x86
pfun Mal(long x,y) as pro
    mov  eax, [x] 'take x to eax
    imul eax, [y] 'multiply with y
    mov [function], eax 'result 
end function

pro a = 45, b = 54
printl Mal(a, b)
p? Mal(a, b) '2430
printl
printl "push to continue"
wait

printl "test 64-bit"

'' for x86_64 architecture (64-Bit):
' 64 bit version
pfun Mal2(long x,y) as pro
    mov  rax, [x] ' take x to rax
    imul rax, [y] ' multiply with y
    mov [pfun], rax 'result
end function

pro a2 = 2123456789, b2 = 2987654321
printl Mal2(a2, b2) '1822673797
p? Mal2(a2, b2)
wait
' ends


[Frank Brübach]

Dim variable / suffixes new

Code Select Expand

' print alternatives and suffixes part one, all examples are running well
' july - august 2024, frank bruebach, halProment,22-08-2024
'
'
dim a as dword
p% a ' p% = dword
a=20
print a

string b
b="Hello tarzan"
p? b ' p?=print alternative

pstring c
c="Hello tarzan2"
p? c

p$ c ' p$=string alternative
c="Hello jane"
p? c

p$ d ' p$=string
d="Hello tarzan3"
p& d ' p&=print alternative

dim e as long
e=2024*365
print e '738760

p% e
e=2024*365
p? e '738760

' ends


[Frank Brübach]

Parser example

Code Select Expand

' -- new parser example, halPromentBasic, march-august2024, frank bruebach
' --
'
take kons
pindex 0

Dim token As String = ""
Dim tokenCount As Integer = 0
ReDim string tokens(tokenCount)


' Split() function
Function Split(string inputs, delimiter, string *tokens(redim) ) As Integer
    Dim token As String = ""
    Dim tokenCount As Integer = 0
    redim string tokens(100)
    int i
    For i = 1 To Len(inputs)
        If Mid(inputs, i, 1) = delimiter Then
            If token <> "" Then
                tokens(tokenCount) = token
                tokenCount += 1
                token = ""
            End If
        Else
            token += Mid(inputs, i, 1)
        End If
    Next
    If token <> "" Then
        ReDim string tokens(tokenCount)
        tokens(tokenCount) = token
    End If

    Return tokenCount
End Function


' IsNumeric() function
Function IsNumeric(string value ) As Integer
    Static string numericChars
    numericChars = "0123456789.-"
    If Len(value) = 0 Then Return False
    int i
    int dotCount = 0
    For i = 1 To Len(value)
        string c = Mid(value, i, 1)
        If InStr(numericChars, c) = 0 Then
            Return False
        ElseIf c = "." Then
            dotCount += 1
            If dotCount > 1 Then
                Return False
            End If
        End If
    Next
    Return True
End Function


' EvaluateExpression function
Function EvaluateExpression(string inputs) As Double
 
    Split(inputs," ", tokens())
    Dim total As Double = 0
    Dim currentNumber As Double = 0
    Dim operators As String = "+"
    int i
    For i = 0 To UBound(tokens)
        Dim token As String = tokens(i)

        If IsNumeric(token) Then
            currentNumber = Val(token)
            If operators = "+" Then
                total += currentNumber
            ElseIf operators = "-" Then
                total -= currentNumber
            ElseIf operators = "*" Then
                total *= currentNumber
            ElseIf operators = "/" Then
                If currentNumber <> 0 Then
                    total /= currentNumber
                Else
                    Print "Error: Division by zero"
                    Exit For
                End If
            End If
            operators = "+"
        Else
            operators = token
        End If
    Next

    Return total
End Function

' Test my code with different inputs
Dim inputs As String = "2 + 3 * 10" ' 50 result ok
Dim result As Double

result = EvaluateExpression(inputs)

' all tests are running fine here for calculations
' + - * /
' Test my code with different inputs
' Dim inputs As String = "2 + 3 * 10" ' 50 ok
' Dim inputs As String = "5 + 6 + 10" ' 21 ok
' Dim inputs As String = "8 * 5" ' 40 ok
' Dim inputs As String = "20 / 4 " ' 5 ok
' Dim inputs As String = "-20 10" ' -10 ok
' Dim inputs As String = "-10  20" ' ok
 Dim inputs As String = "30 -20" ' 10 ok


If result <> 0 Then
    Printl "The total is " + result ' result: 50 ok
Else
    Printl "Error: Invalid input"
End If

printl result

' Wait for a key press before closing the console
Printl "Press any key to continue..."

wait
' ends


[Frank Brübach]

Len Array Print alternatives

Code Select Expand

' len example and array, july-august2024, f. bruebach
' halProment
'
take kons ' kons = konsole

Dim ps As pstring
ps = "ABCD[2]"
MsgBox Str(Len(ps)) ' 7
printl Str(Len(ps)) ' 7

p$ ps2 ' p$ = string alternative
ps2 = "ABCDE[2]"
MsgBox Str(Len(ps2)) ' 8
p? Str(Len(ps2))   ' 8

Dim st as string
st = "HALPPROM[2]"
MsgBox Str(Len(st)) ' 11
printl Str(Len(st)) ' 11

wait


[Frank Brübach]

Load a Textfile and Unicode txt File
A songtext  and Chinese characters

Code Select Expand

' --> loadfile *.txt and unicode, april-august2024
' --> halProment, test version
'
' 1) -------- //
string stunic

loadfile "turnturnturn.txt",stunic ' go with string stunic

print stunic

' 2) -------- //
wstring stunic2

loadfile "chines.txt",stunic2 ' go

print stunic2


[Frank Brübach]

Macros Tests new

Code Select Expand

'' --> macro tests, june-august 2024
''
take kons

'--------------------------------- //print message = p?
macro test1(arg1, arg2 )
    p? arg1
    p? arg2
    if arg2 = ""
        p? " 2nd argument not passed"
    else
        p? arg2
    endif
end macro

test1( "1", "2" ) '122
test1( 5, 6 ) '566

'--------------------------------- console output //
macro test2(arg1, arg2 )
    printl arg1
    printl arg2
    if arg2 = ""
        printl " 2nd argument not passed"
    else
        printl arg2
    endif
end macro

test2( "1", "2" ) '122
test2( 5, 6 ) '566


 macro mult( v1,v2 )
 printl v1*v2 ' 8
 end macro

 mult(2,4)
 p? mult(2,4) ' 8

printl "ends"
wait


[Frank Brübach]

Parse example new

Code Select Expand

' new parse example halProment, april-august2024, frank bruebach
'
'
take kons
pindex 1

function Parse(bstring expression, delimiter as string= ",", int index ) as bstring
    int count = 1
    string temp = ""
    int d = 1
    int f = 0
    int i = 0
    string z ""
    do
        i = instr(d, expression, delimiter)
        if i > 0 then
            f = i
            if count = index then
                exit do
            end if
            count += 1
            f += Len(delimiter)
            d = f
        elseif count = index then
            f = Len(expression) + 1
        end if
    loop until i = 0
     return MID(expression,d, f-d)
         
end function

bstring a,b,c
a = parse("one,two,three", ,2) '' ok -> returns "two" 

b = parse("xyz", , 1)            ' ok -> returns "xyz"

c = parse("xx1x","x", 3)         ' ok -> returns "1"

Printl "'" + a + "'"
Printl "'" + b + "'"
Printl "'" + c + "'"

wait


[Frank Brübach]

Powerbasic Looks a Like example new 2

Code Select Expand

' --> only a test example for powerbasic looks alike, part two
' --> converted to halproment Basic, by frank bruebach, march-july2024
'
#COMPILE_EXE
#DIM_ALL
take poba

FUNCTION PBMAIN () AS LONG
LOCAL a,b,c AS INTEGER
a=2024 : b=365-210 ' circa around for 7 month
c=a*b
FUNCTION=c

MSGBOX 0,"our days counted on earth: " + STR$(c),"PowerBASIC" ,2
'313720 days
END FUNCTION



[Frank Brübach]

OpenGL: rotate triangle with Fonts

Code Select Expand

'
  $ sFile "rotating triangle with font.exe"
  $ title    "Rotating Triangle and rotating Font"
  pro width  =640
  pro height =480

  take proglscene

  sub Initialize(pro hWnd)
  '=======================
  end sub
  '
  sub Scene(pro hWnd)
  '==================
  '
  static single ang1,angi1=1
  '
  glClearColor 0.3, 0.3, 0.5, 0
  glClear GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT
  '
glLoadIdentity
  glpushMatrix
  pro i,j
 glLineWidth 2.0
  gltranslatef 0,-6.5,-6.0
  glBegin GL_LINES
  for i = -20 to 20 '-10 to 10
          for j = -20 to 20
            glVertex3i -20, 0,  j   
            glVertex3i  20, 0,  j   
            glVertex3i  i,  0, -20   
            glVertex3i  i,  0,  20   
          next
        next
  glEnd
 glPopMatrix
 

  glLoadIdentity
  '
  '
  gltranslatef    0.0, 0.0, -4.0
  glrotatef ang1, 0.0, 0.0,  1.0
  '
  glBegin GL_TRIANGLES
  glColor3f  1.0, 0.0, 0.0 : glVertex3f  0.0,  1.0, 0.0
  glColor3f  0.0, 1.0, 0.0 : glVertex3f  -1.0, -1.0, 0.0
  glColor3f  0.0, 0.0, 1.0 : glVertex3f  1.0, -1.0, 0.0
  glEnd
 
 '
  'UPDATE ROTATION ANGLES
  '----------------------
  glPushMatrix
  '
  glLoadIdentity
  static pro framecount
  sys x,y
  framecount++
  gltranslatef -.5,.25,-4.0
  glColor3f    .99,.50,.50
  glscalef    .2,.2,.01
  gprint "framecounter: "+str(framecount)
  '
  glpopmatrix

  glpushMatrix
  glscalef .2,.2,.01
  glRotatef 90.0,0,0,1
  gprint "Hello triangle"
  glPopMatrix

  ang1+=angi1
  if ang1>360 then ang1-=360
  '
  glLoadIdentity
  glpushMatrix
  gltranslatef    2.0, 0.0, -4.0
  glscalef    .2,.2,.01
  glRotatef 90.0,0,0,1
  gprint "Hello openGL"
  glPopMatrix
'
 end sub

  sub Release(sys hwnd)
  '====================
  end sub
  ' ends


[Frank Brübach]

Load gdip Image

Code Select Expand

  ' -- gdip load image from file, adepted gdiplus, oxygen
  ' -- halProment Basic, 25+27-07-2024, 18-08-2024,frank bruebach
  ' 
  take promplus
  take promgui
  take promImg

  '------------------------------
  sub GetImages(sys hwnd,sys hdc)
  '==============================

  long     hstatus
  long     pGraphics,pImage,pBitmap,pStream,pThumbnail
  wstring  strFileName
  long     nThumbnailWidth,nThumbnailHeight,nwidth,nheight
  '
  hStatus = GdipCreateFromHDC hdc, pGraphics
  '
  ' // Create an image and a thumbnail of the image.
  '
  strFileName = "genuss.jpg" ' take and load an image of your choice
  hStatus = GdipLoadImageFromFile strFileName, pImage
  hStatus = GdipGetImageThumbnail pImage,70, 50, pThumbnail, null, null
  '
  ' // Draw the original and the thumbnail images.
  '
  hStatus = GdipGetImageWidth pImage, nWidth
  hStatus = GdipGetImageHeight pImage, nHeight
  hStatus = GdipGetImageWidth pThumbnail, nThumbnailWidth
  hStatus = GdipGetImageHeight pThumbnail, nThumbnailHeight
  '
  '
  'DRAW IMAGES
  '
  hStatus = GdipDrawImageRect pGraphics, pThumbnail, 10, 10, nThumbnailWidth, nThumbnailHeight
  hStatus = GdipDrawImageRectI pGraphics, pImage, 10, 60, nWidth, nHeight
  ''
  ' // Cleanup
  '
  if pThumbnail
    GdipDisposeImage pThumbnail
  endif
  if pImage
     GdipDisposeImage pImage
  endif
  if pBitMap
    GdipDisposeImage pBitMap
  endif
  if pGraphics
    GdipDeleteGraphics pGraphics
  endif
  end sub

  long inst,hdc
 
  dim cmdline as asciiz ptr,inst as long
  &cmdline=GetCommandLine
  inst=GetModuleHandle 0


  '--------------------------------------------------------------------------------------------------------------
  Function WinMain(byval inst as long,byval prevInst as long,byval cmdline as asciiz, byval show as long) as long
  '==============================================================================================================


  long hr,hdlg,token
  GdiplusStartupInput StartupInput

  StartupInput.GdiplusVersion = 1
  hr=GdiplusStartup token, StartupInput, byval 0
  '
  if hr
    print "Error initializing GDIplus: " hex hr
    exit function
  end if


  WNDCLASS wc
  MSG      wm

  long hwnd, wwd, wht, wtx, wty, tax

  wc.style = CS_HREDRAW or CS_VREDRAW
  wc.lpfnWndProc = &WndProc
  wc.cbClsExtra =0
  wc.cbWndExtra =0   
  wc.hInstance =inst
  wc.hIcon=LoadIcon 0, IDI_APPLICATION
  wc.hCursor=LoadCursor 0,IDC_ARROW
  wc.hbrBackground = GetStockObject WHITE_BRUSH
  wc.lpszMenuName =0
  wc.lpszClassName =@"Demo"

  RegisterClass (&wc)
 
  Wwd = 600 : Wht = 440
  Tax = GetSystemMetrics SM_CXSCREEN
  Wtx = (Tax - Wwd) /2
  Tax = GetSystemMetrics SM_CYSCREEN
  Wty = (Tax - Wht) /2
 
  hwnd = CreateWindowEx 0,wc.lpszClassName,"Image Load Test",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0
  ShowWindow hwnd,SW_SHOW
  UpdateWindow hwnd
  '
  bool bRet
  '
  do while bRet := GetMessage (&wm, 0, 0, 0)
    if bRet = -1
      'show an error message
      exit while
    else
      TranslateMessage &wm
      DispatchMessage &wm
    end if
  wend

  GdiplusShutdown token
  End Function

  '--------------------------------------------------------------------------------------------------------------------------
  function WndProc (  byval hWnd as long,  byval wMsg as long, byval wParam as long,  byval lparam as long ) as long callback
  '==========================================================================================================================

    static as Long count=0, refreshes=0, hdc
    static as String txt
    static as PAINTSTRUCT Paintst
    RECT crect

    '==========
    select wMsg
    '==========
       
      '--------------
      case WM_CREATE
      '=============

      ''long hTimer = SetTimer (hWnd, IDC_TIMER, 100, &TimerProc)
      GetClientRect  hWnd,&cRect

      '--------------
      case WM_TIMER
      '=============

      '-------------- 
      case WM_DESTROY
      '===============
         
      'KillTimer(hWnd,ID_TIMER)
      PostQuitMessage 0
       
      '------------
      case WM_PAINT
      '============

      hDC=BeginPaint hWnd,&Paintst
      'GetClientRect  hWnd,&cRect
      'DrawText hDC,"Hello",-1,&cRect,0x25
      GetImages hWnd,hDC
      'refreshes+=1
      EndPaint hWnd,&Paintst
      ValidateRect hwnd,&crect
       
      '--------------  
      case WM_KEYDOWN
      '==============

      '============           
      Select wParam
      '============

    Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0 

        Case 80
          SaveClientImage hwnd
       End Select
       '
      '--------       
      case else
      '========
         
        function=DefWindowProc hWnd,wMsg,wParam,lParam
    end select

  end function

  WinMain inst,0,cmdline,SW_NORMAL
   ' ends


[Frank Brübach]

Three examples are still Missing Here they will follow soon :-)

Here you can find halProment Update August 2024 (Update 6)

[Frank Brübach]

Double Buffer gui example

Code Select Expand

    ' double buffering gui test, based on example for o2
    ' halProment Basic, 30-05-2024, 06-06-2024,21-07-2024
    '   
    take promgui
     
    MainWindow 550,450,WS_OVERLAPPEDWINDOW
    '-----------------------------------------------------------------------------
   
    % CUSTOM_ID    200
    % MARGIN        7
    % CELLSIZE      32
    % DARKCOLOR    RGB(0,80,20)
    % LIGHTCOLOR    RGB(221,190,0)
   
    type CustomData
        pro  hwnd
        pro  style
        pro  hbrLight
        pro  hbrDark
    end type
   
    '------------------------------------------------------------------------ // 
    function WndProc(sys hwnd, uint uMsg, pro wParam, lParam) as pro callback
        static pro hwndCustom
     
        select uMsg
   
            case WM_CREATE
              SetWindowText(hwnd, "Double Buffering Example2")
   
              CustomRegister()     
              hwndCustom = CreateWindowEx(0,CUSTOM_WC, null, WS_CHILD or WS_VISIBLE or 0,
                                    0, 0, 0, 0, hwnd, CUSTOM_ID, hInstance, null)
              if hwndCustom = 0 then mbox "Error: Cannot create hwndCustom"
         
            case WM_SIZE
              if wParam = SIZE_MAXIMIZED or wParam = SIZE_RESTORED then
                word cx = loword(lParam)
                word cy = hiword(lParam)
                SetWindowPos(hwndCustom, null, MARGIN, MARGIN,
                            (cx-2*MARGIN), (cy-2*MARGIN), SWP_NOZORDER)
              end if
   
            case WM_CLOSE
              DestroyWindow(hwnd)
   
            case WM_DESTROY
              PostQuitMessage(0)
                     
            case else
              return DefWindowProc(hwnd, uMsg, wParam, lParam)
   
        end select
     
    end function

    sub CustomPaint(CustomData *pData, pro hDC, RECT *rcDirty, bool bErase)
        pro x, y
        RECT r
        pro hBrush
     
     
        ' Note we paint only the cells overlaping with the dirty rectangle.
        for y = (rcDirty.top / CELLSIZE) to (rcDirty.bottom / CELLSIZE)
            for x = (rcDirty.left / CELLSIZE) to (rcDirty.right / CELLSIZE)
                if mod((x+y),2)=0 then hBrush=pData.hbrLight else hBrush=pData.hbrDark
                SetRect(r, x * CELLSIZE, y * CELLSIZE, (x+1) * CELLSIZE, (y+1) * CELLSIZE)
                FillRect(hDC, r, hBrush)
            next x
        next y
    end sub
   
    sub CustomDoubleBuffer(CustomData *pData, PAINTSTRUCT *pPaintStruct)       
        int cx = pPaintStruct.rcPaint.right - pPaintStruct.rcPaint.left
        int cy = pPaintStruct.rcPaint.bottom - pPaintStruct.rcPaint.top
   
        pro hMemDC,hBmp,hOldBmp
        POINT ptOldOrigin
   
   
        ' Create new bitmap-back device context, large as the dirty rectangle.
        hMemDC = CreateCompatibleDC(pPaintStruct.hdc)
        hBmp = CreateCompatibleBitmap(pPaintStruct.hdc, cx, cy)
        hOldBmp = SelectObject(hMemDC, hBmp)
   
        ' Do the painting into the memory bitmap.
        OffsetViewportOrgEx(hMemDC, -(pPaintStruct.rcPaint.left),
                            -(pPaintStruct.rcPaint.top), ptOldOrigin)
        CustomPaint(pData, hMemDC, pPaintStruct.rcPaint, true)
        SetViewportOrgEx(hMemDC, ptOldOrigin.x, ptOldOrigin.y, null)
   
        ' Blit the bitmap into the screen. This is really fast operation and altough
        ' the CustomPaint() can be complex and slow there will be no flicker any more.
        BitBlt(pPaintStruct.hdc, pPaintStruct.rcPaint.left, pPaintStruct.rcPaint.top,
              cx, cy, hMemDC, 0, 0, SRCCOPY)
   
        ' Clean up.
        SelectObject(hMemDC, hOldBmp)
        DeleteObject(hBmp)
        DeleteDC(hMemDC)
    end sub
   
    function CustomProc(pro hwnd, uint uMsg, sys wParam, lParam) as pro callback
   
        CustomData *pData              'Pointer to CustomData structure
   
        if uMsg != WM_CREATE then
          &pData=GetWindowLongPtr(hwnd, 0)
        end if
   
        select case uMsg
            case WM_NCCREATE
                pro pdat=getmemory sizeof(CustomData)
                if pDat then
                  SetWindowLongPtr(hwnd, 0, pdat)  'Store the pointer for later use
                else
                    return false
                end if
   
                &pData=pdat                        'address of pData stucture
   
                pData.hwnd = hwnd
   
                CREATESTRUCT cstr at lParam
                pData.style=cstr.style
             
                pData.hbrDark = CreateSolidBrush(DARKCOLOR)
                pData.hbrLight = CreateSolidBrush(LIGHTCOLOR)         
                return true
   
            case WM_ERASEBKGND
                return false  ' Defer erasing into WM_PAINT
   
            case WM_PAINT
                PAINTSTRUCT ps
                BeginPaint(hwnd, ps)
             
                ' We let application to choose whether to use double buffering
                ' or not by using the style XXS_DOUBLEBUFFER.
                if(pData.style and XXS_DOUBLEBUFFER) then                     
                    CustomDoubleBuffer(pData, ps)
                else         
                    CustomPaint(pData, ps.hdc, ps.rcPaint, ps.fErase)
                end if
                EndPaint(hwnd, ps)
                return 0
   
            case WM_PRINTCLIENT
                RECT rc
                GetClientRect(hwnd, rc)
                CustomPaint(pData, wParam, rc, true)
                return 0
   
            case WM_STYLECHANGED
                if wParam = GWL_STYLE then                     
                    pData.style = lParam
                end if
                break
   
            case WM_NCDESTROY   
                if &pData then
                    DeleteObject(pData.hbrDark)
                    DeleteObject(pData.hbrLight)
                    freememory(&pData)
                end if
                CustomUnregister()
                return 0
   
        end select
     
        return DefWindowProc(hwnd, uMsg, wParam, lParam)
    end function
    ' ends


[Frank Brübach]

Listview example with Buttons and combobox

Code Select Expand

'' testfile for Listview & Colored Button based on example by charles pegge
'' translated to halProment Basic 2024, by frank bruebach, march-july2024
'' 25-07-2024, 28-07-2024.
''
$ sFile "ListviewColoredButtonCombobox.exe"
uses promgui

'--------------------------------------- //
% IDB_BUTTON  1000
sys hWndStdButton
% IDC_OWNERDRAWN  1001
sys hWndClrButton
% IDB_EDIT  2000
sys hWndStdEdit
% IDB_LIST  2001
sys hWndStdList
% IDC_COMBO  2002
sys hWndStdCombo

 %CBS_SORT = 256i32
 %CBS_DROPDOWN= 2i32
 %CBS_SIMPLE= dword 0x0001

MainWindow 640, 620 , WS_OVERLAPPEDWINDOW
'void Combobox_Addstring(hwndctl,lpsz)
 
function combobox_addstring(byval hwndcombo as dword , byval ltext as bstring ) as string
function=sendMessage(hwndcombo,CB_ADDSTRING, 0, ltext ) 'strptr(ltext)
end function
 
sub combobox_setcursel(byval hwndcombo as dword , byval index as long )
sendMessage(hwndcombo,CB_SETCURSEL, index,0 )
end sub

function WndProc(sys hwnd, uint MainMsg, sys wParam, lParam) as sys callback
    int i,j,countrow,countcol

    select case MainMsg

        case WM_CREATE
            SetWindowText(hwnd, "Listview Editbox Combobox Example Proment")

            sys hInstance = GetWindowLongPtr(hWnd, GWL_HINSTANCE)

            int Lstyle = WS_CHILD or WS_VISIBLE or LVS_REPORT or WS_TABSTOP or LVS_SHOWSELALWAYS or LVS_SINGLESEL or WS_TABSTOP or _
            LVS_REPORT or LVS_SHOWSELALWAYS       
            int LStyleEx = WS_EX_CLIENTEDGE
   
            hWndStdButton = CreateWindowEx(
            0,
            "BUTTON",
            "Standard Button",
            WS_VISIBLE or WS_CHILD,
            10,  10,
            120, 24,
            hWnd,
            IDB_BUTTON,
            hInstance,
            NULL)

            hWndClrButton = CreateWindowEx(
            0,
            "BUTTON",
            NULL,
            WS_CHILD or BS_OWNERDRAW,
            10,  40,
            120, 24,
            hWnd,
            IDC_OWNERDRAWN,
            GetWindowLongPtr(hWnd, GWL_HINSTANCE),
            NULL)

            hWndStdEdit = CreateWindowEx(
            0,
            "EDIT",
            "", ''NULL,
            WS_CHILD or WS_VISIBLE or WS_BORDER or ES_AUTOHSCROLL or WS_HSCROLL or WS_VSCROLL OR ES_MULTILINE OR ES_WANTRETURN,
            10,  100,
            120, 124,
            hWnd,
            IDB_EDIT,
            GetWindowLongPtr(hWnd, GWL_HINSTANCE),
            NULL)
                        ' Set an initial text for the textbox
            SendMessage(hwndStdEdit, WM_SETTEXT, 0, StrPtr("input text here "))
            '
            if not hWndClrButton then
                MessageBox(NULL, "Button Creation Failed.", "Error", MB_OK or MB_ICONERROR)
                return 0
            end if
            ShowWindow(hWndClrButton, SW_SHOW)

            '----------------------> combobox , there are three ways to fill it ------------------- //         
           
            hWndStdCombo = CreateWindowEx(
            0,
            "Combobox",
            "", ''NULL,
            WS_CHILD or WS_VISIBLE or WS_BORDER or ES_AUTOHSCROLL or WS_HSCROLL or WS_VSCROLL _
            OR ES_MULTILINE OR WS_TABSTOP OR CBS_SIMPLE OR CBS_SORT, ''_ '%CBS_DROPDOWNLIST,
            10,  230,
            120, 124,
            hWnd,
            IDC_COMBO,
            GetWindowLongPtr(hWnd, GWL_HINSTANCE),
            NULL)
            sys List1=GetDlgItem(hwnd, IDC_Combo)
 
            ' // Fill the control with some data
            DIM wszText as string
            int i
            FOR i = 1 TO 9
            wszText = "Marvel " + RIGHT("00" + STR(i), 2)
            ComboBox_AddString(hWndStdCombo, wszText) '@wszText
           
            NEXT
            ComboBox_SetCursel(hWndStdCombo, 0)
           
          '--------------------------------> // listview ------------------------------ //
            '
            hWndStdList = CreateWindowEx(WS_EX_CLIENTEDGE, "SysListView32", "",lStyle,
            140,  10,
            420, 460,
            hWnd,
            IDB_LIST,
            GetWindowLongPtr(hWnd, GWL_HINSTANCE),
            NULL)
            if hWndStdList=null then print "Error: Cannot create Listview"
            SendMessage(hWndStdList, LVM_SETEXTENDEDLISTVIEWSTYLE, 0,  LVS_EX_FULLROWSELECT or LVS_EX_GRIDLINES)
              CountRow=26  : CountCol=6 : LV_COLUMN lvc
       
      for i = 0 to CountCol
          Listview_Add_column (hWnd,IDB_LIST, i, "Marvel " + str(i), 110, 0)     
      next i
   
      for i = 1 to CountRow
          Listview_Add_item (hWnd,IDB_LIST, i, 0, "Column 0 Row " + str(i) + " Col 1")
          for j = 1 to CountCol
            Listview_Set_Item (hWnd,IDB_LIST, i, j, "IronMan " + str(i) + " Thor " + str(j))
          next j
      next i
     
      '--------------------------------------------- listview ends ---------------------- //     
        case WM_DRAWITEM
            select case wParam
                case IDC_OWNERDRAWN

                    'get the pointer to the item-drawing info
                    DRAWITEMSTRUCT *ptDrawItem
                    &ptDrawItem=lParam
                    ' alternative
                    'DRAWITEMSTRUCT ptDrawItem at lParam                 

                    SIZE siz
                    string text
                    text = "Color Button"
                    GetTextExtentPoint32(ptDrawItem.hDC, text, len(text), &siz)
                    SetTextColor(ptDrawItem.hDC, WHITE)
                    SetBkColor(ptDrawItem.hDC, RED)

                    ExtTextOut(ptDrawItem.hDC,
                    ((ptDrawItem.rcItem.right - ptDrawItem.rcItem.left) - siz.cx) \ 2,
                    ((ptDrawItem.rcItem.bottom - ptDrawItem.rcItem.top) - siz.cy) \ 2,
                    ETO_OPAQUE or ETO_CLIPPED, &ptDrawItem.rcItem, text, len(text), NULL)

                    uint edge
                    if ptDrawItem.itemState and ODS_SELECTED then
                      edge = EDGE_SUNKEN
                    else
                      edge = EDGE_RAISED
                    end if 
                    DrawEdge(ptDrawItem.hDC, &ptDrawItem.rcItem,
                    edge, BF_RECT)             
            end select

        case WM_COMMAND
            select case loword(wParam)
                case IDB_BUTTON
                    select case hiword(wParam)
                        case BN_CLICKED
                            MessageBox(NULL, "Selected Standard Button", "Standard Button", MB_OK or MB_ICONINFORMATION)
                    end select
                case IDC_OWNERDRAWN
                    select case hiword(wParam)
                        case BN_CLICKED
                            MessageBox(NULL, "Selected Color Button", "Color Button", MB_OK or MB_ICONINFORMATION)
                    end select
            end select

        case WM_CLOSE
            DestroyWindow(hWnd)

        case WM_DESTROY
            PostQuitMessage(0)

        case else
            return DefWindowProc(hWnd, MainMsg, wParam, lParam)
    end select

    return 0
end function
' ends


[Frank Brübach]

Quad rotate Pyramide OpenGL Scene

Code Select Expand

  ' --> openGL scene HalPromentBasic, based on a part of o2 example by charles pegge
  ' --> march,july,august2024 test example for openGL scene by frank bruebach
  '
  $ sFile  "openGLscene2.exe"
  $ title     "Rotating Quad Pyramid Scene"
  % ExplicitMain '

  take proglscene
  take opgl2\proshape
  take opgl2\protex
  take opgl2\promat
  take opgl2\propart

  pindex 1
  pro   GdiplusToken
  float ang1
  float ma[16]
  float li[16]
  pro   cube,sphere
  Cloud cloud1

  sub RenderPlane(float x,y,z,sc,tex,u,v) ' pro
  =======================================
  glBindTexture GL_TEXTURE_2D,tex
  glPushMatrix
  gltranslatef x,y,z
  glscalef sc,1,sc
  glBegin GL_QUADS
  glTexCoord2f 0.0,0.0 : glVertex3f -1.0,0,-1.0
  glTexCoord2f u  ,0.0 : glVertex3f  1.0,0,-1.0
  glTexCoord2f u  ,v   : glVertex3f  1.0,0, 1.0
  glTexCoord2f 0.0,v   : glVertex3f -1.0,0, 1.0   
  glend
  glPopMatrix
  end sub

  sub initialize(pro hWnd)
  '=======================
  end sub
  '

  sub scene(pro hWnd)
  '==================
  '
  static single s1,s2,s3,s4,ang1,angi1=1
  single rtri, rquad
 
  sphere=CompileList : Spheric 1,1,6 : glEndList
  '
  glLoadIdentity
  glClear GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT
  glClearColor 0.5, 0, 0, 0
 
   glShadeModel GL_SMOOTH                         '' Enable Smooth Shading
   'glClearColor 0.0, 0.0, 0.0, 0.5               '' Black Background
    glClearDepth 1.0                               '' Depth Buffer Setup
    glEnable GL_DEPTH_TEST                         '' Enables Depth Testing
    glDepthFunc GL_LEQUAL                          '' The Type Of Depth Testing To Do
    glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST    '' Really Nice Perspective Calculations

   glEnable GL_LIGHTING
  '
  pro t1=texn[10]
  pro t2=texn[11]
  '
  '--> SPHERES
  glPushMatrix
  pindex 1
  glTranslatef -20.,10.,-60.0
  Material Red
  glScalef      6.,6.,6.
  glCallList sphere
  Material White
  glPopMatrix
  glPushMatrix
  glTranslatef 2.5,-1.0,-6.0
  glScalef      .5,.5,.5
  glCallList sphere
  glPopMatrix
  '
  glEnable GL_TEXTURE_2D
  '
  'RenderCube   2.5,-2.0,-6.0, 0.5,t1
  RenderPlane  0.0,-2.0,-16.0,16.0,t2,8,8
  '
  glDisable GL_TEXTURE_2D
  glDisable GL_LIGHTING
  '
  s1=.2    'x y
  s2=-1    'z
  s3=0.5   'color
  s4=s3*.2 'color
  '
  gltranslatef 0,0,-2
  glrotatef ang1, 0,0,1
  '
  glbegin GL_QUADS
  glcolor4f   00,  s3,  s3, 1 : glvertex3f -s1, -s1,  s2
  glcolor4f   s3,  s3,  00, 1 : glvertex3f  s1, -s1,  s2
  glcolor4f   s4,   0,  s3, 1 : glvertex3f  s1,  s1,  s2
  glcolor4f   s4,   0,  s3, 1 : glvertex3f -s1,  s1,  s2
  glend

         glLoadIdentity                                         
           glTranslatef 1.5, 0.0, -6.0                     
           glRotatef ang1,1.0, 1.0, 1.0 'rquad             
          
           glBegin GL_QUADS                                
            glColor3f 0.0, 1.0, 0.0                         
            glVertex3f 1.0, 1.0, -1.0                      
            glVertex3f -1.0, 1.0, -1.0                     
            glVertex3f -1.0, 1.0, 1.0                           
            glVertex3f 1.0, 1.0, 1.0                            
           
            glColor3f 1.0, 0.5, 0.0                             
            glVertex3f 1.0, -1.0, 1.0                           
            glVertex3f -1.0, -1.0, 1.0                          
            glVertex3f -1.0, -1.0, -1.0                         
            glVertex3f 1.0, -1.0, -1.0                          
           
            glColor3f 1.0, 0.0, 0.0                             
            glVertex3f 1.0, 1.0, 1.0                            
            glVertex3f -1.0, 1.0, 1.0                           
            glVertex3f -1.0, -1.0, 1.0                          
            glVertex3f 1.0, -1.0, 1.0                           
           
            glColor3f 1.0, 1.0, 0.0                             
            glVertex3f 1.0, -1.0, -1.0                          
            glVertex3f -1.0, -1.0, -1.0                         
            glVertex3f -1.0, 1.0, -1.0                          
            glVertex3f 1.0, 1.0, -1.0                           
           
            glColor3f 0.0, 0.0, 1.0                             
            glVertex3f -1.0, 1.0, 1.0                           
            glVertex3f -1.0, 1.0, -1.0                          
            glVertex3f -1.0, -1.0, -1.0                         
            glVertex3f -1.0, -1.0, 1.0                          
           
            glColor3f 1.0, 0.0, 1.0                             
            glVertex3f 1.0, 1.0, -1.0                           
            glVertex3f 1.0, 1.0, 1.0                            
            glVertex3f 1.0, -1.0, 1.0                           
            glVertex3f 1.0, -1.0, -1.0                          
           glEnd                                                  

      glLoadIdentity
           glTranslatef -1.5, 0.0, -6.0
          glRotatef ang1,0.0, 1.0, 0.0                            
      glBegin GL_TRIANGLES                                   
       
            glColor3f 1.0, 0.0, 0.0                            
            glVertex3f 0.0, 1.0, 0.0                           
            glColor3f 0.0, 1.0, 0.0                            
            glVertex3f -1.0, -1.0, 1.0                         
            glColor3f   0.0, 0.0, 1.0                          
            glVertex3f 1.0, -1.0, 1.0                           
       
            glColor3f 1.0, 0.0, 0.0                             
            glVertex3f 0.0, 1.0, 0.0                            
            glColor3f 0.0, 0.0, 1.0                             
            glVertex3f 1.0, -1.0, 1.0                           
            glColor3f 0.0, 1.0, 0.0                             
            glVertex3f 1.0, -1.0, -1.0                          
       
            glColor3f 1.0, 0.0, 0.0                             
            glVertex3f 0.0, 1.0, 0.0                            
            glColor3f 0.0, 1.0, 0.0                             
            glVertex3f 1.0, -1.0, -1.0                          
            glColor3f 0.0, 0.0, 1.0                             
            glVertex3f -1.0, -1.0, -1.0                         
       
            glColor3f 1.0, 0.0, 0.0                             
            glVertex3f 0.0, 1.0, 0.0                            
            glColor3f 0.0, 0.0, 1.0                             
            glVertex3f -1.0, -1.0, -1.0                         
            glColor3f 0.0, 1.0, 0.0                             
            glVertex3f -1.0, -1.0, 1.0                          
        glEnd                                                  

  ang1+=angi1
  if ang1>360 then ang1-=360
  '
  end sub

  sub Release(sys hwnd)
  '====================
  end sub
  '------------------------------------------- //
  MainWindow width,height,WS_OVERLAPPEDWINDOW
  ' ends


[Frank Brübach]

Last Not least.. I have forgotten my Mandelbrot example (SDK) Modus

Code Select Expand

  ' -- halProment: mandelbrot example, julia rings, winmain() sdk style
  ' -- translation from freebasic code snippets, frank bruebach, 21-02-2024, 25-07-2024
  '
  $ sfile "testMandelbrot.exe"
  take promgui
 
  'const ID_TIMER = 1
  %ID_TIMER = 100
 
  dim as integer maxIterations = 1000
  dim as double xMin = -2.0, xMax = 1.0, yMin = -1.5, yMax = 1.5
  dim as double zoomFactor = 1.0

  dim cmdline as asciiz ptr, inst as pro
  @cmdline=GetCommandLine
  inst=GetModuleHandle 0

DECLARE FUNCTION SetPixel lib "GDI32.DLL" ALIAS "SetPixel" ( _
  BYVAL hdc AS DWORD _                               
 , BYVAL x AS LONG _                                   
 , BYVAL y AS LONG _                                   
 , BYVAL color AS DWORD _                             
 ) AS DWORD                                           

DECLARE FUNCTION SetPixelV lib "GDI32.DLL" alias "SetPixelV" ( _
  BYVAL hdc AS DWORD _                               
 , BYVAL x AS LONG _                                   
 , BYVAL y AS LONG _                                   
 , BYVAL color AS DWORD _                             
 ) AS LONG                                             

macro RGB(r,g,b) {r+(g<<8)+(b<<16)}
typedef dword COLORREF ' R G B bytes

function RGB(long red,green,blue) as long
  Pro color
  color = red
  color = color + green*256
  color = color + blue*65536
  return color
end function

function mandelbrot(cReal as double, cImaginary as double, maxIterations as integer) as integer
    dim as double zReal = 0.0, zImaginary = 0.0
    dim as double temp
    dim as integer iteration = 0

    while iteration < maxIterations
        temp = zReal * zReal - zImaginary * zImaginary + cReal
        zImaginary = 2.0 * zReal * zImaginary + cImaginary
        zReal = temp
        iteration += 1

        if (zReal * zReal + zImaginary * zImaginary) > 4.0 then
            return iteration
        end if
    wend
    return maxIterations
end function

function juliaRing(cReal as double, cImaginary as double, zReal as double, zImaginary as double, maxIterations as integer) as integer
    dim as double temp
    dim as integer iteration = 0

    while iteration < maxIterations
        temp = zReal * zReal - zImaginary * zImaginary + cReal
        zImaginary = 2.0 * zReal * zImaginary + cImaginary
        zReal = temp
        iteration += 1

        if (abs(zReal) + abs(zImaginary)) > 2.0 then
            return iteration
        end if
    wend
    return maxIterations
end function

sub drawMandelbrotWithJuliaRing(hdc as sys, widths as integer, height as integer, xMin as double, xMax as double, yMin as double, yMax as double, maxIterations as integer)
    dim as double x, y, cReal, cImaginary
    dim as integer colors, iteration

    for x = 0 to widths - 1
        for y = 0 to height - 1
            cReal = xMin + (xMax - xMin) * x / widths
            cImaginary = yMin + (yMax - yMin) * y / height
            iteration = mandelbrot(cReal, cImaginary, maxIterations)
            ' I added here a Julia Ring
            iteration = juliaRing(-0.8, 0.156, cReal, cImaginary, maxIterations)

            colors = RGB(iteration * 8, iteration * 16, iteration * 32) 'here you can change a lot of things even rnd()
            SetPixelV(hdc, x, y, colors)
        next y
    next x
end sub

  '--------------------------------------------------------------------
  Function WinMain(pro inst, prevInst, asciiz*cmdline, pro show) as pro
  '====================================================================
  WndClass wc
  MSG      wm

  pro hwnd, wwd, wht, wtx, wty, tax
  with wc
  .style = CS_HREDRAW or CS_VREDRAW
  .lpfnWndProc = @WndProc
  .cbClsExtra =0
  .cbWndExtra =0   
  .hInstance =inst
  .hIcon=LoadIcon 0, IDI_APPLICATION
  .hCursor=LoadCursor 0,IDC_ARROW
  .hbrBackground = GetStockObject WHITE_BRUSH
  .lpszMenuName =null
  .lpszClassName = strptr "Demo"
  end with
  RegisterClass (@wc)
 
  Wwd = 900 : Wht = 600
  Tax = GetSystemMetrics SM_CXSCREEN
  Wtx = (Tax - Wwd) /2
  Tax = GetSystemMetrics SM_CYSCREEN
  Wty = (Tax - Wht) /2
 
  hwnd = CreateWindowEx 0,wc.lpszClassName,"Mandelbrot JuliaRing SDK Window",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0
  ShowWindow hwnd,SW_SHOW
  UpdateWindow hwnd
  '
  pro bRet
  '
  do while bRet := GetMessage (@wm, 0, 0, 0)
    if bRet = -1 then
      'show an error message
    else
      TranslateMessage @wm
      DispatchMessage @wm
    end if
  wend
  End Function

  dim as rect crect
  '------------------------------------------------------------------ //
  function WndProc ( pro hWnd, wMsg, wParam, lparam ) as pro callback
    static as pro hdc
    static as String txt
    static as PaintStruct Paintst
    static as pro initialized = false
   
    select wMsg       
      case WM_CREATE
            sys hdc = GetDC(hwnd)
            GetClientRect  (hWnd,cRect)
            ' Set up a timer for animation (optional)
            SetTimer(hwnd, ID_TIMER, 500, null) '50, NULL)
            initialized = true
            ReleaseDC(hwnd, hdc)
     
      case WM_DESTROY

            ReleaseDC(hwnd, hdc)
            KillTimer(hwnd, ID_TIMER)
            PostQuitMessage(0)
 
      case WM_DESTROY
         
      PostQuitMessage 0
       
      case WM_PAINT
     
      GetClientRect  hWnd,cRect
      hDC=BeginPaint hWnd,Paintst
      pro p
      if initialized then
          p=drawMandelbrotWithJuliaRing(hdc, 900, 700, -2.0, 1.0, -1.5, 1.5, 200)
      end if
      validateRect(hwnd, null)

      EndPaint hWnd,Paintst
     
      case WM_TIMER 
      case WM_KEYDOWN                 
      Select wParam
     
    Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0   
      End Select     
      case else               
        function=DefWindowProc hWnd,wMsg,wParam,lParam
    end select
  end function

 WinMain inst,0,cmdline,SW_NORMAL
 ' ends