Liberty BASIC Community Forum
« Sample Program .bas code »

Welcome Guest. Please Login or Register.
Sep 21st, 2017, 12:17am


Rules|Home|Help|Search|Recent Posts|Notification


« Previous Topic | Next Topic »
Pages: 1 ... 3 4 5 6 7  Notify Send Topic Print
 locked  Author  Topic: Sample Program .bas code  (Read 904 times)
Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program popupmenu2.bas
« Reply #60 on: Aug 15th, 2017, 04:35am »

popupmenu2.bas

Simple tidy


Code:
    'show how to use a popupmenu
    nomainwin

    open "Popup Menu Example" for graphics_nsb as #main
    #main "down ;\\\  Right click anywhere in this\  window to pop up a menu."
    #main "trapclose [quit]"
    #main "when rightButtonUp [popupMenu]"
    wait

[popupMenu]
    popupMenu "I will", [doNothing], "pop up where", [doNothing], "the mouse is", [doNothing]
    wait

[doNothing]
    wait

[quit]
    notice "quitting now"
    close #main
    end
 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program printform.bas
« Reply #61 on: Aug 15th, 2017, 04:45am »

printform.bas

Unchanged


Code:
    'printform.bas
    'This example program shows how to use a graphics window to produce
    'printable form without using PCL or graphics characters.  Different
    'fonts and colors are used.

    nomainwin
    WindowWidth = 800
    WindowHeight = DisplayHeight
    open "Printable Form" for graphics as #form
    #form "trapclose [quit]"

    #form "down"
    #form "backcolor 220 220 220"
    #form "size 2"
    #form "place 1 1 ; boxfilled 700 110"
    #form "font arial 16 bold"

    #form "place 20 34"
    #form "\Software Mail-in Order Form"
    #form "font arial 10"
    #form "\Mega2 Super Corporation\PO Box 1029391\Industrialtown, PA 11701\"

    #form "backcolor white"
    #form "place 1 110"
    #form "boxfilled 700 471"

    #form "place 1 471"
    #form "boxfilled 700 970"

    #form "font courier_new 10"
    #form "size 1"
    for a = 1 to 9
        y = 111+a*30
        #form "place 250 "; y
        #form "box 650 "; y + 22
        read label$
        #form "place 50 "; y + 13
        #form "\"; label$
    next a

    #form "place 150 431"
    #form "font courier_new 10 italic"
    #form "\Make sure to provide your email address so we can send"
    #form "\your registration code promptly!"

    #form "place 50 501"
    #form "\ 1) Widget Tools SILVER license:"
    #form "\    "
    #form "\                $29.95 x ____ copies          = $______________.___"
    #form "\"
    #form "\ 2) Widget Tools GOLD license:"
    #form "\"
    #form "\                $49.95 x ____ copies          = $______________.___"
    #form "\"
    #form "\ 3) Upgrade to SILVER license.  You will receive a special"
    #form "\    registration code which works with your v1.x or v2.x or 3.x"
    #form "\    license code to upgrade to v4.0 SILVER!"
    #form "\"
    #form "\                $14.95 x ____ copies          = $______________.___"
    #form "\"
    #form "\ 4) Upgrade to GOLD license.  You will receive a special"
    #form "\    registration code which works with your v1.x or v2.x or v3.0x"
    #form "\    license code to upgrade to v4.0 GOLD!"
    #form "\"
    #form "\                $19.95 x ____ copies          = $______________.___"
    #form "\"
    #form "\    Circle YES below if you want us to mail you an optional CDROM."
    #form "\    Your registration code will be printed clearly on the disk."
    #form "\"
    #form "\    YES  Send me the optional CDROM!          = $            10.00"
    #form "\"
    #form "\"
    #form "\                                Total         = $______________.___"


    #form "flush"
    confirm "Send to printer?"; answer
    if answer then #form "print svga"
    wait
    close #form
    end

    data "Name:", "Address 1:", "Address 2:", "City:", "State:", "Zip Code:"
    data "Email Address:", "Special Instructions:", "Comments:"

[quit]
    close #form
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program QsortLB.bas
« Reply #62 on: Aug 15th, 2017, 05:12am »

QsortLB.bas


Code is unchanged, propose to add a multi column sort example as well

Code:
'Liberty BASIC has its own built-in sorting capability, but here
'is an example of how you would write this in BASIC.
'Adapted from Beginning Programming for Dummies by Wallace Wang

mainwin 80 'give me 80 columns
MaxSize = 25
dim NumArray(MaxSize)
for i = 1 to MaxSize
  NumArray(i) = int(rnd(1)*10) + 1
  print NumArray(i); " ";
next i
print "(Initial array)"

call QSort 1, MaxSize

for i = 1 to MaxSize
  print NumArray(i); " ";
next i
print "(Sorted array)"
end

sub QSort Start, Finish
  i = Start
  j = Finish
  x = NumArray(int((i+j)/2))
  while i <= j
    while NumArray(i) < x
      i = i + 1
    wend
    while NumArray(j) > x
      j = j - 1
    wend
    if i <= j then
      a = NumArray(i)
      NumArray(i) = NumArray(j)
      NumArray(j) = a
      i = i + 1
      j = j - 1
    end if
  wend
  for k = 1 to Finish
    print NumArray(k); " ";
  next k
  print
  if j > Start then call QSort Start, j
  if i < Finish then call QSort i, Finish
end sub

 



MsortLB.bas

Code:
'This code uses a modified quicksort routine
'to sort on multiple columns of a data set

