Animated Qsort

[B+]

Well couldn't find an Animated Qsort so I whipped one up today:

' Animate Qsort.txt B+ 2021-05-02 from
' 1) Ascii Fireworks with Mainscreen Commands for Graphics Window.txt for JB B+ 2020-01-01
   '  Use: setup title$, desiredWidth, desiredHeight 'to setup a graphics window #gr
   'Then you can use these command substitutes for the graphics window:
   '  locate = call locateG characterColumn, characterRow
   '   print = call printG text$ '(strings only)
   '   input = call inputG prompt$, variable$ '(string variable only)
   '   color = call colorG fore$, back$ 'takes only string arguments
   '           for colors I set up function QBcolr$(colrNum) to return QB color string for numbers 0 to 15
   '     cls = call clsG 'clears to last colorG fore$, back$ used
   '    PLUS inkee$ is a global variable you have access to use like QB inkey$
   ' finish your code section with a wait command

call setup "Animate Qsort with Main Window Commands for Graphic Windows", 1200, 720 '100 x 30? characters 12X24 check
global maxCol, maxRow, nItems '<<< maxRow??? maxCol??? WTH why doesn't Globals in Setup work???????????????
maxRow = 30
maxCol = 100

' 2) Qsort for string array.txt for JB (B+=MGA) 2017-05-29
'    Adapted code from samples that came with JB that was
'    Adapted from Beginning Programming for Dummies by Wallace Wang

'setup your array with nItems = number of items you need to sort
nItems = 25
dim sa$(nItems) ' then tell JB the size of string array to make room for with DIM

'this is code I used to make up a bunch of funny words, and show a list before sort
call colorG "white", "red"
for i = 1 to nItems
   r = int(rnd(1) * 10) + 1
   for j = 1 to r
       r2 = int(rnd(1) * 26) + 1
       sa$(i) = sa$(i);mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", r2, 1)
   next
   'display list as we go
   call locateG 1, i
   call printG space$(30)
   call locateG 1, i
   call printG sa$(i)
next

'display list titles
call locateG 1, 27
call printG space$(30)
call locateG 1, 27
call printG "Initial Order"

call colorG "white", "blue"
call locateG 34, 27
call printG space$(30)
call locateG 34, 27
call printG "Processing..."

'this sorts the list
call QSort 1, nItems

' final display of sorted list
call colorG "black", "green"
for i = 1 to nItems
   call locateG 68, i
   call printG space$(30)
   call locateG 68, i
   call printG sa$(i)
next
call locateG 68, 27
call printG space$(30)
call locateG 68, 27
call printG "Sorted Order"
wait ' end code input section ==========================
end

' This is the best all purpose sort routine around, don't worry how it works, it just does!
' To use this sub rountine store all the string values you want to sort into sa$() array
' call Qsort with Start = 1 and Finish = number of Items in your array
sub QSort Start, Finish
   i = Start
   j = Finish
   x$ = sa$(int((i+j)/2))
   ' show your work
   for k = 1 to nItems
       if k = int((i+j)/2) then
           call colorG "white", "blue"
       else
           if k >= i and k <= j then call colorG "black", "white" else call colorG "white", "black"
       end if
       call locateG 34, k
       call printG space$(30)
       call locateG 34, k
       call printG sa$(k)
       call pause 10
   next
   while i <= j
       while sa$(i) < x$
           i = i + 1
           ' show your work
           for k = 1 to nItems
               if k = int((i+j)/2) then
                   call colorG "white", "blue"
               else
                   if k >= i and k <= j then call colorG "black", "white" else call colorG "white", "black"
               end if
               call locateG 34, k
               call printG space$(30)
               call locateG 34, k
               call printG sa$(k)
               call pause 10
           next
       wend
       while sa$(j) > x$
           j = j - 1
           ' show your work
           for k = 1 to nItems
               if k = int((i+j)/2) then
                   call colorG "white", "blue"
               else
                   if k >= i and k <= j then call colorG "black", "white" else call colorG "white", "black"
               end if
               call locateG 34, k
               call printG space$(30)
               call locateG 34, k
               call printG sa$(k)
               call pause 10
           next
       wend
       if i <= j then
           a$ = sa$(i)
           sa$(i) = sa$(j)
           sa$(j) = a$
           i = i + 1
           j = j - 1
       end if
       ' show your work
       for k = 1 to nItems
           if k = int((i+j)/2) then
               call colorG "white", "blue"
           else
               if k >= i and k <= j then call colorG "black", "white" else call colorG "white", "black"
           end if
           call locateG 34, k
           call printG space$(30)
           call locateG 34, k
           call printG sa$(k)
           call pause 10
       next
   wend
   if j > Start then call QSort Start, j
   if i < Finish then call QSort i, Finish
end sub

