Author Topic: Business BASIC Helper Library  (Read 16975 times)

Support

  • Administrator
  • *****
  • Posts: 1
    • View Profile
Business BASIC Helper Library
« on: May 04, 2015, 08:30:51 am »
Here are a few ProvideX Business Basic like functions that can be used to help with your conversion to Script BASIC.

' BB Function Helper Library


' BB_ATH - Business BASIC ATH() function
'
' Converts a text string of hex character pairs to ASCII values.
'
FUNCTION BB_ATH(HexStr)

  LOCAL LenHex, AsciiStr, HexTable, ScanPos, HiByte, LowByte
  LenHex = LEN(HexStr)
  IF LenHex % 2 = 0 THEN
    HexTable = "0123456789ABCDEF"
    FOR ScanPos = 1 TO LenHex STEP 2
      HiByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos, 1))) - 1
      LowByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos + 1, 1))) - 1
      IF ISINTEGER(HiByte) AND ISINTEGER(LowByte) THEN
        AsciiStr &= CHR(HiByte * 16 + LowByte)
      ELSE
        AsciiStr = ""
        GOTO Exit_For        
      END IF
    NEXT ScanPos
    Exit_For:
  ELSE
    AsciiStr = ""
  END IF
  BB_ATH = AsciiStr

END FUNCTION


' BB_CVS - Business Basic CVS() function
'
' Action:
'  1   = Remove Leading characters
'  2   = Remove Trailing characters
'  4   = Convert String to Upper Case
'  8   = Convert String to Lower Case
'  16  = Replace characters < 32 with the control character
'  32  = Replace multiple occurrence of the character with one
'  64  = * Replace $ with defined Windows currency symbol
'  128 = * Replace defined Windows currency, comma and thousand symbol
'  256 = * Ucase first char of each word, rest to lower
'    * = Not implemented yet.
'
FUNCTION BB_CVS(StrExpr, Action, CtrlChar)

  LOCAL Char, ExprLen, TempStr, ScanPos
  IF CtrlChar = undef THEN CtrlChar = " "
  Char = ASC(CtrlChar)
 
  ' Remove Leading characters
 IF (Action AND 1) THEN  
    ExprLen = LEN(StrExpr)
    IF CtrlChar = " " THEN
      StrExpr = LTRIM(StrExpr)
    ELSE
      TempStr = ""
      FOR ScanPos = 1 TO ExprLen
        IF MID(StrExpr, ScanPos, 1) <> CtrlChar THEN TempStr &= MID(StrExpr, ScanPos, 1)
      NEXT ScanPos
      StrExpr = TempStr
    END IF
  END IF
 
  ' Remove Trailing characters
 IF (Action AND 2) THEN  
    ExprLen = LEN(StrExpr)
    IF CtrlChar = " " THEN
      StrExpr = RTRIM(StrExpr)
    ELSE
      TempStr = ""
      FOR ScanPos = ExprLen TO 1 STEP - 1
        IF MID(StrExpr, ScanPos, 1) = CtrlChar THEN TempStr = LEFT(StrExpr, ScanPos - 1)
      NEXT ScanPos
      IF LEN(TempStr) THEN StrExpr = TempStr
    END IF
  END IF
 
  ' Convert String to Upper Case
 IF (Action AND 4) THEN  
    StrExpr = UCASE(StrExpr)
  END IF
 
  ' Convert String to Lower Case
 IF (Action AND 8) THEN  
    StrExpr = LCASE(StrExpr)
  END IF
 
  ' Replace characters < 32 with the control character
 IF (Action AND 16) THEN  
    FOR ScanPos = 1 TO LEN(StrExpr)
         IF ASC(MID(StrExpr, ScanPos, 1)) < 32 THEN StrExpr = LEFT(StrExpr, ScanPos -1) & CtrlChar & MID(StrExpr, ScanPos + 1)
    NEXT ScanPos
  END IF
 
  ' Replace multiple occurence of the character with one
 IF (Action AND 32) THEN  
    HitCnt = 0
    StartPos = 1
    NextPos:
    ScanPos = INSTR(StrExpr,CtrlChar,StartPos)
    IF ISINTEGER(ScanPos) THEN
      IF HitCnt THEN  
        IF ASC(MID(StrExpr, ScanPos,1)) = CtrlChar THEN TeStrExpr = LEFT(StrExpr, ScanPos -1) & MID(StrExpr, ScanPos + 1)
      ELSE
        HitCnt += 1
      END IF
      StartPos += 1
      GOTO NextPos
    END IF
  END IF        
  BB_CVS = StrExpr

END FUNCTION