dim dbf$(25,10)
print "Unsorted Set"
for row=1 to 25
    for col=1 to 10
        dbf$(row,col)=str$(int(rnd(0)*9+.5))
        print dbf$(row,col);" ";
    next
    print
next

'provide the starting row, ending row and the number of columns
'and comma delimited string of the column numbers to sort on
'in priority order. This example sorts column3 in order within
'column2
call qsort 1,25,10,"2,3"

print "Sorted Set"
for row=1 to 25
    for col=1 to 10
        print dbf$(row,col);" ";
    next
    print
next
wait

sub qsort Start, Finish, numCol, order$
  'order$ is a comma delimited priority list of columns to sort on "2,1" "7" etc
  i = Start
  j = Finish
  dim temp$(numCol)

  'create the compare string
  r=int((i+j)/2)
  compa$=""
  o=1
  o$=word$(order$,o,",")
  while o$<>""
    compa$=compa$+dbf$(r,val(o$))
    o=o+1
    o$=word$(order$,o,",")
  wend
  while i <= j
      'create the string to compare against
      compb$=""
      o=1
      o$=word$(order$,o,",")
      while o$<>""
        compb$=compb$+dbf$(i,val(o$))
        o=o+1
        o$=word$(order$,o,",")
      wend
      while compb$ < compa$
        i = i + 1
        compb$=""
        o=1
        o$=word$(order$,o,",")
        while o$<>""
            compb$=compb$+dbf$(i,val(o$))
            o=o+1
            o$=word$(order$,o,",")
        wend
    wend
    'create the string to compare against
    compb$=""
    o=1
    o$=word$(order$,o,",")
    while o$<>""
        compb$=compb$+dbf$(j,val(o$))
        o=o+1
        o$=word$(order$,o,",")
    wend
    while compb$ > compa$
      j = j - 1
      compb$=""
      o=1
      o$=word$(order$,o,",")
      while o$<>""
        compb$=compb$+dbf$(j,val(o$))
        o=o+1
        o$=word$(order$,o,",")
      wend
    wend
    if i <= j then
        for p=0 to numCol
            temp$(p)=dbf$(i,p)
        next
        'a$ = sa$(i)
        for p=0 to numCol
            dbf$(i,p)=dbf$(j,p)
        next
        'sa$(i) = sa$(j)
        for p=0 to numCol
            dbf$(j,p)=temp$(p)
        next
        'sa$(j) = a$
        i = i + 1
        j = j - 1
    end if
  wend
  if j > Start then call qsort Start, j, numCol, order$
  if i < Finish then call qsort i, Finish, numCol, order$
end sub


 


User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program resize.bas
« Reply #63 on: Aug 15th, 2017, 05:26am »

resize.bas


Changed to wait rather than input loop. Kinda still bugged.

The controls are misaligned on first drawing, they get even more misaligned if you take out the first wait and allow the resize handler to run. Only when the frame is moved do all the controls line up correctly. Been discussed in other threads.

Code:
    'resize.bas
    'This is an example of a program which resizes several
    'controls in a window depending on how the user changes
    'the size of the window.

    nomainwin
    WindowWidth = 550
    WindowHeight = 410

    listbox #resizer.lbox1, array$(), [lbox1DClick], 1, 0, 256, 186
    listbox #resizer.lbox2, array$(), [lbox2DClick], 257, 0, 284, 164
    combobox #resizer.cbox3, array$(), [cbox3DoubleClick], 257, 164, 283, 150
    texteditor #resizer.tedit4, 1, 186, 540, 195
    open "Resizing example" for window as #resizer
    #resizer "trapclose [quit]"
    #resizer "resizehandler [resized]"
    wait


[resized]
    wWid = WindowWidth
    wHig = WindowHeight
    upperVert = int(256/550*wWid) 'upper middle vertical edge
    midHoriz = int(186/410*wHig) 'middle horizontal edge
    urWid = upperVert - wWid
    print #resizer.lbox1, "locate 0 0 "; upperVert; " "; int(186/410*wHig)
    print #resizer.lbox2, "locate "; upperVert; " 0 "; wWid-upperVert; " "; int(186/410*wHig)-23
    print #resizer.cbox3, "locate "; upperVert; " "; midHoriz-23; " "; wWid - upperVert; " "; 100
    print #resizer.tedit4, "!locate 0 "; midHoriz; " "; wWid; " "; wHig-midHoriz;
    print #resizer, "refresh"
    wait

[quit] 'quit the program
    close #resizer
    end
 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program rndtest.bas
« Reply #64 on: Aug 15th, 2017, 05:29am »

rndtest.bas

Drew afew more dots.


Code:
    'Test the random number generator to see if it can draw
    'uniformly random dots!
    nomainwin

    WindowWidth = 410
    WindowHeight = 440
    open "random generator test" for graphics_nsb as #draw
    #draw "trapclose [quit]"
    #draw "down ; size 2"
    for x = 1 to 50000
        scan 'allow user to break out of loop
        #draw "place "; int(rnd(1)*400); " "; int(rnd(1)*400)
        #draw "go 1"
    next x
    wait

[quit]
    close #draw
    end
 
« Last Edit: Aug 18th, 2017, 08:18am by Rod » User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program radiobutton.bas
« Reply #65 on: Aug 15th, 2017, 05:30am »

radiobutton.bas/rbgroup.bas



both examples need more work

This is proposed replacement for both examples