'setup graphics window with specified title$, width and height with handle #gr, AKA h$
sub setup title$, wWidth, wHeight
   global xmax, ymax  'screen width and height
   xmax = wWidth : ymax = wHeight  '<<<<<< set this as you need or from plug-in notes

   global cellW, cellH
   'do not mess with cellW and cellH globals for printing
   cellW = 12 'pixels wide for characters
   cellH = 24 'pixels high for characters

   global maxRow, maxCol
   'and then these are calculated from above globals
   maxCol = int(xmax / cellW)  'these control printing characters
   maxRow = int(ymax / cellH)

   global lastC, lastR 'for LocateG (locate), printG (print a line), lp (locate and print)
   lastC = 1 : lastR = 1

   'key events update globals with latest info
   global inkee$, h$

   h$ = "#gr"

   global wFG$, wBG$
   wFG$ = "white" : wBG$ = "black"

   nomainwin

   WindowWidth = xmax + 8
   WindowHeight = ymax + 32
   UpperLeftX = (DisplayWidth-WindowWidth) / 2
   UpperLeftY = (DisplayHeight-WindowHeight) / 2

   open title$ for graphics_nsb_nf as #gr
   #gr "trapclose quit"

   'fonts that don't work arial, tahoma, verdana
   '#gr "font arial ";cellW;" ";cellH
   '#gr "font dejavu_sans_mono ";cellW;" ";cellH

   'fonts that work
   '#gr "font courier_new ";cellW;" ";cellH
   #gr "font consolas ";cellW;" ";cellH

   '#gr "home"                  '< check drawing area
   '#gr "posxy w2 h2"           '<<<<<<<<<<<<<<<<<<
   'notice "Screen Drawing Check";chr$(13);"Size:" + chr$(13) + "Width (w2*2) = ";w2*2;",  Height (h2*2) = ";h2*2

   #gr "setfocus"
   #gr "when characterInput charIn"
   #gr "down"
   call colorG "white", "black"
   call clsG
end sub

sub printG mess$ 'print (with "line feed") for graphics window
   startR = lastR
   for i = 1 to len(mess$)
       scan
       call lp lastC, lastR, mid$(mess$, i, 1)
       if lastR <> startR then exit for
   next
   lastC = 1
   lastR = startR + 1
   if lastR > maxRow then lastR = maxRow 'yuck!
end sub

sub clsG  'cls for graphics window
   #gr "fill ";wBG$
   lastC = 1 : lastR = 1
end sub

sub colorG fore$, back$ 'set color fore and back to color string names, see QBcolr$ function
   wFG$ = fore$ : wBG$ = back$
   #gr "color ";wFG$
   #gr "backcolor ";wBG$
end sub

sub locateG x, y   'locate xColumnCell, yRowCell for printing
   if 0 < x and x < maxCol + 1 and 0 < y and y < maxRow + 1 then
       lastC = x
       lastR = y
   end if
end sub

sub inputG prmpt$, byref var$   'input for a graphics screen
   'prints prompt at lastC, lastR and leaves lastC = 1 lastR = pRow + 1

   inkee$ = "" 'clear last key (new fix for DE5)
   call lp lastC, lastR, prmpt$;"{"
   'this will update lastR and lastC to the starting point of input variable
   pRow = lastR : pCol = lastC 'save these for redrawing var
   call lp pCol, pRow, "}"
   OK$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz"
   OK$ = OK$+ chr$(8)+ chr$(27) + chr$(13) + "1234567890!@#$%^&*()_-+={}[]|\:;'<,>.?/"
   do
       scan
       if instr(OK$, inkee$) then
           if inkee$ = Chr$(8) then
               if t$ <> "" then
                   if Len(t$)=1 then t$="" else t$=Left$(t$,Len(t$)-1)
               end if
           else
               if inkee$=Chr$(13) or inkee$=Chr$(27) then
                   'new D5, I was expecting nothing in return for my esc
                   if inkee$ = chr$(27) then t$ = ""
                   exit do
               else
                   t$=t$;inkee$
               end if
           end if
           call lp pCol, pRow, t$;"} "
           inkee$ = ""
       end if
   loop until done
   var$ = t$
   lastC = 1 : lastR = pRow + 1
end sub

function QBcolr$(colrNum)
   select case colrNum
   case 0   : QBcolr$ = "black"
   case 1   : QBcolr$ = "darkblue"
   case 2   : QBcolr$ = "brown"
   case 3   : QBcolr$ = "darkcyan"
   case 4   : QBcolr$ = "darkred"
   case 5   : QBcolr$ = "darkpink"
   case 6   : QBcolr$ = "darkgreen"
   case 7   : QBcolr$ = "lightgray"
   case 8   : QBcolr$ = "darkgray"
   case 9   : QBcolr$ = "blue"
   case 10  : QBcolr$ = "green"
   case 11  : QBcolr$ = "cyan"
   case 12  : QBcolr$ = "red"
   case 13  : QBcolr$ = "pink"
   case 14  : QBcolr$ = "yellow"
   case 15  : QBcolr$ = "white"
   end select
end function

function rndColor$()
   rndColor$ = QBcolr$( int( rnd(0) * 16) )
end function

sub lp x, y, mess$ 'locate x, y : print mess$ lp = locate and print
   'if locate = x col and y row then and top left corner locates as 1, 1
   c = x - 1: r = y
   if 0 < x and x < maxCol + 1 and 0 < y and y < maxRow + 1 then
       #gr "place ";c * cellW;" ";r * cellH - 4
       #gr "|";mess$
       lastC = x + len(mess$)
       if lastC > maxCol then lastC = 1 : lastR = lastR + 1
       if lastR > maxRow then lastR = maxRow 'yuck!
   end if
end sub

sub cp y,cpText$ 'cp Center Print on line y the cpText$
   call lp int((maxCol - len(cpText$))/2 + 1.5), y, cpText$
   lastC = 1 : lastR = y + 1
end sub

sub at xPix, yPix, char$  'print a string at pixel x, y This pin point locating.
   #gr "place ";xPix;" ";yPix
   #gr "|";char$
end sub

sub pause mil   'tsh version has scan built-in
   t0 = time$("ms")
   while time$("ms") < t0 + mil : scan : wend
end sub

sub charIn hdl$, c$
   inkee$ = c$
end sub

sub quit hdl$
   timer 0
   close #gr
   end
end sub






Watch out for the "DORFLVGOMS"

[B+]

Qsort is recursive. Every time you see the screen start a new white section (sometimes just a line or 2), that is a new recursive call to Qsort over the white section that works it's way toward the blue "middle".