Sorry your browser is not supported!

select function$
    case "MyFunction"
	Call Function Ptr MyPtr, intval(arg1$), arg2, val(arg3$)
    endcase
    case "AnotherFunction"
	Call Function Ptr MyPtr, val(arg3$), intval(arg1$), arg2
    endcase
endselect

sync on
sync rate 0
sync sleep 1

ExtractCommandLine()
if array count(ARGV()) < 0
    exit prompt "No command provided in arguments", null$()
    end
endif

FnPtr = get ptr to function( "Cmd_" + ARGV(0) )
if FnPtr
    call function ptr FnPtr
    sync : sync
    wait key
else
    exit prompt "Unknown command: " + ARGV(0), null$()
    end
endif
end


function Cmd_Circle()
    local x as integer
    local y as integer
    local r as integer
    local Filled as integer = 0
    local ArgsCnt as integer
    
    ArgsCnt = ValidateArgs(3, 4, "Circle", "Circle: x , y , radius [, filled]")
    x = intval(ARGV(1))
    y = intval(ARGV(2))
    r = intval(ARGV(3))
    if ArgsCnt >= 4 then Filled = intval(ARGV(4))
    
    if Filled
        fill circle x, y, r
    else
        circle x, y, r
    endif
endfunction


function Cmd_Box()
    local x1 as integer
    local y1 as integer
    local x2 as integer
    local y2 as integer
    local Filled as integer = 0
    local ArgsCnt as integer
    
    ArgsCnt = ValidateArgs(4, 5, "Box", "Box: x1 , y1 , x2 , y2 , [, filled]")
    x1 = intval(ARGV(1))
    y1 = intval(ARGV(2))
    x2 = intval(ARGV(3))
    y2 = intval(ARGV(4))
    if ArgsCnt >= 5 then Filled = intval(ARGV(5))
    
    if Filled
        box x1, y1, x2, y2
    else
        box outline x1, y1, x2, y2
    endif
endfunction


function ValidateArgs(MinArgs as integer, MaxArgs as integer, Cmd as string, Usage as string)
    local Cnt as integer
    Cnt = array count( ARGV() )
    if Cnt < MinArgs or Cnt > MaxArgs
        exit prompt Usage, Cmd
        end
    endif
endfunction Cnt




global dim ARGV() as string

function ExtractCommandLine()
   local CmdLine as string
   local Pos as integer

   global dim ARGV() as string

   CmdLine = cl$()

   ` While there is still something in the cmdline left to look at,
   while CmdLine <> ""
      ` Increase the size of the ARGV array - at this point there WILL be something to go there.
      array insert at bottom ARGV()

      if fast left$(CmdLine, 1) = chr$(34)
         ` Cmdline starts with quote, so search for the next quote, and that's the argument.
         Pos = instr(CmdLine, chr$(34), 2)
         ARGV() = mid$(CmdLine, 2, Pos - 2)
         CmdLine = mid$(CmdLine, Pos + 2, 0)
      else
         ` Cmdline is not quoted, so search for the next space (if there is one) and that's the argument
         Pos = instr(CmdLine, " ")
         if Pos > 0
            ARGV() = fast left$(CmdLine, Pos - 1)
            CmdLine = mid$(CmdLine, Pos + 1, 0)
         else
            ARGV() = CmdLine
            CmdLine = ""
         endif
      endif
   endwhile
endfunction

circle x y radius
circle x y radius fillflag
box x1 y1 x2 y2
box x1 y1 x2 y2 fillflag

// Constants for Argument datatype function pointers
#CONSTANT INT_ARG_PTR Get Ptr To Function("as_integer")
#CONSTANT FLOAT_ARG_PTR Get ptr To Function("as_float")
#CONSTANT STRING_ARG_PTR Get ptr To Function("as_string")
#CONSTANT BYTE_ARG_PTR Get ptr To Function("as_byte")
#CONSTANT WORD_ARG_PTR Get ptr To Function("as_word")
#CONSTANT DWORD_ARG_PTR Get ptr To Function("as_dword")

// Constants for Return datatype function pointers
#CONSTANT VOID_RET_PTR Get ptr To Function("ret_void")
#CONSTANT INT_RET_PTR Get ptr To Function("ret_integer")
#CONSTANT FLOAT_RET_PTR Get ptr To Function("ret_float")
#CONSTANT STRING_RET_PTR Get ptr To Function("ret_string")
#CONSTANT BYTE_RET_PTR Get ptr To Function("ret_byte")
#CONSTANT WORD_RET_PTR Get ptr To Function("ret_word")
#CONSTANT DWORD_RET_PTR Get ptr To Function("ret_dword")

// --- start here ---

// CL: MyPrint(5,Hello World,3.14)
// I would use my own parsing functions to get the return type and arg types
MyCallFunctionName("MyPrint","v","isf","5,Hello World,3.14")

// CL: MyRND(20,40)
Rand$ = MyCallFunctionName("MyRND","i","ii","20,40")
Print Rand$

// CL: GetString()
string$ = MyCallFunctionName("MyString","s","","")
Print string$

// --- end here ---
Wait Key : end

// These three functions are written normally(no special code to get them to work)
Function MyString()
	s$ = "Hello World"
Endfunction s$

Function MyRND(MinVal,MaxVal)
	Range = MaxVal-MinVal
	R = RND(Range)+MinVal
Endfunction R

Function MyPrint(Arg1 as integer,Arg2 as string,Arg3 as float)
	Print "Int: ",Arg1
	Print "String: ",Arg2
	Print "Float: ",Arg3
Endfunction