Code:
    'demonstrates radiobuttons
    nomainwin

    'saved status
    'you might load these from a file
    fstatus=1 '1=always, 2= when replacing, 3=never
    pstatus=1

    WindowWidth = 520
    WindowHeight = 220

    groupbox #cfg, "Confirm File Operations:", 240, 20, 200, 140
    radiobutton #cfg.falways, "Always", [falways], [unset], 260, 45, 130, 20
    radiobutton #cfg.fwhen, "When Replacing", [fwhen], [unset], 260, 70, 130, 20
    radiobutton #cfg.never, "Never", [fnever], [unset], 260, 95, 130, 20
    groupbox #cfg, "Confirm Print Operations:", 20, 20, 200, 140
    radiobutton #cfg.palways, "Always", [palways], [unset], 40, 45, 130, 20
    radiobutton #cfg.pwhen, "When Replacing", [pwhen], [unset], 40, 70, 130, 20
    radiobutton #cfg.pnever, "Never", [pnever], [unset], 40, 95, 130, 20
    button #cfg, " &OK ", [cfgOk], UL, 450, 30
    open "Action Confirmation - Setup" for dialog as #cfg
    #cfg "trapclose [cfgOk]"

    'set to current status
    if fstatus=1 then #cfg.falways "set"
    if fstatus=2 then #cfg.fwhen "set"
    if fstatus=3 then #cfg.fnever "set"
    if pstatus=1 then #cfg.palways "set"
    if pstatus=2 then #cfg.pwhen "set"
    if pstatus=3 then #cfg.pnever "set"
    'now wait for user input
    wait

[unset]
    wait

[falways]
    fstatus=1
    wait

[fwhen]
    fstatus=2
    wait

[fnever]
    fstatus=3
    wait

[palways]
    pstatus=1
    wait

[pwhen]
    pstatus=2
    wait

[pnever]
    pstatus=3
    wait

[cfgOk]
    status$=str$(fstatus)+" "+str$(pstatus)
    confirm status$ + chr$(13) + "Save this configuration?"; answer$
    'perform some sort of save for config here
    close #cfg
    end

 
« Last Edit: Aug 18th, 2017, 08:43am by Rod » User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program rolodex1.bs
« Reply #66 on: Aug 18th, 2017, 08:13am »

rolodex1.bas


Unchanged save for the window size. !autoresize does not work unless there is enough whitespace. Increased to 250,250

Code:
    ' This is a simple Rolodex application

    ' In this demo we touch upon adding buttons to a text window,
    ' sequential file i/o, and more

    ' do not open a main window
    nomainwin

    dim cards$(1000) ' set up one hundred rolodex cards

    gosub [loadCards]

    if cardLimit = 0 then cards$(0) = "Shoptalk Systems" + chr$(13) + "http://www.libertybasic.com" + chr$(13) : cardLimit = 1

    cardNumber = 0
    WindowWidth = 250
    WindowHeight = 250

    bmpbutton #rolo, "bmp\lbttn.bmp", [previous], UL, 5, 3
    bmpbutton #rolo, "bmp\rbttn.bmp", [next], UL, 34, 3
    bmpbutton #rolo, "bmp\addbttn.bmp", [add], UL, 63, 3
    bmpbutton #rolo, "bmp\lensbttn.bmp", [find], UL, 92, 3
    bmpbutton #rolo, "bmp\xoutbttn.bmp", [del], UL, 121, 3
    bmpbutton #rolo, "bmp\tohdrive.bmp", [save], UL, 150, 3
    texteditor #rolo.text, 5, 32, 213, 150
    open "Liberty Rolodex" for window_nf as #rolo

    print #rolo, "trapclose [quit]"
    print #rolo.text, cards$(cardNumber) ;

[mainLoop]
    'wait for user input
    wait

