Task: Range extraction








VB: Public Function RangeExtraction(AList) As String

Const RangeDelim = "-"          
Dim result As String
Dim InRange As Boolean
Dim Posn, ub, lb, rangestart, rangelen As Integer

result = ""

ub = UBound(AList)
lb = LBound(AList)
Posn = lb
While Posn < ub
  rangestart = Posn
  rangelen = 0
  InRange = True
  
  While InRange
    rangelen = rangelen + 1
    If Posn = ub Then
      InRange = False
    Else
      InRange = (AList(Posn + 1) = AList(Posn) + 1)
      Posn = Posn + 1
    End If
  Wend
  If rangelen > 2 Then 
    result = result & "," & Format$(AList(rangestart)) & RangeDelim & Format$(AList(rangestart + rangelen - 1))
  Else 
    For i = rangestart To rangestart + rangelen - 1
      result = result & "," & Format$(AList(i))
    Next
  End If
  Posn = rangestart + rangelen
Wend
RangeExtraction = Mid$(result, 2) 
End Function


Public Sub RangeTest()


Dim MyList As Variant
MyList = Array(0, 1, 2, 4, 6, 7, 8, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 27, 28, 29, 30, 31, 32, 33, 35, 36, 37, 38, 39)
Debug.Print "a) "; RangeExtraction(MyList)


Dim MyOtherList(1 To 20) As Integer
MyOtherList(1) = -6
MyOtherList(2) = -3
MyOtherList(3) = -2
MyOtherList(4) = -1
MyOtherList(5) = 0
MyOtherList(6) = 1
MyOtherList(7) = 3
MyOtherList(8) = 4
MyOtherList(9) = 5
MyOtherList(10) = 7
MyOtherList(11) = 8
MyOtherList(12) = 9
MyOtherList(13) = 10
MyOtherList(14) = 11
MyOtherList(15) = 14
MyOtherList(16) = 15
MyOtherList(17) = 17
MyOtherList(18) = 18
MyOtherList(19) = 19
MyOtherList(20) = 20
Debug.Print "b) "; RangeExtraction(MyOtherList)
End Sub



Fortran:       SUBROUTINE IRANGE(TEXT)	
Could make this a function, but then a maximum text length returned would have to be specified.
       CHARACTER*(*) TEXT	
       INTEGER LOTS		
       PARAMETER (LOTS = 666)	
       INTEGER VAL(LOTS)	
       INTEGER N		
       INTEGER I,I1		
        N = 1		
        DO I = 1,LEN(TEXT)	
          IF (TEXT(I:I).EQ.",") N = N + 1	
        END DO			
        IF (N.LE.2) RETURN	
        IF (N.GT.LOTS) STOP "Too many values
        READ (TEXT,*) VAL(1:N)	
        TEXT = ""		
        L = 0			
        I1 = 1			
   10   IF (L.GT.0) CALL EMIT(",")	
        CALL SPLOT(VAL(I1))		
        DO I = I1 + 1,N			
          IF (VAL(I - 1) + 1 .NE. VAL(I)) EXIT	
        END DO				
        IF (I - I1 .GT. 2) THEN		
          CALL EMIT("-")		
          CALL SPLOT(VAL(I - 1))	
          I1 = I			
         ELSE			
          I1 = I1 + 1			
        END IF			
        IF (I.LE.N) GO TO 10	
       CONTAINS		
        SUBROUTINE EMIT(C)	
         CHARACTER*1 C		
          L = L + 1		
          IF (L.GT.LEN(TEXT)) STOP "Ran out of text
          TEXT(L:L) = C		
        END SUBROUTINE EMIT	
        SUBROUTINE SPLOT(N)	
         INTEGER N		
         CHARACTER*12 FIELD	
         INTEGER I		
          WRITE (FIELD,"(I0)") N
          DO I = 1,12		
            IF (FIELD(I:I).LE." ") EXIT	
            CALL EMIT(FIELD(I:I))	
          END DO		
        END SUBROUTINE SPLOT	
      END	

      PROGRAM POKE
      CHARACTER*(200) SOME
      SOME = "  0,  1,  2,  4,  6,  7,  8, 11, 12, 14,  "
     1      //"  15, 16, 17, 18, 19, 20, 21, 22, 23, 24,"
     2      //"25, 27, 28, 29, 30, 31, 32, 33, 35, 36,  "
     3      //"37, 38, 39                               "
      CALL IRANGE(SOME)
      WRITE (6,*) SOME
      END