QB64.org Forum

Samples Gallery & Reference => Utilities => Topic started by: The Librarian on August 11, 2019, 12:51:49 pm

Title: _MEM Sort by SMcNeill
Post by: The Librarian on August 11, 2019, 12:51:49 pm
_MEM Sort

Contributor(s): @SMcNeill
Source: qb64 @ Freeformus
URL: http://qb64.freeforums.net/thread/28/mem-sort (http://qb64.freeforums.net/thread/28/mem-sort)
Tags: [_MEM] [sort]

Description:
The following routine is a quick and efficient way to sort almost any type of array, regardless of data type. (The one thing it doesn't sort is variable-length strings, as _MEM doesn't support those at all.)

Source Code:
Code: QB64: [Select]
  1. SCREEN _NEWIMAGE(1280, 720, 256)
  2.  
  3. DIM x(5) AS _BYTE
  4. DIM z(5) AS STRING * 5
  5.  
  6. 'Let's see if we can sort the integer array
  7. 'Initialize Data
  8. FOR i = 0 TO 5: x(i) = RND * 100: PRINT x(i),: NEXT: PRINT
  9. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  10.  
  11. 'Sort
  12. m = _MEM(x())
  13. Sort m
  14.  
  15. 'Result
  16. FOR i = 0 TO 5: PRINT x(i),: NEXT: PRINT
  17.  
  18. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  19.  
  20.  
  21. 'Try the same routine with a different data type array to sort
  22. 'Initialize Data
  23. FOR i = 0 TO 7: y(i) = RND * 100: PRINT y(i),: NEXT
  24. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  25.  
  26. 'Sort
  27. m = _MEM(y())
  28. Sort m
  29.  
  30. 'Result
  31. FOR i = 0 TO 7: PRINT y(i),: NEXT: PRINT
  32. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  33.  
  34.  
  35. 'To test with fixed length string arrays
  36. z(0) = "Doggy": z(1) = "Pudding": z(2) = "Frog ": z(3) = "test2": z(4) = "Test2": z(5) = "test1"
  37. FOR i = 0 TO 5: PRINT z(i),: NEXT: PRINT
  38. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  39.  
  40. m = _MEM(z())
  41. Sort m
  42.  
  43. 'Result
  44. FOR i = 0 TO 5: PRINT z(i),: NEXT: PRINT
  45.  
  46.  
  47.  
  48.  
  49. SUB Sort (m AS _MEM)
  50.     $IF 64BIT THEN
  51.         DIM ES AS _INTEGER64, EC AS _INTEGER64
  52.     $ELSE
  53.         DIM ES AS LONG, EC AS LONG
  54.     $END IF
  55.  
  56.     IF NOT m.TYPE AND 65536 THEN EXIT SUB 'We won't work without an array
  57.     IF m.TYPE AND 1024 THEN DataType = 10
  58.     IF m.TYPE AND 1 THEN DataType = DataType + 1
  59.     IF m.TYPE AND 2 THEN DataType = DataType + 2
  60.     IF m.TYPE AND 4 THEN IF m.TYPE AND 128 THEN DataType = DataType + 4 ELSE DataType = 3
  61.     IF m.TYPE AND 8 THEN IF m.TYPE AND 128 THEN DataType = DataType + 8 ELSE DataType = 5
  62.     IF m.TYPE AND 32 THEN DataType = 6
  63.     IF m.TYPE AND 512 THEN DataType = 7
  64.  
  65.     'Convert our offset data over to something we can work with
  66.     DIM m1 AS _MEM: m1 = _MEMNEW(LEN(ES))
  67.     _MEMPUT m1, m1.OFFSET, m.ELEMENTSIZE: _MEMGET m1, m1.OFFSET, ES 'Element Size
  68.     _MEMPUT m1, m1.OFFSET, m.SIZE: _MEMGET m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
  69.     _MEMFREE m1
  70.  
  71.     EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count.  We subtract 1 so our arrays start at 0 and not 1.
  72.     'And work with it!
  73.     DIM o AS _OFFSET, o1 AS _OFFSET, counter AS _UNSIGNED LONG
  74.  
  75.     SELECT CASE DataType
  76.         CASE 1 'BYTE
  77.             DIM temp1(-128 TO 127) AS _UNSIGNED LONG
  78.             DIM t1 AS _BYTE
  79.             i = 0
  80.             DO
  81.                 _MEMGET m, m.OFFSET + i, t1
  82.                 temp1(t1) = temp1(t1) + 1
  83.                 i = i + 1
  84.             LOOP UNTIL i > EC
  85.             i1 = -128
  86.             DO
  87.                 DO UNTIL temp1(i1) = 0
  88.                     _MEMPUT m, m.OFFSET + counter, i1 AS _BYTE
  89.                     counter = counter + 1
  90.                     temp1(i1) = temp1(i1) - 1
  91.                     IF counter > EC THEN EXIT SUB
  92.                 LOOP
  93.                 i1 = i1 + 1
  94.             LOOP UNTIL i1 > 127
  95.         CASE 2: 'INTEGER
  96.             DIM temp2(-32768 TO 32767) AS _UNSIGNED LONG
  97.             DIM t2 AS INTEGER
  98.             i = 0
  99.             DO
  100.                 _MEMGET m, m.OFFSET + i * 2, t2
  101.                 temp2(t2) = temp2(t2) + 1
  102.                 i = i + 1
  103.             LOOP UNTIL i > EC
  104.             i1 = -32768
  105.             DO
  106.                 DO UNTIL temp2(i1) = 0
  107.                     _MEMPUT m, m.OFFSET + counter * 2, i1 AS INTEGER
  108.                     counter = counter + 1
  109.                     temp2(i1) = temp2(i1) - 1
  110.                     IF counter > EC THEN EXIT SUB
  111.                 LOOP
  112.                 i1 = i1 + 1
  113.             LOOP UNTIL i1 > 32767
  114.         CASE 3 'SINGLE
  115.             DIM T3a AS SINGLE, T3b AS SINGLE
  116.             gap = EC
  117.             DO
  118.                 gap = 10 * gap \ 13
  119.                 IF gap < 1 THEN gap = 1
  120.                 i = 0
  121.                 swapped = 0
  122.                 DO
  123.                     o = m.OFFSET + i * 4
  124.                     o1 = m.OFFSET + (i + gap) * 4
  125.                     IF _MEMGET(m, o, SINGLE) > _MEMGET(m, o1, SINGLE) THEN
  126.                         _MEMGET m, o1, T3a
  127.                         _MEMGET m, o, T3b
  128.                         _MEMPUT m, o1, T3b
  129.                         _MEMPUT m, o, T3a
  130.                         swapped = -1
  131.                     END IF
  132.                     i = i + 1
  133.                 LOOP UNTIL i + gap > EC
  134.             LOOP UNTIL gap = 1 AND swapped = 0
  135.         CASE 4 'LONG
  136.             DIM T4a AS LONG, T4b AS LONG
  137.             gap = EC
  138.             DO
  139.                 gap = 10 * gap \ 13
  140.                 IF gap < 1 THEN gap = 1
  141.                 i = 0
  142.                 swapped = 0
  143.                 DO
  144.                     o = m.OFFSET + i * 4
  145.                     o1 = m.OFFSET + (i + gap) * 4
  146.                     IF _MEMGET(m, o, LONG) > _MEMGET(m, o1, LONG) THEN
  147.                         _MEMGET m, o1, T4a
  148.                         _MEMGET m, o, T4b
  149.                         _MEMPUT m, o1, T4b
  150.                         _MEMPUT m, o, T4a
  151.                         swapped = -1
  152.                     END IF
  153.                     i = i + 1
  154.                 LOOP UNTIL i + gap > EC
  155.             LOOP UNTIL gap = 1 AND swapped = 0
  156.         CASE 5 'DOUBLE
  157.             DIM T5a AS DOUBLE, T5b AS DOUBLE
  158.             gap = EC
  159.             DO
  160.                 gap = 10 * gap \ 13
  161.                 IF gap < 1 THEN gap = 1
  162.                 i = 0
  163.                 swapped = 0
  164.                 DO
  165.                     o = m.OFFSET + i * 8
  166.                     o1 = m.OFFSET + (i + gap) * 8
  167.                     IF _MEMGET(m, o, DOUBLE) > _MEMGET(m, o1, DOUBLE) THEN
  168.                         _MEMGET m, o1, T5a
  169.                         _MEMGET m, o, T5b
  170.                         _MEMPUT m, o1, T5b
  171.                         _MEMPUT m, o, T5a
  172.                         swapped = -1
  173.                     END IF
  174.                     i = i + 1
  175.                 LOOP UNTIL i + gap > EC
  176.             LOOP UNTIL gap = 1 AND swapped = 0
  177.         CASE 6 ' _FLOAT
  178.             DIM T6a AS _FLOAT, T6b AS _FLOAT
  179.             gap = EC
  180.             DO
  181.                 gap = 10 * gap \ 13
  182.                 IF gap < 1 THEN gap = 1
  183.                 i = 0
  184.                 swapped = 0
  185.                 DO
  186.                     o = m.OFFSET + i * 32
  187.                     o1 = m.OFFSET + (i + gap) * 32
  188.                     IF _MEMGET(m, o, _FLOAT) > _MEMGET(m, o1, _FLOAT) THEN
  189.                         _MEMGET m, o1, T6a
  190.                         _MEMGET m, o, T6b
  191.                         _MEMPUT m, o1, T6b
  192.                         _MEMPUT m, o, T6a
  193.                         swapped = -1
  194.                     END IF
  195.                     i = i + 1
  196.                 LOOP UNTIL i + gap > EC
  197.             LOOP UNTIL gap = 1 AND swapped = 0
  198.         CASE 7 'String
  199.             DIM T7a AS STRING, T7b AS STRING, T7c AS STRING
  200.             T7a = SPACE$(ES): T7b = SPACE$(ES): T7c = SPACE$(ES)
  201.             gap = EC
  202.             DO
  203.                 gap = INT(gap / 1.247330950103979)
  204.                 IF gap < 1 THEN gap = 1
  205.                 i = 0
  206.                 swapped = 0
  207.                 DO
  208.                     o = m.OFFSET + i * ES
  209.                     o1 = m.OFFSET + (i + gap) * ES
  210.                     _MEMGET m, o, T7a
  211.                     _MEMGET m, o1, T7b
  212.                     IF T7a > T7b THEN
  213.                         T7c = T7b
  214.                         _MEMPUT m, o1, T7a
  215.                         _MEMPUT m, o, T7c
  216.                         swapped = -1
  217.                     END IF
  218.                     i = i + 1
  219.                 LOOP UNTIL i + gap > EC
  220.             LOOP UNTIL gap = 1 AND swapped = false
  221.         CASE 8 '_INTEGER64
  222.             DIM T8a AS _INTEGER64, T8b AS _INTEGER64
  223.             gap = EC
  224.             DO
  225.                 gap = 10 * gap \ 13
  226.                 IF gap < 1 THEN gap = 1
  227.                 i = 0
  228.                 swapped = 0
  229.                 DO
  230.                     o = m.OFFSET + i * 8
  231.                     o1 = m.OFFSET + (i + gap) * 8
  232.                     IF _MEMGET(m, o, _INTEGER64) > _MEMGET(m, o1, _INTEGER64) THEN
  233.                         _MEMGET m, o1, T8a
  234.                         _MEMGET m, o, T8b
  235.                         _MEMPUT m, o1, T8b
  236.                         _MEMPUT m, o, T8a
  237.                         swapped = -1
  238.                     END IF
  239.                     i = i + 1
  240.                 LOOP UNTIL i + gap > EC
  241.             LOOP UNTIL gap = 1 AND swapped = 0
  242.         CASE 11: '_UNSIGNED _BYTE
  243.             DIM temp11(0 TO 255) AS _UNSIGNED LONG
  244.             DIM t11 AS _UNSIGNED _BYTE
  245.             i = 0
  246.             DO
  247.                 _MEMGET m, m.OFFSET + i, t11
  248.                 temp11(t11) = temp11(t11) + 1
  249.                 i = i + 1
  250.             LOOP UNTIL i > EC
  251.             i1 = 0
  252.             DO
  253.                 DO UNTIL temp11(i1) = 0
  254.                     _MEMPUT m, m.OFFSET + counter, i1 AS _UNSIGNED _BYTE
  255.                     counter = counter + 1
  256.                     temp11(i1) = temp11(i1) - 1
  257.                     IF counter > EC THEN EXIT SUB
  258.                 LOOP
  259.                 i1 = i1 + 1
  260.             LOOP UNTIL i1 > 255
  261.         CASE 12 '_UNSIGNED INTEGER
  262.             DIM temp12(0 TO 65535) AS _UNSIGNED LONG
  263.             DIM t12 AS _UNSIGNED INTEGER
  264.             i = 0
  265.             DO
  266.                 _MEMGET m, m.OFFSET + i * 2, t12
  267.                 temp12(t12) = temp12(t12) + 1
  268.                 i = i + 1
  269.             LOOP UNTIL i > EC
  270.             i1 = 0
  271.             DO
  272.                 DO UNTIL temp12(i1) = 0
  273.                     _MEMPUT m, m.OFFSET + counter * 2, i1 AS _UNSIGNED INTEGER
  274.                     counter = counter + 1
  275.                     temp12(i1) = temp12(i1) - 1
  276.                     IF counter > EC THEN EXIT SUB
  277.                 LOOP
  278.                 i1 = i1 + 1
  279.             LOOP UNTIL i1 > 65535
  280.         CASE 14 '_UNSIGNED LONG
  281.             DIM T14a AS _UNSIGNED LONG, T14b AS _UNSIGNED LONG
  282.             gap = EC
  283.             DO
  284.                 gap = 10 * gap \ 13
  285.                 IF gap < 1 THEN gap = 1
  286.                 i = 0
  287.                 swapped = 0
  288.                 DO
  289.                     o = m.OFFSET + i * 4
  290.                     o1 = m.OFFSET + (i + gap) * 4
  291.                     IF _MEMGET(m, o, _UNSIGNED LONG) > _MEMGET(m, o1, _UNSIGNED LONG) THEN
  292.                         _MEMGET m, o1, T14a
  293.                         _MEMGET m, o, T14b
  294.                         _MEMPUT m, o1, T14b
  295.                         _MEMPUT m, o, T14a
  296.                         swapped = -1
  297.                     END IF
  298.                     i = i + 1
  299.                 LOOP UNTIL i + gap > EC
  300.             LOOP UNTIL gap = 1 AND swapped = 0
  301.         CASE 18: '_UNSIGNED _INTEGER64
  302.             DIM T18a AS _UNSIGNED _INTEGER64, T18b AS _UNSIGNED _INTEGER64
  303.             gap = EC
  304.             DO
  305.                 gap = 10 * gap \ 13
  306.                 IF gap < 1 THEN gap = 1
  307.                 i = 0
  308.                 swapped = 0
  309.                 DO
  310.                     o = m.OFFSET + i * 8
  311.                     o1 = m.OFFSET + (i + gap) * 8
  312.                     IF _MEMGET(m, o, _UNSIGNED _INTEGER64) > _MEMGET(m, o1, _UNSIGNED _INTEGER64) THEN
  313.                         _MEMGET m, o1, T18a
  314.                         _MEMGET m, o, T18b
  315.                         _MEMPUT m, o1, T18b
  316.                         _MEMPUT m, o, T18a
  317.                         swapped = -1
  318.                     END IF
  319.                     i = i + 1
  320.                 LOOP UNTIL i + gap > EC
  321.             LOOP UNTIL gap = 1 AND swapped = 0
  322.     END SELECT
  323.