' BB_DEC - Business BASIC DEC() function
'
' Returns a two's complement binary equivalent of the string.
'
FUNCTION BB_DEC(BinStr)                                  

  LOCAL i, d                                      
  FOR i = LEN(BinStr) TO 1 STEP -1                        
    d += ASC(MID(BinStr,i,1)) * 256 ^ ABS(i - LEN(BinStr))
  NEXT i                                                    
  BB_DEC = d                                                

END FUNCTION                                              


' BB_HTA - Business BASIC HTA() function
'
' Returns the hexadecimal text string of the pasted argument string.
'
FUNCTION BB_HTA(AsciiStr)
  LOCAL AsciiLen,ScanPos,HexStr
  AsciiLen = LEN(AsciiStr)
  IF AsciiLen THEN
    FOR ScanPos = 1 TO AsciiLen
      HexStr &= RIGHT("0" & HEX(ASC(MID(AsciiStr, ScanPos, 1))),2)
    NEXT ScanPos
  ELSE
    HexStr = ""
  END IF
  BB_HTA = HexStr
END FUNCTION


' BB_JUL - Business BASIC JUL() function
'
' Converts a date from year, month, day to a Julian date.
'
FUNCTION BB_JUL(Y,M,D)

  IF Y = undef AND M = undef AND D = undef THEN
    BB_JUL = NOW
  ELSE
    BB_JUL = TIMEVALUE(Y,M,D)
  END IF
 
END FUNCTION


' BB_LRC - Business Basic LRC() function.
'
' Returns a one byte string containing the longitudinal redundancy checksum of a character string.
'
FUNCTION BB_LRC(ArgStr)

  LOCAL ArgStrLen, ScanPos, LRCVal
  LRCVal = 0
  ArgStrLen = LEN(ArgStr)
  IF ArgStrLen THEN
    FOR ScanPos = 1 TO ArgStrLen
      LRCVal += LRCVal XOR ASC(MID(ArgStr, ScanPos, 1))
    NEXT ScanPos
    BB_LRC = CHR(LRCVal)
  ELSE
    BB_LRC = CHR(&H00)
  END IF

END FUNCTION


' BB_PAD - Business BASIC PAD() funtion
'
' Returns a character string of the length specified (NumExpr)
'
' NOTE: StrExpr    = String to be processed
'       NewLen     = Desired length of string
'       HowToPad   = This parameter defines how to pad the string
'                     0 - Pad on left  (right justify)
'                     1 - Pad on right (left justify)
'                     2 - Center in string
'       StrPad     = First character of this string used to pad StrExpr
'
FUNCTION BB_PAD(StrExpr,NewLen,HowToPad,StrPad)

  LOCAL StrExpr,NewLen,HowToPad,StrPad,PadVal,StrExprLen,ResultStr,RLPLen
  IF HowToPad = undef THEN
    PadVal = 1
  ELSE IF HowToPad = 0 OR UCASE(HowToPad) = "L" THEN
    PadVal = 0
  ELSE IF HowToPad = 1 OR UCASE(HowToPad) = "R" THEN  
    PadVal = 1
  ELSE IF HowToPad = 2 OR UCASE(HowToPad) = "C" THEN      
    PadVal = 2
  ELSE
    BB_ERR = 41
    BB_PAD = ""
    EXIT FUNCTION
  END IF
 
  IF StrPad = undef THEN StrPad = " "
  StrExprLen = LEN(StrExpr)
 
  IF PadVal = 0 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = RIGHT(StrExpr, NewLen)
    ELSE
      ResultStr = STRING(NewLen - StrExprLen, StrPad) & StrExpr
    END IF
  END IF

  IF PadVal = 1 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = LEFT(StrExpr, NewLen)
    ELSE
      ResultStr = StrExpr & STRING(NewLen - StrExprLen, StrPad)
    END IF
  END IF

  IF PadVal = 2 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = LEFT(StrExpr, NewLen)
    ELSE
      RLPLen = (NewLen - StrExprLen) / 2
      IF RLPLen % 2 THEN
        ResultStr = STRING(FIX(RLPLen),StrPad) & StrExpr & STRING(FIX(RLPLen) + 1,StrPad)
      ELSE
        ResultStr = STRING(RLPLen,StrPad) & StrExpr & STRING(RLPLen,StrPad)
      END IF
    ENDIF
  END IF

  BB_PAD = ResultStr
 
END FUNCTION


' BB_POS - Business Basic POS() function
'
' BB_POS follows these logic steps:
'
' 1. If stringA or StringB is null, return 0
' 2. Start with first byte in stringB if intA is positive, or the Nth byte
'    from the end of stringB if intA is negatine (-N).
' 3. If past either the begining or end of stringB then return 0
'    (or occurrence count if intB is 0)
' 4. Compare stringA with the substring at the current position in stringB.
'    The length of substring will be either the length of stringA or the
'    remainder of stringB, whichever is shorter.
' 5. If a given releationship is true and if this was the Nth successful
'    try (specified by intB=N) then return the current scan position.
' 6. If the relation was not satisfied then bump the scan position
'    (possibly backwards if intA is negative) and go to step 3 and try again.
'
' Relationship Operators:
'
' "="   -   Equal To
' "<"   -   Less Than
' ">"   -   Greater Than
' "<="  -   Less Than Or Equal To
' ">="  -   Greater Than Or Equal To
' "<>"  -   Not Equal To
' ":"   -   Equal to Any
' "^"   -   Not Equal To Any
'
FUNCTION BB_POS(MatchStr,ScanStr,Relate,IncVal,OccurVal)
 
  LOCAL LenMatchStr,LenScanStr,ScanPos,OccurCnt,Item,StartVal,EndVal
  IF Relate = undef THEN Relate = "="
  IF IncVal = undef  THEN IncVal = 1
  IF OccurVal = undef  THEN OccurVal = 1
  LenMatchStr = LEN(MatchStr)
  IF INSTR(":^", Relate) THEN LenMatchStr = 1
  LenScanStr = LEN(ScanStr)
  IF LenMatchStr = 0 OR LenScanStr = 0 OR OccurVal < 0 THEN
    BB_POS = 0
    EXIT FUNCTION
  END IF
  IF IncVal > 0 THEN
    StartVal = 1
    EndVal = LenScanStr
  ELSE
    StartVal = LenScanStr
    EndVal = 1
  END IF
  FOR ScanPos = StartVal TO EndVal STEP IncVal
    Item = MID(ScanStr, ScanPos, LenMatchStr)
    IF Relate = "=" THEN
      IF MatchStr = Item THEN OccurCnt += 1
    ELSE IF Relate = "<" THEN
      IF MatchStr < Item THEN OccurCnt += 1
    ELSE IF Relate = ">" THEN
      IF MatchStr > Item THEN OccurCnt += 1
    ELSE IF Relate = "<=" OR Relate = "=<" THEN
      IF MatchStr <= Item THEN OccurCnt += 1
    ELSE IF Relate = ">=" OR Relate = "=>" THEN
      IF MatchStr >= Item THEN OccurCnt += 1
    ELSE IF Relate = "<>" OR Relate = "><" THEN
      IF MatchStr <> Item THEN OccurCnt += 1
    ELSE IF Relate = ":" THEN
      IF INSTR(MatchStr, Item) THEN OccurCnt += 1
    ELSE IF Relate = "^" THEN
      IF NOT ISNUMERIC(INSTR(MatchStr, Item)) THEN OccurCnt += 1
    ELSE
      BB_POS = 0
      EXIT FUNCTION
    END IF
    IF OccurVal > 0 THEN
      IF OccurCnt = OccurVal THEN GOTO Done
    END IF
  NEXT ScanPos
 
  Done:
 
  IF OccurVal = 0 THEN
    BB_POS = OccurCnt
  ELSE IF OccurCnt THEN
    BB_POS = ScanPos
  ELSE
    BB_POS = 0  
  END IF
 
END FUNCTION
 
bbtest.sb
' bb.inc test script

IMPORT bb.inc


PRINT "HTA()\n"
hta = BB_HTA("Script BASIC")
PRINT hta,"\n\n"
PRINT "ATH()\n"
PRINT BB_ATH(hta),"\n\n"
PRINT "PAD()\n"
s = BB_PAD("BASIC",10,2," ")
PRINT "|" & s & "|\n\n"
PRINT "POS()\n"
s = "The quick brown fox"
' yields 5
PRINT BB_POS("q",s,"="),"\n"
' yields 0
PRINT BB_POS("z",s,"="),"\n"
' yields 13
PRINT BB_POS("o",s,"=") ,"\n"
' yields 18 - Scan from end (fox)
PRINT BB_POS("o",s,"=",-1),"\n"
' yields 18 - Second occurrence (fox)
PRINT BB_POS("o",s,"=",1,2),"\n"
' yields 13 - Checks every 2nd position
PRINT BB_POS("o",s,"=",2),"\n"
' yields 6 - "u" is first char. > "r"
PRINT BB_POS("r",s,"<"),"\n"
PRINT "CVS()\n"
s = "  sb  "
PRINT "|" & BB_CVS(s,3," "),"|\n"
PRINT "|" & BB_CVS(s,4,""),"|\n\n"
 
Output

jrs@laptop:~/sb/sb22/PHB$ time scriba bbtest.sb
HTA()
536372697074204241534943

ATH()
Script BASIC

PAD()
|  BASIC  |

POS()
5
0
13
18
18
13
6
CVS()
|sb|
|  SB  |


real   0m0.026s
user   0m0.022s
sys   0m0.004s
jrs@laptop:~/sb/sb22/PHB$

« Last Edit: December 06, 2017, 04:29:57 am by support »