// this can call any function
Function MyCallFunctionName(Func$,ReturnType$,Format$,ArgList$)
	
	// Get Pointer to the function name
	FuncPtr = Get Ptr To Function(Func$)
	
	// check if pointer exists
	if FuncPtr<>0

		// define variables
		ArgInt as Integer
		ArgFloat as Float
		ArgString as String
		ArgByte as Byte
		ArgWord as Word
		ArgDword as Dword
		
		ArgCount = Fast LEN(Format$)
		if ArgCount<>0
			
			Split String ArgList$,","
			LOCAL DIM ArgPtr(ArgCount) as DWORD
			LOCAL DIM ArgStr(ArgCount) as String
			
			// set ArgPtr(?) to the correct arg-type function 
			for arg=1 to ArgCount
				Type$ = Mid$(Format$,arg)
				Select Type$
					Case "i": // integer
						ArgPtr(arg) = INT_ARG_PTR
						ArgInt = Val(Get Split Word$(Arg))
						ArgStr(arg) = Str$(ArgInt)
					Endcase
					Case "f": // float
						ArgPtr(arg) = FLOAT_ARG_PTR
						ArgFloat = Val(Get Split Word$(Arg))
						ArgStr(arg) = Str$(ArgFloat)
					Endcase
					Case "s": // string
						ArgPtr(arg) = STRING_ARG_PTR
						ArgString = Get Split Word$(Arg)
						ArgStr(arg) = ArgString
					Endcase
					Case "b": // byte
						ArgPtr(arg) = BYTE_ARG_PTR
						ArgByte = Val(Get Split Word$(Arg))
						ArgStr(arg) = Str$(ArgByte)
					Endcase
					Case "w": // word
						ArgPtr(arg) = WORD_ARG_PTR
						ArgWord = Val(Get Split Word$(Arg))
						ArgStr(arg) = Str$(ArgWord)
					Endcase
					Case "d": // dword
						ArgPtr(arg) = DWORD_ARG_PTR
						ArgDword = Val(Get Split Word$(Arg))
						ArgStr(arg) = Str$(ArgDword)
					Endcase
					Case Default // type not reconized
						ArgPtr(arg) = STRING_ARG_PTR
						ArgString = Get Split Word$(Arg)
						ArgStr(arg) = ArgString
					Endcase
				Endselect
			next arg
		Endif
		
		// set ReturnPtr to correct return-type function
		Select ReturnType$
			Case "v": // void
				ReturnPtr = VOID_RET_PTR
			Endcase
			Case "i": // integer
				ReturnPtr = INT_RET_PTR
			Endcase
			Case "f": // float
				ReturnPtr = FLOAT_RET_PTR
			Endcase
			Case "s": // string
				ReturnPtr = STRING_RET_PTR
			Endcase
			Case "b": // byte
				ReturnPtr = BYTE_RET_PTR
			Endcase
			Case "w": // word
				ReturnPtr = WORD_RET_PTR
			Endcase
			Case "d": // dword
				ReturnPtr = DWORD_RET_PTR
			Endcase
			Case Default // type not reconized
				ReturnPtr = VOID_RET_PTR
			Endcase
		Endselect
		
		// function calls 0 to 9 parameters
		Select ArgCount
			Case 0:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr))
			Endcase
			Case 1:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1))))
			Endcase
			Case 2:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2))))
			Endcase
			Case 3:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3))))
			Endcase
			Case 4:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3)), Call Function Ptr(ArgPtr(4),ArgStr(4))))
			Endcase
			Case 5:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3)), Call Function Ptr(ArgPtr(4),ArgStr(4)), Call Function Ptr(ArgPtr(5),ArgStr(5))))
			Endcase
			Case 6:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3)), Call Function Ptr(ArgPtr(4),ArgStr(4)), Call Function Ptr(ArgPtr(5),ArgStr(5)), Call Function Ptr(ArgPtr(6),ArgStr(6))))
			Endcase
			Case 7:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3)), Call Function Ptr(ArgPtr(4),ArgStr(4)), Call Function Ptr(ArgPtr(5),ArgStr(5)), Call Function Ptr(ArgPtr(6),ArgStr(6)), Call Function Ptr(ArgPtr(7),ArgStr(7))))
			Endcase
			Case 8:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3)), Call Function Ptr(ArgPtr(4),ArgStr(4)), Call Function Ptr(ArgPtr(5),ArgStr(5)), Call Function Ptr(ArgPtr(6),ArgStr(6)), Call Function Ptr(ArgPtr(7),ArgStr(7)), Call Function Ptr(ArgPtr(8),ArgStr(8))))
			Endcase
			Case 9:
				Result$=Call Function Ptr(ReturnPtr,Call Function Ptr(FuncPtr, Call Function Ptr(ArgPtr(1),ArgStr(1)), Call Function Ptr(ArgPtr(2),ArgStr(2)), Call Function Ptr(ArgPtr(3),ArgStr(3)), Call Function Ptr(ArgPtr(4),ArgStr(4)), Call Function Ptr(ArgPtr(5),ArgStr(5)), Call Function Ptr(ArgPtr(6),ArgStr(6)), Call Function Ptr(ArgPtr(7),ArgStr(7)), Call Function Ptr(ArgPtr(8),ArgStr(8)), Call Function Ptr(ArgPtr(9),ArgStr(9))))
			Endcase
		Endselect
	Else
		Exit Prompt "function '"+func$+"' does not exist!","Error"
		End
	Endif
	
Endfunction Result$

// Argument String to Types functions
function as_string(v as string)
endfunction v

function as_integer(v as string)
	result as integer
	result = Val(v)
endfunction result

function as_float(v as string)
	result as float
	result = Val(v)
endfunction result

function as_byte(v as string)
	result as byte
	result = Val(v)
endfunction result

function as_word(v as string)
	result as word
	result = Val(v)
endfunction result

function as_dword(v as string)
	result as dword
	result = Val(v)
endfunction result

// return type to string functions
function ret_void(v)
	result$ = ""
Endfunction result$

function ret_string(v as string)
Endfunction v

function ret_integer(v as integer)
	Result$ = Str$(v)
Endfunction result$

function ret_float(v as float)
	Result$ = Str$(v)
Endfunction result$

function ret_byte(v as byte)
	Result$ = Str$(v)
Endfunction result$

function ret_word(v as word)
	Result$ = Str$(v)
Endfunction result$

function ret_dword(v as dword)
	Result$ = Str$(v)
Endfunction result$

dim col(255)
col(int(ang)) = 0

sync on

make object cube 1, 1
m = new matrix4()
set identity matrix4 m
apply view matrix4 m

do
    sync
loop

PRINT DELIMIT CSV$("248WW,248WW2,248HF")
SYNC
WAIT KEY