[loadCards]

    cardLimit = 0

    'return now if file does not exist
    dim info$(10,3)
    files "", "rolodeck.dat", info$()
    if val(info$(0, 0)) = 0 then return

    open "rolodeck.dat" for input as #file

    while eof(#file) = 0 and cardLimit < 100 and line$ <> "EOF"
        card$ = ""
        line$ = ""
        while line$ <> "EOC"  and line$ <> "EOF"   ' End Of Card
            line input #file, line$
            if line$ <> "EOC" then card$ = card$ + line$ + chr$(13)
        wend
        if line$ <> "EOF" then cards$(cardLimit) = card$  : cardLimit = cardLimit + 1
    wend

    close #file

    return

[next]     ' >> was pressed. move foreward to the next card and display it

    if cardNumber + 1 >= cardLimit then [mainLoop]

    gosub [cardRead]

    cardNumber = cardNumber + 1
    print #rolo.text, "!cls";
    print #rolo.text, cards$(cardNumber);

    goto [mainLoop]

[previous]      ' << was pressed. back up to the previous card and display it

    if cardNumber <= 0 then [mainLoop]

    gosub [cardRead]

    cardNumber = cardNumber - 1
    print #rolo.text, "!cls";
    print #rolo.text, cards$(cardNumber);

    goto [mainLoop]

[find]     ' Find was pressed. find and display the card containing findString$

    prompt "Find what?"; findString$

    for searchIndex = 0 to cardLimit - 1
        matchIndex =  instr(cards$(searchIndex), findString$)
        if matchIndex > 0 then cardNumber = searchIndex
    next searchIndex

    print #rolo.text, "!cls";
    print #rolo.text, cards$(cardNumber);

    goto [mainLoop]

[add]     ' Add was pressed. add a new card to the end of the deck

    if cards$(cardNumber) = "" then [mainLoop]
    if cardLimit >= 99 then [mainLoop]

    cardNumber = cardLimit

    print #rolo.text, "!cls";
    print #rolo.text, "New Card."
    print #rolo.text, "Click on Save When Done."
    print #rolo.text, "!selectall";

    goto [mainLoop]

[del]     ' Del was pressed. delete the currently displayed card

    if cardNumber = cardLimit then [mainLoop]

    confirm "Delete: Are you sure?" ; answer$
    if answer$ = "no" then [mainLoop]

    for index = cardNumber + 1 to cardLimit
        cards$(index-1) = cards$(index)
    next index

    cardLimit = cardLimit - 1
    if cardNumber = cardLimit and cardNumber > 0 then cardNumber = cardNumber - 1
    if cardLimit = 0 then cardLimit = 1

    print #rolo.text, "!cls";
    print #rolo.text, cards$(cardNumber);

    goto [mainLoop]

[save]     ' Save was pressed. save the entire deck of cards

    gosub [cardRead]
    if cardNumber = cardLimit then cardLimit = cardLimit + 1

    ' save each card into rolodeck.dat ending each card with EOC
    ' and ending the file in EOF
    open "rolodeck.dat" for output as #deck

    for index = 0 to cardLimit - 1
        print #deck, cards$(index); "EOC"
    next index
    print #deck, "EOF"

    close #deck

    goto [mainLoop]

[quit]     ' close event occurred.. save the entire deck of cards

    confirm "Quit Rolodex?"; r$
    if r$ = "no" then [mainLoop]

    gosub [cardRead]
    if cardNumber = cardLimit then cardLimit = cardLimit + 1

    ' save each card into rolodeck.dat ending each card with EOC
    ' and ending the file in EOF

    print #rolo.text, "!cls";
    print #rolo.text, "Saving data...";

    open "rolodeck.dat" for output as #deck

    for index = 0 to cardLimit - 1
        print #deck, cards$(index); "EOC"
    next index
    print #deck, "EOF"

    close #deck

    close #rolo

    end

[cardRead]    ' read the contents of the window into the current card slot

    print #rolo.text, "!modified? m$";
    if m$ = "false" then return

    ' find out how many lines of text are displayed
    print #rolo.text, "!lines size";

    ' place the contents of #rolo into card$
    card$ = ""
    for index = 1 to size
        print #rolo.text, "!line "; index ;
        line input #rolo.text, line$
        card$ = card$ + line$ + chr$(13)
    next index

    ' remove extra blank lines from end of card
    while right$(card$, 2) = chr$(13) + chr$(13)
        card$ = left$(card$, len(card$) - 1)
    wend

    cards$(cardNumber) = card$

    return

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program rolodex3.bas
« Reply #67 on: Aug 18th, 2017, 08:16am »

rolodex3.bas

Same as rolodex1, unchanged save for the WindowWidth, WindowHeight.

Code:
    ' rolodex3.bas - This is a simple Rolodex application written for Liberty BASIC v3.0.
    ' Liberty BASIC v1.x and v2.x users should find it instructive to compare this with
    ' the rolodex1.bas example also included because this version uses newer Liberty
    ' BASIC features.

    ' In this demo we touch upon adding buttons to a text window,
    ' sequential file i/o, and more

    ' do not open a main window
    nomainwin

    dim cards$(1000) ' set up one hundred rolodex cards

    gosub [loadCards]

    if cardLimit = 0 then
        cards$(0) = "Shoptalk Systems" + chr$(13) + "http://www.libertybasic.com" + chr$(13)
        cardLimit = 1
    end if

    cardNumber = 0
    WindowWidth = 250
    WindowHeight = 250

    bmpbutton #rolo, "bmp\newbttn.bmp", [add], UL, 5, 3
    bmpbutton #rolo, "bmp\saveas.bmp", [save], UL, 34, 3
    bmpbutton #rolo, "bmp\lbttn.bmp", [previous], UL, 63, 3
    bmpbutton #rolo, "bmp\rbttn.bmp", [next], UL, 92, 3
    bmpbutton #rolo, "bmp\lensbttn.bmp", [find], UL, 121, 3
    bmpbutton #rolo, "bmp\xoutbttn.bmp", [del], UL, 150, 3
    texteditor #rolo.text, 0, 32, 218, 149
    open "Liberty Rolodex v3.0" for window as #rolo
    #rolo "trapclose [quit]"
    #rolo.text "!autoresize"
    #rolo.text cards$(cardNumber) ;
    wait

[loadCards]

    cardLimit = 0

    'return now if file does not exist
    dim info$(10,3)
    files "", "rolodeck.dat", info$()
    if val(info$(0, 0)) = 0 then return

    open "rolodeck.dat" for input as #file

    while eof(#file) = 0 and cardLimit < 100 and line$ <> "EOF"
        card$ = ""
        line$ = ""
        while line$ <> "EOC"  and line$ <> "EOF"   ' End Of Card
            line input #file, line$
            if line$ <> "EOC" then card$ = card$ + line$ + chr$(13)
        wend
        if line$ <> "EOF" then cards$(cardLimit) = card$  : cardLimit = cardLimit + 1
    wend

    close #file

return

[next]     ' >> was pressed. move foreward to the next card and display it

    if cardNumber + 1 >= cardLimit then wait

    gosub [cardRead]

    cardNumber = cardNumber + 1
    #rolo.text "!cls"
    #rolo.text cards$(cardNumber);
    wait

[previous]      ' << was pressed. back up to the previous card and display it

    if cardNumber <= 0 then wait

    gosub [cardRead]

    cardNumber = cardNumber - 1
    #rolo.text "!cls"
    #rolo.text cards$(cardNumber);
    wait

[find]     ' Find was pressed. find and display the card containing findString$

    prompt "Find what?"; findString$

    for searchIndex = 0 to cardLimit - 1
        matchIndex =  instr(cards$(searchIndex), findString$)
        if matchIndex > 0 then cardNumber = searchIndex
    next searchIndex

    #rolo.text "!cls"
    #rolo.text cards$(cardNumber);
    wait

[add]     ' Add was pressed. add a new card to the end of the deck

    if cards$(cardNumber) = "" then wait
    if cardLimit >= 99 then wait

    cardNumber = cardLimit

    #rolo.text "!cls"
    #rolo.text "New Card."
    #rolo.text "Click on Save When Done."
    #rolo.text "!selectall"
    wait

[del]     ' Del was pressed. delete the currently displayed card

    if cardNumber = cardLimit then wait

    confirm "Delete: Are you sure?" ; answer$
    if answer$ = "no" then wait

    for index = cardNumber + 1 to cardLimit
        cards$(index-1) = cards$(index)
    next index

    cardLimit = cardLimit - 1
    if cardNumber = cardLimit and cardNumber > 0 then cardNumber = cardNumber - 1
    if cardLimit = 0 then cardLimit = 1

    #rolo.text "!cls"
    #rolo.text cards$(cardNumber);
    wait

[save]     ' Save was pressed. save the entire deck of cards

    gosub [cardRead]
    if cardNumber = cardLimit then cardLimit = cardLimit + 1

    ' save each card into rolodeck.dat ending each card with EOC
    ' and ending the file in EOF
    open "rolodeck.dat" for output as #deck

    for index = 0 to cardLimit - 1
        print #deck, cards$(index); "EOC"
    next index
    print #deck, "EOF"

    close #deck
    wait

[quit]     ' close event occurred.. save the entire deck of cards

    confirm "Quit Rolodex?"; r$
    if r$ = "no" then wait

    gosub [cardRead]
    if cardNumber = cardLimit then cardLimit = cardLimit + 1

    ' save each card into rolodeck.dat ending each card with EOC
    ' and ending the file in EOF

    #rolo.text "!cls"
    #rolo.text "Saving data...";

    open "rolodeck.dat" for output as #deck

    for index = 0 to cardLimit - 1
        print #deck, cards$(index); "EOC"
    next index
    print #deck, "EOF"

    close #deck

    close #rolo

    end

[cardRead]    ' read the contents of the window into the current card slot

    #rolo.text "!modified? m$"
    if m$ = "false" then return

    ' find out how many lines of text are displayed
    #rolo.text "!lines size"

    ' place the contents of #rolo into card$
    card$ = ""
    for index = 1 to size
        #rolo.text "!line "; index
        line input #rolo.text, line$
        card$ = card$ + line$ + chr$(13)
    next index

    ' remove extra blank lines from end of card
    while right$(card$, 2) = chr$(13) + chr$(13)
        card$ = left$(card$, len(card$) - 1)
    wend

    cards$(cardNumber) = card$

    return

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program runbatch.bas
« Reply #68 on: Aug 18th, 2017, 09:12am »

runbatch.bas


Original would not run for me in win10 but this does.


Code:
    'how to run a DOS batch file from Liberty BASIC
    print DefaultDir$+"\test.bat"
    open DefaultDir$+"\test.bat" for output as #1
    #1 "pause - this is a test"
    #1 "exit"
    close #1

    run DefaultDir$+"\test.bat"
 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program segment.bas
« Reply #69 on: Aug 18th, 2017, 09:16am »

segment.bas


Simple tidy

Code:
    'segment.bas
    'This program demonstrates the use of graphics
    'segments.  Five graphic segments are drawn, and
    'then the second and fourth are deleted.  Then
    'the window is redrawn, causing the first, third,
    'and fifth segments to be redrawn automatically.
    nomainwin

    'Open a graphics window
    open "segment demo" for graphics as #draw
    #draw "trapclose [quit]"

    'Set up a large font and put the pen in the
    'upper left corner
    #draw "font arial 20"
    #draw "place 10 25"

    'Draw the words ONE, TWO, THREE, FOUR and FIVE
    'each in its own segment (this is done with the
    'flush command).
    #draw "\ONE"
    #draw "flush"
    #draw "\TWO"
    #draw "flush"
    #draw "\THREE"
    #draw "flush"
    #draw "\FOUR"
    #draw "flush"
    #draw "\FIVE"
    #draw "flush"

    'Now delete the second and fourth segments, leaving
    'only the drawn words ONE, THREE, and FIVE
    #draw "delsegment 2"
    #draw "delsegment 4"

    'Now redraw so that the graphics will be displayed
    'without the deleted segments.
    #draw "redraw"

    wait

[quit]
    close #draw
    end

 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program selectcasethree.bas
« Reply #70 on: Aug 18th, 2017, 12:49pm »

selectcasethree.bas

Unchanged



Code:
    'This program fills a variable value, finds its designated partner
    'and reverses the text just for fun.
    value = 3
    select case value
        case 1
            print reversed$("one")
        case 2
            print reversed$("two")
        case 3
            print reversed$("three")
        case 4
            print reversed$("four")
        case 5
            print reversed$("five")
        case else
            print value; " is not covered!"
    end select

function reversed$(string$)
    for x = len(string$) to 1 step -1
        reversed$ = reversed$ + mid$(string$, x, 1)
    next x
end function

 

User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program sieve2.bas
« Reply #71 on: Aug 18th, 2017, 12:50pm »

sieve2.bas


Unchanged


Code:
    'sieve2.bas
    'Notice that arrays are globally visible to functions.
    'The sieve() function uses the flags() array.
    'This is a Sieve benchmark adapted from BYTE 1985
    ' May, page 286

    size = 7000
    dim flags(7001)
    start = time$("ms")
    print sieve(size); " primes found."
    print "End of iteration.  Elapsed time in milliseconds: "; time$("ms")-start
    end

    function sieve(size)
        for i = 0 to size
            if flags(i) = 0 then
                prime = i + i + 3
                k = i + prime
                while k <= size
                    flags(k) = 1
                    k = k + prime
                wend
                sieve = sieve + 1
            end if
        next i
    end function
 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program .bas code
« Reply #72 on: Aug 18th, 2017, 1:07pm »

SKETCH for th Arduino board
Code:
#include <Servo.h>
 // set up 14 servo objects in an array
 Servo myservos[14] ;

 void setup() {
   Serial.begin(9600);
   Serial.println("Com Open");
 }
 void loop() {

 // checkPot() uses pin 4 (or pin 18 in LB rpog ) and pin 13
 // do not change settings on these in the lbRun() function
 checkPot();

 }

 // serialEvent checks to see if data is available on serial port
 // when a message comes we just invoke our LB function
 // unlike LB functions can be used without assigning a return value
 // an initial * is needed for each message as it is consumed my serialEvent()

 void serialEvent(){
   // check if data available, if so call the LB routine
   if ( Serial.available() ) {
   lbRun();
   }
 }

 // all the functionality from previous LB sketch is now wrapped up here
 // this is called automatically from serialEvent() when a new message is detected
 void lbRun()
 {
   while (Serial.available() > 0)
   {
     // look for the next valid integer in the incoming serial stream:
     int cmd = Serial.parseInt();
     // do it again:
     int pin = Serial.parseInt();
     // do it again:
     int val = Serial.parseInt();
     // look for the newline. That's the end of your
     // sentence:
     if (Serial.read() == '*')
     {

       if ( cmd == 0)//pin mode set
       {
         if (val == 0)//input
         {
           pinMode(pin, INPUT);
           digitalWrite(pin, HIGH);
         }
         if (val == 1)//output
         {
           pinMode(pin, OUTPUT);
         }
         if (val == 2)//attach servo
         {
           myservos[pin].attach(pin);
         }
         if (val == 3)//detach servo
         {
           myservos[pin].detach();
         }
       }
       if ( cmd == 1)//getdigital
       {
         Serial.print(pin);
         Serial.print(",");
         Serial.print(digitalRead(pin));
         Serial.print("*");
       }
       if ( cmd == 4)//setdigital
       {
         digitalWrite(pin, val);
       }

       if ( cmd == 5)//setanalog
       {
         analogWrite(pin, val);
       }

       if ( cmd == 2)//getanalog
       {
         analogRead(pin);
         delay(10);
         Serial.print(pin + 14);
         Serial.print(",");
         Serial.print(analogRead(pin));
         Serial.print("*");
       }
       if ( cmd == 6)//setservo
       {
         myservos[pin].write(val) ;
         delay(15);
       }

       if ( cmd == 7)//settone
       {
         if (val == 0)
         {
           noTone(pin);
         }
         else
         {
           tone(pin, val);
         }
       }

       if ( cmd == 3)//getpulse
       {
         Serial.print(pin);
         Serial.print(",");
         Serial.print(pulseIn(pin, val));
         Serial.print("*");
       }

       }
     }
   }   // end or lbRun()

   void checkPot()
   {
   if (  analogRead(4) > 500 )  // check for value too high
   {
           Serial.print("help Brian, he is far too Hot");
           // a numeric alternative could be Serial.print("10000,10000,*");
           // or anything that the LB program checks for in serial messages
          Serial.print("*");
          pinMode(13, OUTPUT);
          for(int i = 0 ; i<5 ; i++ )
          {
          digitalWrite(13, HIGH) ;
          delay( 200) ;
          digitalWrite(13, LOW) ;
          delay( 200) ;
          }  // end of loop
          } // end of if clause

   }  // end of checkpot()


 


The Liberty BASIC code in the following post will use this SKETCH to read and write to the Arduino.
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program Arduino.bas
« Reply #73 on: Aug 18th, 2017, 1:08pm »

Arduino.bas

Code to leverage the community SKETCH


Code:
    ' Command       Pin Range          Value to send           Response
    '====================================================================
    ' GetDigital       0-13                -                   pin,0 or 1
    ' The port is set to input and the pullup resistor set high,
    ' ground the pin via a switch/sensor to pull it low.

    ' GetAnalog        0-5 (analog)        -                   pin,0-1023 0-5v
    ' The analog pins 0-5 return 0-1023 measuring 0-5v on the pin, connect
    ' pots, LDRs, Thermistors or any resistance based sensor.

    ' GetPWM           0-13               0 or 1               pin,microseconds
    ' Sending 0 will measure the low pulse 1 will measure the high pulse,
    ' connect gyros and accelerometers that provide PWM output.

    ' SetDigital       0-13               0 or 1               -
    ' This will set the pin HIGH or LOW use with LEDs or driver electronics
    ' to switch relays or pulse motors.

    ' SetPWM(analog)   3,5,6,9,10,11      0-255                -
    ' This sets the PWM ratio on any of the legal pins from 0% HIGH to 100% HIGH
    ' connect LEDs or with driver electronics control motot speed.

    ' AddServo         0-13               -                    -
    ' Servos must first be assigned a pin, this disables PWM on pins 9 and 10

    ' SetServo         0-13               0-180                -
    ' This sets the servo angle in degrees. But many electronic motor control (ESCs) and gyro
    ' gadgets use this form of PWM output. Forward and reverse motor speed control and gyro
    ' stabilised servo control are all possible.

    ' DelServo         0-13               -                    -
    ' Servos must be detached for the pin to be reused, when all are detached pin 9 and 10
    ' are reenabled for PWM

    ' SetTone          0-13               Hz 31-4978           -
    ' Only one pin can output a tone at any time, sending 0 silences the tone.

    ' Ping             0-13               -                    pin,microseconds
    ' This pings an ultrasonic transducer, divide the result by 29 then 2 to get cm distance





    nomainwin
    dim port$(256)      'com port name list
    dim cmd$(10)
    cmd$(1)="AddServo"
    cmd$(2)="GetDigital"
    cmd$(3)="GetAnalog"
    cmd$(4)="GetPWM"
    cmd$(5)="SetDigital"
    cmd$(6)="SetPWM"
    cmd$(7)="SetServo"
    cmd$(8)="SetTone"
    cmd$(9)="Ping"
    cmd$(10)="DelServo"

    dim pin$(20)
    for n= 0 to 13
    pin$(n+1)=str$(n)
    next

    dim val$(20)
    val$(1)="AsLOW"     'value of 0 sent
    val$(2)="AsHIGH"    'value of 1 sent
    val$(3)="AsSlider"  'value taken from slider, 0-255 for PWM 0-180 for servo
    val$(4)="AsNumeric" 'value taken fro textbox
    val$(5)="None"      'value of 0 sent

    global Port,Cmd,Pin,Val,Buffer$,Slider

    Port=0
    Slider=128

    WindowWidth = 550
    WindowHeight = 195
    UpperLeftX=int((DisplayWidth-WindowWidth)/2)
    UpperLeftY=int((DisplayHeight-WindowHeight)/2)

    combobox #main.cbport, port$(, portClick,    5,  80,  50, 100
    statictext #main.stport, "Com Port",   5,  60, 60,  20
    combobox #main.cbcmd, cmd$(, cmdClick,   60,  80,  90, 100
    statictext #main.stcmd, "Command",  60,  60,  60,  20
    combobox #main.cbpin, pin$(, pinClick,  155,  80,  40, 100
    statictext #main.stpin, "Pin", 155,  60,  20,  20
    combobox #main.cbval, val$(, valClick, 200,  80,  80,  20
    statictext #main.starg, "Argument", 200,  60,  135,  20
    textbox #main.tbvalue, 290,80,75,25
    statictext #main.stval, "Value", 290,  60,  135,  20
    button #main.send,"Send",send, UL, 290,  125,  75,  25
    textbox #main.tbrequest, 375,  80, 150,  25
    statictext #main.strequest, "Request", 375,  60,  60,  20
    textbox #main.tbresponse, 375,  125, 150,  25
    statictext #main.stresponse, "Response", 375,  105,  60,  20
    graphicbox #main.gbslider, 10, 125, 256, 19
    statictext #main.st01, "0", 5, 105, 10, 15
    statictext #main.st02, "50", 130, 105, 20, 15
    statictext #main.st03, "100", 250, 105, 20, 15



    open "Arduino simple interface" for window as #main
    #main "trapclose quit"
    #main.gbslider "down"
    #main.gbslider "fill lightgray"
    #main.gbslider "backcolor black"
    #main.gbslider "line 0 8 256 8"
    #main.gbslider "place ";Slider-4;" 0 ; boxfilled  ";Slider+4;" 17"
    #main.gbslider "when leftButtonMove mouse"
    #main.gbslider "when leftButtonDown mouse"
    #main.gbslider "when characterInput key"

    'find out what com ports are available and load the combobox
    call getPorts
    'we need an endless loop to clear out the serial buffer Arduino only stores 64 bytes
    while 1
        scan
        call getresponse
    wend

    'left and right arrow keys nudge the slider
    sub key h$,k$
        key=asc(right$(k$,1))
        if key=_VK_LEFT then Slider=Slider-1
        if key=_VK_RIGHT then Slider=Slider+1
        call display h$
    end sub

    'mouse moves the slider
    sub mouse h$,x,y
        Slider = x
        call display h$
    end sub

    'update the slider display, map the value and put it in the textbox
    'then send the change request
    sub display h$
        if Slider > 255 then Slider = 255
        if Slider < 0 then Slider = 0
        #main.st02, str$(Slider)
        #main.gbslider "fill lightgray"
        #main.gbslider "line 0 8 256 8"
        #main.gbslider "place ";Slider-4;" 0 ; boxfilled  ";Slider+4;" 17"
        #main.cbval "selectionindex? i"
        if Cmd >= 5 and Cmd <=7 and i=3 then
            if Cmd=6 then
                #main.tbvalue int(Slider/1.42)'0-180
            else
                #main.tbvalue Slider'0-255
            end if
            call send h$
        end if
    end sub

    'Subs to handle comboboxes=================================================

    'what command did the user click,if it needs no argument set val to 0
    sub cmdClick h$
        #main.cbcmd "selectionindex? i"
        Cmd=i-1
        if (Cmd>=0 and Cmd<=3) or (Cmd>=8 and Cmd<=9) then
            #main.cbval "selectindex 5"
            #main.tbvalue 0
        end if
    end sub

    'what pin was selected
    sub pinClick h$
        #main.cbpin "selectionindex? i"
        Pin=i-1
    end sub

    'where have we to take the value from, slider,textbox or pre defined
    sub valClick h$
        #main.cbval "selectionindex? i"
        Val=i-1
        if Val=0 or Val=1 then #main.tbvalue Val
        if Val=2 then #main.tbvalue Slider
        if Val=3 or Val=4 then #main.tbvalue 0
        if Val=3 then #main.tbvalue "!setfocus"
    end sub

    'send the request if the button is clicked
    sub send h$
        #main.tbvalue "!contents? v$"
        Val=val(v$)
        #main.tbresponse ""
        msg$=str$(Cmd)+","
        msg$=msg$+right$("00"+str$(Pin),2)+","
        msg$=msg$+right$("0000"+str$(Val),4)+"*"
        #main.tbrequest msg$
        #port msg$
    end sub

    'suck the input buffer dry, keep the remnants of the message if the whole
    'message has not been received
    sub getresponse
        if Port then
            if lof(#port)>0 then
                Buffer$=Buffer$+input$(#port, lof(#port))
                endofdata=instr(Buffer$,"*",1)
                [loop]
                if endofdata>0 then
                    'we have a valid end
                    dat$=left$(Buffer$,endofdata-1)
                    Buffer$=right$(Buffer$,len(Buffer$)-endofdata)
                    pin=val(word$(dat$,1,","))
                    dat=val(word$(dat$,2,","))
                    #main.tbresponse pin;" ";dat
                    endofdata=instr(Buffer$,"*",1)
                    if endofdata>0 then [loop]
                end if
            end if
        end if
    end sub

    'Subs to handle the com port ==============================================
    sub portClick h$
        'take com port combobox input, open choosen com port
        #main.cbport "selection? p$"
        if Port then close #port
        if p$<>"" then
            open p$;":9600,n,8,1,ds0,cs0,rs" for random as #port
            Port=1
            call delay 500
        end if
    end sub

    sub getPorts
        'test first 32 ports and load combobox list for valid serial ports
        index=1
        for p = 1 to 32
            oncomerror [trap]
            open "Com";str$(p);":9600,n,8,1,ds0,cs0,rs" for random as #com
            port$(index)="Com";str$(p)
            index=index+1
            close #com

            [trap]
            oncomerror
        next
        #main.cbport, "reload"
        'now if there is only one port open it
        if port$(1)<>"" and port$(2)="" then
            open port$(1);":9600,n,8,1,ds0,cs0,rs" for random as #port
            Port=1
            #main.cbport, "selectindex 1"
            call delay 500
        else
            #main.cbport, "selectindex 0"
        end if
    end sub

    sub delay m
        CallDLL #kernel32, "Sleep", m As ulong, Sleep As void
    end sub

    sub quit h$
        close #main
        if Port then close #port
        end
    end sub




 
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5526
xx Re: Sample Program slotmach.bas
« Reply #74 on: Aug 18th, 2017, 2:29pm »

slotmach.bas


Changed slightly plenty of scope for improvement. Made the images move through the graphicbox and made the randomness slightly different. The concept of three wheels which might move differently if the student wishes.



Code:
    'slotmach.bas - a sample program for Liberty BASIC v1.3

    'Here is a simple slot machine demo created by Carl Gundel
    'Copyright 1997 Shoptalk Systems
    'Feel free to use this code in any Liberty BASIC project
    nomainwin

    loadbmp "cherry", "bmp\cherry.bmp"
    loadbmp "bar", "bmp\bar.bmp"
    loadbmp "lemon", "bmp\lemon.bmp"

    'Store our bitmaps in three wheels
    'with a repeating, but random, twelve image patern
    dim image$(12,3)
    for x = 1 to 12
        for w = 1 to 3
            i=int(rnd(0)*3+1)
            select case i
                case 1
                    image$(x,w) = "bar"
                case 2
                    image$(x,w) = "cherry"
                case 3
                    image$(x,w) = "lemon"
            end select
        next w
    next x

    'Here is our window code
    WindowWidth = 360
    WindowHeight = 255
    graphicbox #main.gb1, 22, 61, 88, 65
    graphicbox #main.gb2, 134, 61, 88, 65
    graphicbox #main.gb3, 238, 61, 88, 65
    button #main, "Pull", [pullLever], UL, 278, 186, 56, 25
    open "Slot Machine" for window_nf as #main
    #main "trapclose [quit]"

    'starting position
    #main.gb1 "down ; drawbmp ";image$(1,1);" 0 0"
    #main.gb2 "down ; drawbmp ";image$(1,2);" 0 0"
    #main.gb3 "down ; drawbmp ";image$(1,3);" 0 0"
    wait



[pullLever]   'the user pulled the lever


    'Put your animation code in here.
    'Roll the wheels a random number of times
    'you might roll them independently
    'you might add sounds with playwave
    for x = 1 to int(rnd(0)*12+1)
        while y<50
            #main.gb1 "cls;drawbmp "; image$(x,1); " 0 ";y
            #main.gb2 "cls;drawbmp "; image$(x,2); " 0 ";y
            #main.gb3 "cls;drawbmp "; image$(x,3); " 0 ";y
            y=y+1
        wend
        y=-50
    next x
    if x=13 then x=12
    'roll to final resting place
    for y= -50 to 0
        #main.gb1 "cls;drawbmp "; image$(x,1); " 0 ";y
        #main.gb2 "cls;drawbmp "; image$(x,2); " 0 ";y
        #main.gb3 "cls;drawbmp "; image$(x,3); " 0 ";y
    next


[checkwin]
    wait

[quit]
    close #main
    end

 
User IP Logged

Pages: 1 ... 3 4 5 6 7  Notify Send Topic Print
« Previous Topic | Next Topic »

Rules|Home|Help|Search|Recent Posts|Notification

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls