home *** CD-ROM | disk | FTP | other *** search
/ Microsoft Programmer's Library 1.3 / Microsoft-Programers-Library-v1.3.iso / sampcode / fortran / sortdemo.for < prev    next >
Encoding:
Text File  |  1988-12-08  |  29.2 KB  |  934 lines
  1. $NOTRUNCATE
  2. $STORAGE:2
  3.         INTERFACE TO INTEGER*2 FUNCTION KbdCharIn
  4.      +  [ALIAS: 'KBDCHARIN']
  5.      +  (CHARDATA,
  6.      +   IoWait [VALUE],
  7.      +   KbdHandle [VALUE])
  8.  
  9.         INTEGER*2 CHARDATA(10)*1, IoWait, KbdHandle
  10.  
  11.         END
  12.  
  13.         INTERFACE TO INTEGER*2 FUNCTION DosBeep
  14.      +  [ALIAS: 'DOSBEEP']
  15.      +  (Frequency [VALUE],
  16.      +   Duration [VALUE])
  17.  
  18.         INTEGER*2 Frequency, Duration
  19.  
  20.         END
  21.  
  22.         INTERFACE TO INTEGER*2 FUNCTION DosGetDateTime
  23.      +  [ALIAS: 'DOSGETDATETIME']
  24.      +  (DateTime)
  25.  
  26.         INTEGER*1 DateTime(11)
  27.  
  28.         END
  29.         INTERFACE TO INTEGER*2 FUNCTION DosSleep
  30.      +  [ALIAS: 'DOSSLEEP']
  31.      +  (TimeInterval [VALUE])
  32.  
  33.         INTEGER*4 TimeInterval
  34.  
  35.         END
  36.  
  37.         INTERFACE TO INTEGER*2 FUNCTION VioScrollDn
  38.      +  [ALIAS: 'VIOSCROLLDN']
  39.      +  (TopRow [VALUE],
  40.      +   LeftCol [VALUE],
  41.      +   BotRow [VALUE],
  42.      +   RightCol [VALUE],
  43.      +   Lines [VALUE],
  44.      +   Cell,
  45.      +   VioHandle [VALUE])
  46.  
  47.         INTEGER*2 TopRow, LeftCol, BotRow, RightCol
  48.         INTEGER*2 Lines, Cell, VioHandle
  49.  
  50.         END
  51.  
  52.         INTERFACE TO INTEGER*2 FUNCTION VioWrtCharStrAtt
  53.      +  [ALIAS: 'VIOWRTCHARSTRATT']
  54.      +  (CharString,
  55.      +   Length [VALUE],
  56.      +   Row [VALUE],
  57.      +   Column [VALUE],
  58.      +   Attr,
  59.      +   VioHandle [VALUE])
  60.  
  61.         CHARACTER*80 CharString
  62.         INTEGER*2 Length, Row, Column, Attr*1, VioHandle
  63.  
  64.         END
  65.  
  66.         INTERFACE TO INTEGER*2 FUNCTION VioReadCellStr
  67.      +  [ALIAS: 'VIOREADCELLSTR']
  68.      +  (CellStr,
  69.      +   Length,
  70.      +   Row [VALUE],
  71.      +   Column [VALUE],
  72.      +   VioHandle [VALUE])
  73.  
  74.         CHARACTER*8000 CellStr
  75.         INTEGER*2 Length, Row, Column, VioHandle
  76.  
  77.         END
  78.  
  79.         INTERFACE TO INTEGER*2 FUNCTION VioWrtCellStr
  80.      +  [ALIAS: 'VIOWRTCELLSTR']
  81.      +  (CellStr,
  82.      +   Length [VALUE],
  83.      +   Row [VALUE],
  84.      +   Column [VALUE],
  85.      +   VioHandle [VALUE])
  86.  
  87.         CHARACTER*8000 CellStr
  88.         INTEGER*2 Length, Row, Column, VioHandle
  89.  
  90.         END
  91.  
  92.         INTERFACE TO INTEGER*2 FUNCTION VioWrtNCell
  93.      +  [ALIAS: 'VIOWRTNCELL']
  94.      +  (Cell,
  95.      +   Times [VALUE],
  96.      +   Row [VALUE],
  97.      +   Column [VALUE],
  98.      +   VioHandle [VALUE])
  99.  
  100.         INTEGER*2 Cell, Times, Row, Column, VioHandle
  101.  
  102.         END
  103.  
  104.         INTERFACE TO INTEGER*2 FUNCTION VioGetCurPos
  105.      +  [ALIAS: 'VIOGETCURPOS']
  106.      +  (Row,
  107.      +   Column,
  108.      +   VioHandle [VALUE])
  109.  
  110.         INTEGER*2 Row, Column, VioHandle
  111.  
  112.         END
  113.  
  114.         INTERFACE TO INTEGER*2 FUNCTION VioSetCurPos
  115.      +  [ALIAS: 'VIOSETCURPOS']
  116.      +  (Row [VALUE],
  117.      +   Column [VALUE],
  118.      +   VioHandle [VALUE])
  119.  
  120.         INTEGER*2 Row, Column, VioHandle
  121.  
  122.         END
  123.  
  124.         INTERFACE TO INTEGER*2 FUNCTION VioGetMode
  125.      +  [ALIAS: 'VIOGETMODE']
  126.      +  (MODE,
  127.      +   VioHandle [VALUE])
  128.  
  129.         INTEGER*2 MODE(6), VioHandle
  130.  
  131.         END
  132.  
  133.         INTERFACE TO INTEGER*2 FUNCTION VioSetMode
  134.      +  [ALIAS: 'VIOSETMODE']
  135.      +  (MODE,
  136.      +   VioHandle [VALUE])
  137.  
  138.         INTEGER*2 MODE(6), VioHandle
  139.  
  140.         END
  141.  
  142.       PROGRAM SortDemo
  143. C                                 SORTDEMO
  144. C This program graphically demonstrates six common sorting algorithms.  It
  145. C prints 25 or 43 horizontal bars, all of different lengths and all in random
  146. C order, then sorts the bars from smallest to longest.
  147. C
  148. C The program also uses SOUND statements to generate different pitches,
  149. C depending on the location of the bar being printed. Note that the SOUND
  150. C statements delay the speed of each sorting algorithm so you can follow
  151. C the progress of the sort. Therefore, the times shown are for comparison
  152. C only. They are not an accurate measure of sort speed.
  153. C
  154. C If you use these sorting routines in your own programs, you may notice
  155. C a difference in their relative speeds (for example, the exchange
  156. C sort may be faster than the shell sort) depending on the number of
  157. C elements to be sorted and how "scrambled" they are to begin with.
  158. C
  159.       IMPLICIT INTEGER*2(a-z)
  160.       CHARACTER cellstr*8000
  161.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  162.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  163.       DIMENSION mode(6),wmode(6)
  164.       DATA length,mode(1)/8000,12/
  165.       gbg = VioGetCurPos(crow,ccol,0)
  166.       gbg = VioReadCellStr(cellstr,length,0,0,0)
  167.       gbg = VioGetMode(mode,0)
  168.       DO 100 i=1,6
  169.            mode(i)= mode(i)
  170. 100   CONTINUE
  171. C
  172. C If monochrome or color burst disabled, use one color
  173. C
  174.       IF((.not. btest(mode(2),0)).OR.(btest(mode(2),2))) MaxColors=1
  175. C
  176. C First try 43 lines on VGA, then EGA. If neither, use 25 lines.
  177. C
  178.       IF(wmode(4).NE.43) THEN
  179.         wmode(4)=43
  180.         wmode(5)=640
  181.         wmode(6)=350
  182.         IF(VioSetMode(wmode,0).NE.0) THEN
  183.           wmode(5)=720
  184.           wmode(6)=400
  185.           IF(VioSetMode(wmode,0).NE.0) THEN
  186.             gbg=VioGetMode(wmode,0)
  187.             MaxBars=25
  188.             wmode(4)=25
  189.             gbg=VioSetMode(wmode,0)
  190.           ENDIF
  191.         ENDIF
  192.       ENDIF  
  193.       CALL Initialize
  194.       CALL SortMenu
  195.       IF(mode(4).NE.MaxBars) gbg = VioSetMode(mode,0)
  196.       gbg = VioWrtCellStr(cellstr,length,0,0,0)
  197.       gbg = VioSetCurPos(crow,ccol,0)
  198.       END
  199.  
  200.       BLOCK DATA
  201.       IMPLICIT INTEGER*2(a-z)
  202.       LOGICAL Sound
  203.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  204.       DATA MaxBars/43/,MaxColors/15/,Sound/.TRUE./,Pause/30/
  205.       END
  206.  
  207.       SUBROUTINE BoxInit
  208. C
  209. C =============================== BoxInit ====================================
  210. C    Calls the DrawFrame procedure to draw the frame around the sort menu,
  211. C    then prints the different options stored in the OptionTitle array.
  212. C ============================================================================
  213. C
  214.       IMPLICIT INTEGER*2(a-z)
  215.       INTEGER*1 COLOR
  216.       PARAMETER (COLOR=15,FIRSTMENU=1,LEFT=48,LINELENGTH=30,NLINES=18,
  217.      +           WIDTH=80-LEFT)
  218.       CHARACTER Factor*4,menu(NLINES)*30
  219.       LOGICAL Sound
  220.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  221.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  222.       DATA menu/
  223.      +      '     FORTRAN Sorting Demo',
  224.      +      ' ',
  225.      +      'Insertion',
  226.      +      'Bubble',
  227.      +      'Heap',
  228.      +      'Exchange',
  229.      +      'Shell',
  230.      +      'Quick',
  231.      +      ' ',
  232.      +      'Toggle Sound: ',
  233.      +      ' ',
  234.      +      'Pause Factor: ',
  235.      +      '<   (Slower)',
  236.      +      '>   (Faster)',
  237.      +      ' ',
  238.      +      'Type first character of',
  239.      +      'choice ( I B H E S Q T < > )',
  240.      +      'or ESC key to end program: '/
  241. C
  242.       CALL DrawFrame (1,LEFT-3,WIDTH+3,22)
  243. C
  244.       DO 100 i=1,NLINES
  245.         gbg = VioWrtCharStrAtt(menu(i),LINELENGTH,FIRSTMENU + i,
  246.      +                         LEFT,COLOR,0)
  247. 100   CONTINUE
  248.       WRITE(Factor,'(I2.2)')Pause/30
  249.       gbg = VioWrtCharStrAtt(Factor,len(Factor),13,LEFT+14,COLOR,0)
  250. C
  251. C Erase the speed option if the length of the Pause is at a limit
  252. C
  253.       IF(Pause.EQ.900) THEN
  254.         gbg = VioWrtCharStrAtt('            ',12,14,LEFT,COLOR,0)
  255.       ELSEIF(Pause.EQ.0) THEN
  256.         gbg = VioWrtCharStrAtt('            ',12,15,LEFT,COLOR,0)
  257.       ENDIF
  258. C
  259. C Print the current value for Sound:
  260. C
  261.       IF(Sound) THEN
  262.         gbg = VioWrtCharStrAtt('ON ',3,11,LEFT+14,COLOR,0)
  263.       ELSE
  264.         gbg = VioWrtCharStrAtt('OFF',3,11,LEFT+14,COLOR,0)
  265.       ENDIF
  266. C
  267.       RETURN
  268.       END
  269.  
  270.       SUBROUTINE BubbleSort
  271. C
  272. C ============================== BubbleSort ==================================
  273. C    The BubbleSort algorithm cycles through SortArray, comparing adjacent
  274. C    elements and swapping pairs that are out of order.  It continues to
  275. C    do this until no pairs are swapped.
  276. C ============================================================================
  277. C
  278.       IMPLICIT INTEGER*2(a-z)
  279.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  280.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  281. C
  282.       limit = MaxBars
  283. 1     CONTINUE
  284.       switch = 0
  285.       DO 100 row=1,limit-1
  286. C
  287. C Two adjacent elements are out of order, so swap their values
  288. C and redraw those two bars:
  289. C
  290.         IF(SortArray(BARLENGTH,row).GT.SortArray(BARLENGTH,row+1)) THEN
  291.           CALL SwapSortArray(row,row+1)
  292.           CALL SwapBars(row,row+1)
  293.           switch = row
  294.         ENDIF
  295. 100   CONTINUE
  296. C
  297. C Sort on next pass only to where the last switch was made:
  298. C
  299.       limit = switch
  300.       IF(switch.NE.0) GO TO 1
  301.       RETURN
  302.       END
  303.  
  304.       SUBROUTINE DrawFrame(Top,Left,Width,Height)
  305. C
  306. C ============================== DrawFrame ===================================
  307. C   Draws a rectangular frame using the high-order ASCII characters ╔ (201) ,
  308. C   ╗ (187) , ╚ (200) , ╝ (188) , ║ (186) , and ═ (205).
  309. C ============================================================================
  310. C
  311.       IMPLICIT INTEGER*2(a-z)
  312. C
  313.       CHARACTER tempstr*80
  314.       INTEGER*1 Attr,COLOR
  315.       PARAMETER (ULEFT=201,URIGHT=187,LLEFT=200,LRIGHT=188,
  316.      +           VERTICAL=186,HORIZONTAL=205,SPACE=32,COLOR=15)
  317. C
  318.       Attr=COLOR
  319.       CellAttr=ishl(COLOR,8)
  320.       bottom=Top+Height-1
  321.       right=Left+Width-1
  322.       gbg = VioWrtNCell(ior(CellAttr,ULEFT),1,Top,Left,0)
  323.       gbg = VioWrtNCell(ior(CellAttr,HORIZONTAL),
  324.      +                  Width-2,Top,Left+1,0)
  325.       gbg = VioWrtNCell(ior(CellAttr,URIGHT),1,Top,right,0)
  326.       tempstr(1:1)=char(VERTICAL)
  327.       DO 100 i=2,Width-1
  328.         tempstr(i:i)=char(SPACE)
  329. 100   CONTINUE
  330.       tempstr(Width:Width)=char(VERTICAL)
  331.       DO 200 i=1,Height-2
  332.         gbg = VioWrtCharStrAtt(tempstr,Width,i+Top,Left,COLOR,0)
  333. 200   CONTINUE
  334.       gbg = VioWrtNCell(ior(CellAttr,LLEFT),1,bottom,Left,0)
  335.       gbg = VioWrtNCell(ior(CellAttr,HORIZONTAL),
  336.      +                  Width-2,bottom,Left+1,0)
  337.       gbg = VioWrtNCell(ior(CellAttr,LRIGHT),1,bottom,right,0)
  338.       RETURN
  339.       END
  340.  
  341.       SUBROUTINE ElapsedTime(CurrentRow)
  342. C
  343. C ============================= ElapsedTime ==================================
  344. C    Prints seconds elapsed since the given sorting routine started.
  345. C    Note that this time includes both the time it takes to redraw the
  346. C    bars plus the pause while the SOUND statement plays a note, and
  347. C    thus is not an accurate indication of sorting speed.
  348. C ============================================================================
  349. C
  350.       IMPLICIT INTEGER*2(a-z)
  351.       CHARACTER Timing*7
  352.       INTEGER*1 DateTime(12),COLOR
  353.       INTEGER*4 time0,time1
  354.       LOGICAL Sound
  355.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  356.       COMMON /time/time0
  357.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  358.       PARAMETER (COLOR=15,FIRSTMENU=1,LEFT=48)
  359.       gbg = DosGetDateTime(DateTime)
  360.       time1=DateTime(1)*360000+
  361.      +      DateTime(2)*6000+
  362.      +      DateTime(3)*100+
  363.      +      DateTime(4)
  364.       WRITE(Timing,'(F7.2)')float(time1-time0)/100.
  365. C
  366. C Print the number of seconds elapsed
  367. C
  368.       gbg = VioWrtCharStrAtt(Timing,len(Timing),Select+FIRSTMENU+3,
  369.      +                       LEFT+15,COLOR,0)
  370. C
  371.       IF(Sound) gbg = DosBeep(60*CurrentRow,32)
  372.       gbg = DosSleep(int4(Pause))
  373.       RETURN
  374.       END
  375.  
  376.       SUBROUTINE ExchangeSort
  377. C
  378. C ============================= ExchangeSort =================================
  379. C   The ExchangeSort compares each element in SortArray - starting with
  380. C   the first element - with every following element.  If any of the
  381. C   following elements is smaller than the current element, it is exchanged
  382. C   with the current element and the process is repeated for the next
  383. C   element in SortArray.
  384. C ============================================================================
  385. C
  386.       IMPLICIT INTEGER*2(a-z)
  387.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  388.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  389. C
  390.       DO 100 Row=1,MaxBars-1
  391.         SmallestRow = Row
  392.         DO 200 j=Row+1,MaxBars
  393.           IF(SortArray(BARLENGTH,j) .LT. 
  394.      +       SortArray(BARLENGTH,SmallestRow)) THEN
  395.             SmallestRow = j
  396.             CALL ElapsedTime(j)
  397.           ENDIF
  398. 200     CONTINUE
  399.         IF(SmallestRow.GT.Row) THEN
  400. C
  401. C       Found a row shorter than the current row, so swap those
  402. C       two array elements:
  403. C
  404.           CALL SwapSortArray(Row,SmallestRow)
  405.           CALL SwapBars(Row,SmallestRow)
  406.         ENDIF
  407. 100   CONTINUE
  408.       RETURN
  409.       END
  410.  
  411.       SUBROUTINE HeapSort
  412. C
  413. C =============================== HeapSort ===================================
  414. C  The HeapSort procedure works by calling two other procedures - PercolateUp
  415. C  and PercolateDown.  PercolateUp turns SortArray into a "heap," which has
  416. C  the properties outlined in the diagram below:
  417. C
  418. C                               SortArray(1)
  419. C                               /          \
  420. C                    SortArray(2)           SortArray(3)
  421. C                   /          \            /          \
  422. C         SortArray(4)   SortArray(5)   SortArray(6)  SortArray(7)
  423. C          /      \       /       \       /      \      /      \
  424. C        ...      ...   ...       ...   ...      ...  ...      ...
  425. C
  426. C
  427. C  where each "parent node" is greater than each of its "child nodes"; for
  428. C  example, SortArray(1) is greater than SortArray(2) or SortArray(3),
  429. C  SortArray(3) is greater than SortArray(6) or SortArray(7), and so forth.
  430. C
  431. C  Therefore, once the first FOR...NEXT loop in HeapSort is finished, the
  432. C  largest element is in SortArray(1).
  433. C
  434. C  The second FOR...NEXT loop in HeapSort swaps the element in SortArray(1)
  435. C  with the element in MaxRow, rebuilds the heap (with PercolateDown) for
  436. C  MaxRow - 1, then swaps the element in SortArray(1) with the element in
  437. C  MaxRow - 1, rebuilds the heap for MaxRow - 2, and continues in this way
  438. C  until the array is sorted.
  439. C ============================================================================
  440. C
  441.       IMPLICIT INTEGER*2(a-z)
  442.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  443.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  444. C
  445.       DO 100 i=2,MaxBars
  446.         CALL PercolateUp(i)
  447. 100   CONTINUE
  448. C
  449.       DO 200 i=MaxBars,2,-1
  450.         CALL SwapSortArray(1,i)
  451.         CALL SwapBars(1,i)
  452.         CALL PercolateDown(i-1)
  453. 200   CONTINUE
  454.       RETURN
  455.       END
  456.  
  457.       SUBROUTINE Initialize
  458. C
  459. C ============================== Initialize ==================================
  460. C    Initializes the SortBackup and OptionTitle arrays.  It also calls the
  461. C    BoxInit procedure.
  462. C ============================================================================
  463. C
  464.       IMPLICIT INTEGER*2(a-z)
  465.       INTEGER*1 DateTime(11)
  466.       LOGICAL Sound
  467.       REAL Seed,SRand
  468.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  469.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  470. C
  471.       DIMENSION temparray(43)
  472.       BARLENGTH = 1
  473.       BARCOLOR = 2
  474.       DO 100 i=1,MaxBars
  475.         temparray(i) = i
  476. 100   CONTINUE
  477. C
  478. C Seed the random-number generator.
  479. C
  480.       gbg = DosGetDateTime(DateTime)
  481.       Seed = DateTime(1)*3600+DateTime(2)*60+DateTime(3)
  482.       Seed = SRand(Seed/86400.*259199.)
  483. C
  484.       MaxIndex = MaxBars
  485.       DO 200 i=1,MaxBars
  486. C
  487. C Find a random element in TempArray between 1 and MaxIndex,
  488. C then assign the value in that element to LengthBar
  489. C
  490.         index = RANDLIM(1,MaxIndex)
  491.         lengthbar = temparray(index)
  492. C
  493. C Overwrite the value in TempArray(Index) with the value in
  494. C TempArray(MaxIndex) so the value in TempArray(Index) is
  495. C chosen only once:
  496. C
  497.         temparray(index) = temparray(MaxIndex)
  498. C
  499. C Decrease the value of MaxIndex so that TempArray(MaxIndex) can't
  500. C be chosen on the next pass through the loop:
  501. C
  502.         MaxIndex = MaxIndex - 1
  503. C
  504.         SortBackup(BARLENGTH,i) = LengthBar
  505.         IF(MaxColors.EQ.1) THEN
  506.           SortBackup(BARCOLOR,i) = 7
  507.         ELSE  
  508.           SortBackup(BARCOLOR,i) = mod(LengthBar,MaxColors) + 1
  509.         ENDIF
  510. 200   CONTINUE
  511.       CALL cls
  512. C Assign values in SortBackup to SortArray and draw unsorted bars on the screen.
  513.       CALL Reinitialize
  514. C Draw frame for the sort menu and print options.
  515.       CALL BoxInit
  516.       RETURN
  517.       END
  518.  
  519.       SUBROUTINE InsertionSort
  520. C
  521. C ============================= InsertionSort ================================
  522. C   The InsertionSort procedure compares the length of each successive
  523. C   element in SortArray with the lengths of all the preceding elements.
  524. C   When the procedure finds the appropriate place for the new element, it
  525. C   inserts the element in its new place, and moves all the other elements
  526. C   down one place.
  527. C ============================================================================
  528. C
  529.       IMPLICIT INTEGER*2(a-z)
  530.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  531.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  532.       DIMENSION TempArray(2)
  533.       DO 100 Row=2,MaxBars
  534.         TempArray(BARLENGTH) = SortArray(BARLENGTH,Row)
  535.         TempArray(BARCOLOR) = SortArray(BARCOLOR,Row)
  536.         DO 200 j=Row,2,-1
  537. C
  538. C As long as the length of the j-1st element is greater than the
  539. C length of the original element in SortArray(Row), keep shifting
  540. C the array elements down:
  541. C
  542.           IF(SortArray(BARLENGTH,j - 1).GT.TempArray(BARLENGTH)) THEN
  543.             SortArray(BARLENGTH,j) = SortArray(BARLENGTH,j - 1)
  544.             SortArray(BARCOLOR,j) = SortArray(BARCOLOR,j - 1)
  545.             CALL PrintOneBar(j)
  546.             CALL ElapsedTime(j)
  547.           ELSE
  548.             GO TO 201
  549.           ENDIF
  550. 200     CONTINUE
  551. 201   CONTINUE
  552. C
  553. C Insert the original value of SortArray(Row) in SortArray(j):
  554. C
  555.       SortArray(BARLENGTH,j) = TempArray(BARLENGTH)
  556.       SortArray(BARCOLOR,j) = TempArray(BARCOLOR)
  557.       CALL PrintOneBar(j)
  558.       CALL ElapsedTime(j)
  559. 100   CONTINUE
  560.       RETURN
  561.       END
  562.  
  563. C
  564. C ============================ PercolateDown =================================
  565. C   The PercolateDown procedure restores the elements of SortArray from 1 to
  566. C   MaxLevel to a "heap" (see the diagram with the HeapSort procedure).
  567. C ============================================================================
  568. C
  569.       SUBROUTINE PercolateDown(MaxLevel)
  570.       IMPLICIT INTEGER*2(a-z)
  571.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  572. C
  573.       i = 1
  574. C
  575. C Move the value in SortArray(1) down the heap until it has reached
  576. C its proper node (that is, until it is less than its parent node
  577. C or until it has reached MaxLevel, the bottom of the current heap):
  578. C
  579. 1     CONTINUE
  580. C Get the subscript for the child node.
  581.       Child = 2 * i
  582. C
  583. C Reached the bottom of the heap, so exit this procedure:
  584. C
  585.       IF(Child.GT.MaxLevel) RETURN
  586. C
  587. C If there are two child nodes, find out which one is bigger:
  588. C
  589.       IF(Child+1.LE.MaxLevel) THEN
  590.         IF(SortArray(BARLENGTH,Child+1).GT.SortArray(BARLENGTH,Child))
  591.      +    Child=Child+1
  592.       ENDIF
  593. C
  594. C Move the value down if it is still not bigger than either one of
  595. C its children:
  596. C
  597.       IF(SortArray(BARLENGTH,i).LT.SortArray(BARLENGTH,Child)) THEN
  598.         CALL SwapSortArray(i,Child)
  599.         CALL SwapBars(i,Child)
  600.         i = Child
  601.       ELSE
  602. C
  603. C Otherwise, SortArray has been restored to a heap from 1 to
  604. C MaxLevel, so exit:
  605. C
  606.         RETURN
  607.       ENDIF
  608.       GO TO 1
  609.       END
  610.  
  611.       SUBROUTINE PercolateUp(MaxLevel)
  612. C
  613. C ============================== PercolateUp =================================
  614. C   The PercolateUp procedure converts the elements from 1 to MaxLevel in
  615. C   SortArray into a "heap" (see the diagram with the HeapSort procedure).
  616. C ============================================================================
  617. C
  618.       IMPLICIT INTEGER*2(a-z)
  619.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  620. C
  621.       i = MaxLevel
  622. C
  623. C Move the value in SortArray(MaxLevel) up the heap until it has
  624. C reached its proper node (that is, until it is greater than either
  625. C of its child nodes, or until it has reached 1, the top of the heap):
  626. C
  627. 1     CONTINUE
  628.       IF(i.EQ.1) RETURN
  629. C Get the subscript for the parent node.
  630.       Parent = i / 2
  631. C
  632. C The value at the current node is still bigger than the value at
  633. C its parent node, so swap these two array elements:
  634. C
  635.       IF(SortArray(BARLENGTH,i).GT.SortArray(BARLENGTH,Parent)) THEN
  636.         CALL SwapSortArray(Parent,i)
  637.         CALL SwapBars(Parent,i)
  638.         i = Parent
  639.         GO TO 1
  640.       ENDIF
  641. C
  642. C Otherwise, the element has reached its proper place in the heap,
  643. C so exit this procedure:
  644. C
  645.       RETURN
  646.       END
  647.  
  648.       SUBROUTINE PrintOneBar(Row)
  649. C
  650. C ============================== PrintOneBar =================================
  651. C  Prints SortArray(BARLENGTH,Row) at the row indicated by the Row
  652. C  parameter, using the color in SortArray(BARCOLOR,Row)
  653. C ============================================================================
  654. C
  655.       IMPLICIT INTEGER*2(a-z)
  656.       PARAMETER (BLOCK=223,SPACE=16#0720)
  657.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  658.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  659. C
  660.       gbg = VioWrtNCell(ior(ishl(SortArray(BARCOLOR,ROW),8),BLOCK),
  661.      +                  SortArray(BARLENGTH,Row),Row,1,0)
  662.       blanks=MaxBars-SortArray(BARLENGTH,Row)
  663.       IF(blanks.GT.0)
  664.      +  gbg = VioWrtNCell(SPACE,blanks,Row,SortArray(BARLENGTH,Row)+1,0)
  665.       RETURN
  666.       END
  667.  
  668.       SUBROUTINE QuickSort(Low,High)
  669.       IMPLICIT INTEGER*2(a-z)
  670.       PARAMETER (LOG2MAXBARS=6)
  671.       INTEGER*1 StackPtr,Upper(LOG2MAXBARS),Lower(LOG2MAXBARS)
  672.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  673.       Lower(1)=Low
  674.       Upper(1)=High
  675.       StackPtr=1
  676. 100   CONTINUE
  677.       IF(Lower(StackPtr).GE.Upper(StackPtr)) THEN
  678.         StackPtr = StackPtr - 1
  679.       ELSE
  680.         i = Lower(StackPtr)
  681.         j = Upper(StackPtr)
  682.         Pivot = SortArray(BARLENGTH,j)
  683. 200     CONTINUE
  684. 300     IF(i.LT.j.AND.SortArray(BARLENGTH,i).LE.Pivot) THEN
  685.           i = i + 1
  686.           GO TO 300
  687.         ENDIF
  688. 400     IF(j.GT.i.AND.SortArray(BARLENGTH,j).GE.Pivot) THEN
  689.           j = j - 1
  690.           GO TO 400
  691.         ENDIF
  692.         IF(i.LT.j)THEN
  693.           CALL SwapSortArray(i,j)
  694.           CALL SwapBars(i,j)
  695.        ENDIF
  696.         IF(i.LT.j) GO TO 200
  697.         j = Upper(StackPtr)
  698.         CALL SwapSortArray(i,j)
  699.         CALL SwapBars(i,j)
  700.         IF(i-Lower(StackPtr).LT.Upper(StackPtr)-i) THEN
  701.           Lower(StackPtr+1) = Lower(StackPtr)
  702.           Upper(StackPtr+1) = i - 1
  703.           Lower(StackPtr) = i + 1
  704.         ELSE
  705.           Lower(StackPtr+1) = i + 1
  706.           Upper(StackPtr+1) = Upper(StackPtr)
  707.           Upper(StackPtr) = i - 1
  708.         ENDIF
  709.         StackPtr = StackPtr + 1
  710.       ENDIF
  711.       IF(StackPtr.GT.0) GO TO 100
  712.       RETURN
  713.       END
  714.  
  715.       INTEGER FUNCTION RandLim (Lo,Hi)
  716.       IMPLICIT INTEGER*2(a-z)
  717.       REAL Seed,SRand,X
  718.       Seed = mod(int(Seed)*7141+54773,259200)
  719.       RandLim = Lo+(Hi-Lo+1)*Seed/259200
  720.       RETURN
  721. C
  722. C    REAL FUNCTION SRand (Seed)
  723. C    initializes either generator (Seed = 0. to 259199.)
  724. C
  725.       ENTRY SRand (X)
  726.       SRand = X
  727.       Seed = X
  728.       RETURN
  729.       END
  730.  
  731.       SUBROUTINE Reinitialize
  732. C
  733. C ============================== Reinitialize ================================
  734. C   Restores the array SortArray to its original unsorted state while
  735. C   displaying the unsorted color bars.
  736. C ============================================================================
  737. C
  738.       IMPLICIT INTEGER*2(a-z)
  739.       INTEGER*1 DateTime(11)
  740.       INTEGER*4 time0
  741.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  742.       COMMON /time/time0
  743.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  744. C
  745.       DO 100 row=1,MaxBars
  746.         SortArray(BARLENGTH,row)=SortBackup(BARLENGTH,row)
  747.         SortArray(BARCOLOR,row)=SortBackup(BARCOLOR,row)
  748.         CALL PrintOneBar(row)
  749. 100   CONTINUE
  750.       gbg = DosGetDateTime(DateTime)
  751.       time0=DateTime(1)*360000+
  752.      +      DateTime(2)*6000+
  753.      +      DateTime(3)*100+
  754.      +      DateTime(4)
  755.       RETURN
  756.       END
  757.  
  758.       SUBROUTINE ShellSort
  759. C
  760. C =============================== ShellSort ==================================
  761. C  The ShellSort procedure is similar to the BubbleSort procedure.  However,
  762. C  ShellSort begins by comparing elements that are far apart (separated by
  763. C  the value of the Offset variable, which is initially half the distance
  764. C  between the first and last element), then comparing elements that are
  765. C  closer together (when Offset is one, the last iteration of this procedure
  766. C  is merely a bubble sort).
  767. C ============================================================================
  768. C
  769.       IMPLICIT INTEGER*2(a-z)
  770.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  771.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  772. C
  773. C Set comparison offset to half the number of records in SortArray:
  774. C
  775.       Offset = MaxBars / 2
  776. 1     CONTINUE
  777.       Limit = MaxBars - Offset
  778. 2     CONTINUE
  779. C Assume no switches at this offset.
  780.       Switch = 0
  781. C
  782. C Compare elements and switch ones out of order:
  783.       DO 100 Row=1,Limit
  784.         IF(SortArray(BARLENGTH,Row).GT.
  785.      +     SortArray(BARLENGTH,Row+Offset)) THEN
  786.           CALL SwapSortArray(Row,Row+Offset)
  787.           CALL SwapBars (Row, Row + Offset)
  788.           Switch = Row
  789.         ENDIF
  790. 100   CONTINUE
  791. C Sort on next pass only to where last switch was made:
  792.       Limit = Switch - Offset
  793.       IF(Switch.GT.0) GO TO 2
  794. C
  795. C No switches at last offset, try one half as big:
  796. C
  797.       Offset = Offset / 2
  798.       IF(Offset.GT.0) GO TO 1
  799.       RETURN
  800.       END
  801.  
  802.       SUBROUTINE SortMenu
  803. C
  804. C =============================== SortMenu ===================================
  805. C   The SortMenu procedure first calls the Reinitialize procedure to make
  806. C   sure the SortArray is in its unsorted form, then prompts the user to
  807. C   make one of the following choices:
  808. C
  809. C               * One of the sorting algorithms
  810. C               * Toggle sound on or off
  811. C               * Increase or decrease speed
  812. C               * End the program
  813. C ============================================================================
  814. C
  815.       IMPLICIT INTEGER*2(a-z)
  816.       PARAMETER (FIRSTMENU=1,LEFT=48,NLINES=18,SPACE=32)
  817.       CHARACTER inkey*1
  818.       INTEGER*1 chardata(10)
  819.       LOGICAL Sound
  820.       COMMON /misc/MaxBars,MaxColors,Sound,Pause
  821.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  822. C
  823. C     Locate the cursor
  824. C
  825.       gbg = VioSetCurPos(FIRSTMENU + NLINES, 75, 0)
  826. C
  827. 1     CONTINUE
  828.       gbg = KbdCharIn(chardata,0,0)
  829.       inkey=char(chardata(1))
  830.       IF(lge(inkey,'a').AND.lle(inkey,'z'))
  831.      +  inkey=char(ichar(inkey)-SPACE)
  832. C
  833. C        /* Branch to the appropriate procedure depending on the key typed: */
  834. C
  835.       IF(inkey.EQ.'I') THEN
  836.         Select = 0
  837.         CALL Reinitialize
  838.         CALL InsertionSort
  839.         CALL ElapsedTime(0)
  840.       ELSEIF(inkey.EQ.'B') THEN
  841.         Select = 1
  842.         CALL Reinitialize
  843.         CALL BubbleSort
  844.         CALL ElapsedTime(0)
  845.       ELSEIF(inkey.EQ.'H') THEN
  846.         Select = 2
  847.         CALL Reinitialize
  848.         CALL HeapSort
  849.         CALL ElapsedTime(0)
  850.       ELSEIF(inkey.EQ.'E') THEN
  851.         Select = 3
  852.         CALL Reinitialize
  853.         CALL ExchangeSort
  854.         CALL ElapsedTime(0)
  855.       ELSEIF(inkey.EQ.'S') THEN
  856.         Select = 4
  857.         CALL Reinitialize
  858.         CALL ShellSort
  859.         CALL ElapsedTime(0)
  860.       ELSEIF(inkey.EQ.'Q') THEN
  861.         Select = 5
  862.         CALL Reinitialize
  863.         CALL QuickSort (1, MaxBars)
  864.         CALL ElapsedTime(0)
  865.       ELSEIF(inkey.EQ.'T') THEN
  866. C
  867. C       Toggle the sound, then redraw the menu to clear any timing
  868. C       results (since they won't compare with future results):
  869. C
  870.         Sound=.NOT.Sound
  871.         CALL Boxinit
  872.       ELSEIF(inkey.EQ.'<') THEN
  873. C
  874. C       Increase pause length to slow down sorting time, then redraw
  875. C       the menu to clear any timing results (since they won't compare
  876. C       with future results):
  877. C
  878.         IF(Pause.NE.900) THEN
  879.           Pause = Pause + 30
  880.           CALL BoxInit
  881.         ENDIF
  882.       ELSEIF(inkey.EQ.'>') THEN
  883. C
  884. C       Decrease pause length to speed up sorting time, then redraw
  885. C       the menu to clear any timing results (since they won't compare
  886. C       with future results):
  887. C
  888.         IF(Pause.NE.0) THEN
  889.           Pause = Pause - 30
  890.           CALL BoxInit
  891.         ENDIF
  892.       ELSEIF(inkey.EQ.char(27)) THEN
  893. C
  894. C       User pressed ESC, so return to main:
  895. C
  896.         RETURN
  897.       ENDIF
  898.       GO TO 1
  899.       END
  900.  
  901.       SUBROUTINE SwapBars(Row1,Row2)
  902. C
  903. C =============================== SwapBars ===================================
  904. C   Calls PrintOneBar twice to switch the two bars in Row1 and Row2,
  905. C   then calls the ElapsedTime procedure.
  906. C ============================================================================
  907. C
  908.       IMPLICIT INTEGER*2(a-z)
  909. C
  910.       CALL PrintOneBar(Row1)
  911.       CALL PrintOneBar (Row2)
  912.       CALL ElapsedTime (Row1)
  913. C
  914.       RETURN
  915.       END
  916.  
  917.       SUBROUTINE SwapSortArray(i,j)
  918.       IMPLICIT INTEGER*2(a-z)
  919.       COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  920.       temp=SortArray(1,i)
  921.       SortArray(1,i)=SortArray(1,j)
  922.       SortArray(1,j)=temp
  923.       temp=SortArray(2,i)
  924.       SortArray(2,i)=SortArray(2,j)
  925.       SortArray(2,j)=temp
  926.       RETURN
  927.       END
  928.  
  929.       SUBROUTINE cls
  930.       IMPLICIT INTEGER*2(a-z)
  931.       gbg = VioScrollDn(0, 0, -1, -1, -1, 16#720, 0)
  932.       RETURN
  933.       END
  934.