` Make a 512x512 image
make image 1,512,512,21
` Draw to it
draw to image 1
` Paint it white
box 0,0,512,512,rgb(255,255,255)
` Black text near middle
ink rgb(0,0,0),rgb(255,255,255)
text 256,256,"Hello!"
` Back to screen
draw to bitmap 0

do
  paste image 1, 25, 25
  if upkey() then PrintImage(1)
loop

function PrintImage(i)
   Set Printer Orientation 1 : ` Landscape
   qpw = Get Printer Page Width()
   qph = Get Printer Page Height()
   ` Scale
   pw = qpw
   ph = image height(i) * (1.0 * ((pw*1.0)/(image width(i)*1.0)))
   Image_To_Printer(i,0,0, pw, ph)
   Printer Go
endfunction

function Image_To_Printer(ImageNo As Integer,x As integer,y as integer, width as integer, height as integer)
  mem_no as integer
  ptr as DWORD
  mem_no = find free memblock()
  MAKE MEMBLOCK FROM IMAGE mem_no,ImageNo
  ptr = GET MEMBLOCK PTR(mem_no)
  PLOT BITMAP IN MEMBLOCK ptr,x,y,width,height
  DELETE MEMBLOCK mem_no
endfunction

make object plain 1, 100, 100, 104, 106
open console : print console object exist(1); crlf$()
lock vertexdata for limb 1, 0
ptr = get vertexdata ptr()
print console "Pointer: #"; hex$(ptr); crlf$()

unlock vertexdata
c$ = get console char$()

  d$ = datafile string$(1)
  while datafile end(1) = 0
    UpdateLog("String is "+d$)
    split csv string d$
    UpdateLog("Split OK")
    Skus(y).SKU    = split word$(1)
    Skus(y).Price  = split word$(3)
    Skus(y).Desc   = split word$(2)
    d$ = datafile string$(1)
    inc y
  endwhile

    d$ = replace all$(d$,chr$(34)+chr$(34),"QUOTEMARKHERE")
    d$ = replace all$(d$,chr$(34)+","+chr$(34),chr$(34)+chr$(1)+chr$(34))
    d$ = replace all$(d$,chr$(34),"")
    d$ = replace all$(d$,"QUOTEMARKHERE",chr$(34))
    split string d$, chr$(1)

`%Project Title%
`ColourTests.dba
`======================
sync on
c as DWORD
d as DWORD
e as DWord
f as DWORD
// Original colour
c = rgb(255,100,150,200)

// Converted to HSV
d = RGB TO HSV ( c )

// Convert the unchanged HSV value back to the source RGB colour in variable E
e = HSV TO RGB ( d )

// Try the same with AHSV parameters
a# = HSV A(d)
iHue# = HSV H(d)
s# = HSV s(d)
v# = HSV V(V#)
f = HSV TO RGB ( a#, iHue#, s#, v# )

// The values C, E and F should be the same, but are not
Print "Original RGB: "; c
Print "New HSV: "; d
Print "Returned RGB: "; e
Print "Converted RGB: "; f

// Neither are these return values
PRINT "RGB Original: "; RGBR(c); ","; RGBG(C); ","; RGBB(C)
PRINT "RGB Returned: "; RGBR(e); ","; RGBG(e); ","; RGBB(e)
PRINT "RGB Converted: "; RGBR(f); ","; RGBG(f); ","; RGBB(f)
PRINT "HSV Converted: "; RGBR(d); ","; RGBG(d); ","; RGBB(d)
Ink e, e : box 300,300,340,340
Ink f, f : box 300,340,340,380
sync

Wait Key

v# = HSV V(V#) should be v# = HSV V(d)

sync on
c as DWORD
d as DWORD
e as DWord
f as DWORD
// Original colour
c = rgb(255,100,150,200)
d = RGB TO HSV ( c )
do
	// Converted to HSV


	// Convert the unchanged HSV value back to the source RGB colour in variable E
	e = HSV TO RGB ( d )

	// Try the same with AHSV parameters
	a# = HSV A(d)
	iHue# = HSV H(d)
	s# = HSV s(d)
	v# = HSV V(d)
	f = HSV TO RGB ( a#, iHue#, s#, v# )

	// The values C, E and F should be the same, but are not
	Print "Original RGB: "; c
	Print "New HSV: "; d
	Print "Returned RGB: "; e
	Print "Converted RGB: "; f

	// Neither are these return values
	PRINT "RGB Original: "; RGBR(c); ","; RGBG(C); ","; RGBB(C)
	PRINT "RGB Returned: "; RGBR(e); ","; RGBG(e); ","; RGBB(e)
	PRINT "RGB Converted: "; RGBR(f); ","; RGBG(f); ","; RGBB(f)

	Ink e, e : box 300,300,340,340
	Ink f, f : box 300,345,340,385
	sync
	set cursor 0,0
loop

in$ = "   Hello   ~    world   "

split string in$, "~"

out$ = trim$(split word$(1))
for i = 2 to split count()
    out$ = out$ + "~" + trim$( split word$(i) )
next

print "BEFORE"
print in$

print "AFTER"
print out$

wait key

while string count$(in$,"~ ")
 in$=replace all$(in$,"~ ")
endwhile

sync on
sync sleep 1
sync
sync

dim Grouping(9) as string

GroupID = 0
ID = 1

do
    if leftkey() and GroupID > 0 then dec GroupID
    if rightkey() and GroupID < 9 then inc GroupID
    
    if upkey() and ID < 100 then inc ID
    if downkey() and ID > 1 then dec ID
    
    if spacekey() then AddToGroup(ID, GroupID)
    if returnkey() then RemoveFromGroup(ID, GroupID)
    
    cls
    print "Group: "; GroupID
    print "ID: "; ID
    print
    for i = 0 to 9
        print "Grouping ("; i; "): "; Grouping(i); ""
    next
    print
    print "left/right = change group (0-9)"
    print "up/down = change id (1-100)"
    print "space = add id to group"
    print "return = remove id from group"
    
    if shiftkey() then ProcessGroup( GroupID, "MyFunction")
    sync

    wait no key
    wait key
loop


function MyFunction(ID as integer)
    print "Processing ID "; ID
endfunction

function ProcessGroup(Group as integer, FunctionName as string)
    local ID as integer
    local i as integer
    
    split string Grouping(Group), "."
    i = split count()-1
    while i > 0
        ID = intval( split word$(i) )
        print "ID = "; ID; "... ";
        call function name FunctionName, ID
        print ""
        dec i
    endwhile
endfunction

function AddToGroup(ID as integer, Group as integer)
    local StrID as string
    
    StrID = IntToString(ID)
    
    if instr(Grouping(Group), StrID) = 0 then Grouping(Group) = Grouping(Group) + StrID
endfunction

function RemoveFromGroup(ID as integer, Group as integer)
    local StrID as string
    
    StrID = IntToString(ID)
    
    Grouping(Group) = remove$(Grouping(Group), StrID)
endfunction

function IntToString(ID)
    local StrID as string

    StrID = padleft$( str$(ID), "0", 5) + "."
endfunction StrID

function StringToID(StrID as string)
    local ID as integer
    
    ID = intval( StrID )
endfunction ID

Obj$(objectId) = "Door&Solid"
Split String Obj$(1), "&"
For i = 1 to Split Count()
  Call Function Name Split Word$(i), objectId
Next i

`Monster builder
`===============
`set ups
backdrop on
`set sync on for the this application to handle screen refreshing with the "sync" command
sync on
`set refresh rate
sync rate 60

current_ui$ = "main"

dim file_list$(100)
file_list$(1) = "Bot"
file_list$(2) = "Squid"
file_list$(3) = "Rat"

do
	call function name current_ui$
	y = 0
	for t = 1 to 3
		text 90,y,file_list$(t)
		inc y,10
	next t
	sync
loop

function main()
endfunction

h = get ptr to function("NextFunction")

call function ptr h

r=EXECUTE SAVE DIALOG("Save PDF As",dir documents(),"PDF Files (*.pdf)|*.pdf","Default PDF name")
if r
  r$ = save dialog filename()
endif

call function ptr h
wait key
end

function NextFunction()
  print "Next"
endfunction