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

Support

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

Code: Script BASIC
  1. ' BB Function Helper Library
  2.  
  3.  
  4. ' BB_ATH - Business BASIC ATH() function
  5. '
  6. ' Converts a text string of hex character pairs to ASCII values.
  7. '
  8. FUNCTION BB_ATH(HexStr)
  9.  
  10.   LOCAL LenHex, AsciiStr, HexTable, ScanPos, HiByte, LowByte
  11.   LenHex = LEN(HexStr)
  12.   IF LenHex % 2 = 0 THEN
  13.     HexTable = "0123456789ABCDEF"
  14.     FOR ScanPos = 1 TO LenHex STEP 2
  15.       HiByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos, 1))) - 1
  16.       LowByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos + 1, 1))) - 1
  17.       IF ISINTEGER(HiByte) AND ISINTEGER(LowByte) THEN
  18.         AsciiStr &= CHR(HiByte * 16 + LowByte)
  19.       ELSE
  20.         AsciiStr = ""
  21.         GOTO Exit_For        
  22.       END IF
  23.     NEXT ScanPos
  24.     Exit_For:
  25.   ELSE
  26.     AsciiStr = ""
  27.   END IF
  28.   BB_ATH = AsciiStr
  29.  
  30. END FUNCTION
  31.  
  32.  
  33. ' BB_CVS - Business Basic CVS() function
  34. '
  35. ' Action:
  36. '  1   = Remove Leading characters
  37. '  2   = Remove Trailing characters
  38. '  4   = Convert String to Upper Case
  39. '  8   = Convert String to Lower Case
  40. '  16  = Replace characters < 32 with the control character
  41. '  32  = Replace multiple occurrence of the character with one
  42. '  64  = * Replace $ with defined Windows currency symbol
  43. '  128 = * Replace defined Windows currency, comma and thousand symbol
  44. '  256 = * Ucase first char of each word, rest to lower
  45. '    * = Not implemented yet.
  46. '
  47. FUNCTION BB_CVS(StrExpr, Action, CtrlChar)
  48.  
  49.   LOCAL Char, ExprLen, TempStr, ScanPos
  50.   IF CtrlChar = undef THEN CtrlChar = " "
  51.   Char = ASC(CtrlChar)
  52.  
  53.   ' Remove Leading characters
  54.  IF (Action AND 1) THEN  
  55.     ExprLen = LEN(StrExpr)
  56.     IF CtrlChar = " " THEN
  57.       StrExpr = LTRIM(StrExpr)
  58.     ELSE
  59.       TempStr = ""
  60.       FOR ScanPos = 1 TO ExprLen
  61.         IF MID(StrExpr, ScanPos, 1) <> CtrlChar THEN TempStr &= MID(StrExpr, ScanPos, 1)
  62.       NEXT ScanPos
  63.       StrExpr = TempStr
  64.     END IF
  65.   END IF
  66.  
  67.   ' Remove Trailing characters
  68.  IF (Action AND 2) THEN  
  69.     ExprLen = LEN(StrExpr)
  70.     IF CtrlChar = " " THEN
  71.       StrExpr = RTRIM(StrExpr)
  72.     ELSE
  73.       TempStr = ""
  74.       FOR ScanPos = ExprLen TO 1 STEP - 1
  75.         IF MID(StrExpr, ScanPos, 1) = CtrlChar THEN TempStr = LEFT(StrExpr, ScanPos - 1)
  76.       NEXT ScanPos
  77.       IF LEN(TempStr) THEN StrExpr = TempStr
  78.     END IF
  79.   END IF
  80.  
  81.   ' Convert String to Upper Case
  82.  IF (Action AND 4) THEN  
  83.     StrExpr = UCASE(StrExpr)
  84.   END IF
  85.  
  86.   ' Convert String to Lower Case
  87.  IF (Action AND 8) THEN  
  88.     StrExpr = LCASE(StrExpr)
  89.   END IF
  90.  
  91.   ' Replace characters < 32 with the control character
  92.  IF (Action AND 16) THEN  
  93.     FOR ScanPos = 1 TO LEN(StrExpr)
  94.          IF ASC(MID(StrExpr, ScanPos, 1)) < 32 THEN StrExpr = LEFT(StrExpr, ScanPos -1) & CtrlChar & MID(StrExpr, ScanPos + 1)
  95.     NEXT ScanPos
  96.   END IF
  97.  
  98.   ' Replace multiple occurence of the character with one
  99.  IF (Action AND 32) THEN  
  100.     HitCnt = 0
  101.     StartPos = 1
  102.     NextPos:
  103.     ScanPos = INSTR(StrExpr,CtrlChar,StartPos)
  104.     IF ISINTEGER(ScanPos) THEN
  105.       IF HitCnt THEN  
  106.         IF ASC(MID(StrExpr, ScanPos,1)) = CtrlChar THEN TeStrExpr = LEFT(StrExpr, ScanPos -1) & MID(StrExpr, ScanPos + 1)
  107.       ELSE
  108.         HitCnt += 1
  109.       END IF
  110.       StartPos += 1
  111.       GOTO NextPos
  112.     END IF
  113.   END IF        
  114.   BB_CVS = StrExpr
  115.  
  116. END FUNCTION
  117.  
  118.  
  119. ' BB_DEC - Business BASIC DEC() function
  120. '
  121. ' Returns a two's complement binary equivalent of the string.
  122. '
  123. FUNCTION BB_DEC(BinStr)                                  
  124.  
  125.   LOCAL i, d                                      
  126.   FOR i = LEN(BinStr) TO 1 STEP -1                        
  127.     d += ASC(MID(BinStr,i,1)) * 256 ^ ABS(i - LEN(BinStr))
  128.   NEXT i                                                    
  129.   BB_DEC = d                                                
  130.  
  131. END FUNCTION                                              
  132.  
  133.  
  134. ' BB_HTA - Business BASIC HTA() function
  135. '
  136. ' Returns the hexadecimal text string of the pasted argument string.
  137. '
  138. FUNCTION BB_HTA(AsciiStr)
  139.   LOCAL AsciiLen,ScanPos,HexStr
  140.   AsciiLen = LEN(AsciiStr)
  141.   IF AsciiLen THEN
  142.     FOR ScanPos = 1 TO AsciiLen
  143.       HexStr &= RIGHT("0" & HEX(ASC(MID(AsciiStr, ScanPos, 1))),2)
  144.     NEXT ScanPos
  145.   ELSE
  146.     HexStr = ""
  147.   END IF
  148.   BB_HTA = HexStr
  149. END FUNCTION
  150.  
  151.  
  152. ' BB_JUL - Business BASIC JUL() function
  153. '
  154. ' Converts a date from year, month, day to a Julian date.
  155. '
  156. FUNCTION BB_JUL(Y,M,D)
  157.  
  158.   IF Y = undef AND M = undef AND D = undef THEN
  159.     BB_JUL = NOW
  160.   ELSE
  161.     BB_JUL = TIMEVALUE(Y,M,D)
  162.   END IF
  163.  
  164. END FUNCTION
  165.  
  166.  
  167. ' BB_LRC - Business Basic LRC() function.
  168. '
  169. ' Returns a one byte string containing the longitudinal redundancy checksum of a character string.
  170. '
  171. FUNCTION BB_LRC(ArgStr)
  172.  
  173.   LOCAL ArgStrLen, ScanPos, LRCVal
  174.   LRCVal = 0
  175.   ArgStrLen = LEN(ArgStr)
  176.   IF ArgStrLen THEN
  177.     FOR ScanPos = 1 TO ArgStrLen
  178.       LRCVal += LRCVal XOR ASC(MID(ArgStr, ScanPos, 1))
  179.     NEXT ScanPos
  180.     BB_LRC = CHR(LRCVal)
  181.   ELSE
  182.     BB_LRC = CHR(&H00)
  183.   END IF
  184.  
  185. END FUNCTION
  186.  
  187.  
  188. ' BB_PAD - Business BASIC PAD() funtion
  189. '
  190. ' Returns a character string of the length specified (NumExpr)
  191. '
  192. ' NOTE: StrExpr    = String to be processed
  193. '       NewLen     = Desired length of string
  194. '       HowToPad   = This parameter defines how to pad the string
  195. '                     0 - Pad on left  (right justify)
  196. '                     1 - Pad on right (left justify)
  197. '                     2 - Center in string
  198. '       StrPad     = First character of this string used to pad StrExpr
  199. '
  200. FUNCTION BB_PAD(StrExpr,NewLen,HowToPad,StrPad)
  201.  
  202.   LOCAL StrExpr,NewLen,HowToPad,StrPad,PadVal,StrExprLen,ResultStr,RLPLen
  203.   IF HowToPad = undef THEN
  204.     PadVal = 1
  205.   ELSE IF HowToPad = 0 OR UCASE(HowToPad) = "L" THEN
  206.     PadVal = 0
  207.   ELSE IF HowToPad = 1 OR UCASE(HowToPad) = "R" THEN  
  208.     PadVal = 1
  209.   ELSE IF HowToPad = 2 OR UCASE(HowToPad) = "C" THEN      
  210.     PadVal = 2
  211.   ELSE
  212.     BB_ERR = 41
  213.     BB_PAD = ""
  214.     EXIT FUNCTION
  215.   END IF
  216.  
  217.   IF StrPad = undef THEN StrPad = " "
  218.   StrExprLen = LEN(StrExpr)
  219.  
  220.   IF PadVal = 0 THEN
  221.     IF NewLen < StrExprLen THEN
  222.       ResultStr = RIGHT(StrExpr, NewLen)
  223.     ELSE
  224.       ResultStr = STRING(NewLen - StrExprLen, StrPad) & StrExpr
  225.     END IF
  226.   END IF
  227.  
  228.   IF PadVal = 1 THEN
  229.     IF NewLen < StrExprLen THEN
  230.       ResultStr = LEFT(StrExpr, NewLen)
  231.     ELSE
  232.       ResultStr = StrExpr & STRING(NewLen - StrExprLen, StrPad)
  233.     END IF
  234.   END IF
  235.  
  236.   IF PadVal = 2 THEN
  237.     IF NewLen < StrExprLen THEN
  238.       ResultStr = LEFT(StrExpr, NewLen)
  239.     ELSE
  240.       RLPLen = (NewLen - StrExprLen) / 2
  241.       IF RLPLen % 2 THEN
  242.         ResultStr = STRING(FIX(RLPLen),StrPad) & StrExpr & STRING(FIX(RLPLen) + 1,StrPad)
  243.       ELSE
  244.         ResultStr = STRING(RLPLen,StrPad) & StrExpr & STRING(RLPLen,StrPad)
  245.       END IF
  246.     ENDIF
  247.   END IF
  248.  
  249.   BB_PAD = ResultStr
  250.  
  251. END FUNCTION
  252.  
  253.  
  254. ' BB_POS - Business Basic POS() function
  255. '
  256. ' BB_POS follows these logic steps:
  257. '
  258. ' 1. If stringA or StringB is null, return 0
  259. ' 2. Start with first byte in stringB if intA is positive, or the Nth byte
  260. '    from the end of stringB if intA is negatine (-N).
  261. ' 3. If past either the begining or end of stringB then return 0
  262. '    (or occurrence count if intB is 0)
  263. ' 4. Compare stringA with the substring at the current position in stringB.
  264. '    The length of substring will be either the length of stringA or the
  265. '    remainder of stringB, whichever is shorter.
  266. ' 5. If a given releationship is true and if this was the Nth successful
  267. '    try (specified by intB=N) then return the current scan position.
  268. ' 6. If the relation was not satisfied then bump the scan position
  269. '    (possibly backwards if intA is negative) and go to step 3 and try again.
  270. '
  271. ' Relationship Operators:
  272. '
  273. ' "="   -   Equal To
  274. ' "<"   -   Less Than
  275. ' ">"   -   Greater Than
  276. ' "<="  -   Less Than Or Equal To
  277. ' ">="  -   Greater Than Or Equal To
  278. ' "<>"  -   Not Equal To
  279. ' ":"   -   Equal to Any
  280. ' "^"   -   Not Equal To Any
  281. '
  282. FUNCTION BB_POS(MatchStr,ScanStr,Relate,IncVal,OccurVal)
  283.  
  284.   LOCAL LenMatchStr,LenScanStr,ScanPos,OccurCnt,Item,StartVal,EndVal
  285.   IF Relate = undef THEN Relate = "="
  286.   IF IncVal = undef  THEN IncVal = 1
  287.   IF OccurVal = undef  THEN OccurVal = 1
  288.   LenMatchStr = LEN(MatchStr)
  289.   IF INSTR(":^", Relate) THEN LenMatchStr = 1
  290.   LenScanStr = LEN(ScanStr)
  291.   IF LenMatchStr = 0 OR LenScanStr = 0 OR OccurVal < 0 THEN
  292.     BB_POS = 0
  293.     EXIT FUNCTION
  294.   END IF
  295.   IF IncVal > 0 THEN
  296.     StartVal = 1
  297.     EndVal = LenScanStr
  298.   ELSE
  299.     StartVal = LenScanStr
  300.     EndVal = 1
  301.   END IF
  302.   FOR ScanPos = StartVal TO EndVal STEP IncVal
  303.     Item = MID(ScanStr, ScanPos, LenMatchStr)
  304.     IF Relate = "=" THEN
  305.       IF MatchStr = Item THEN OccurCnt += 1
  306.     ELSE IF Relate = "<" THEN
  307.       IF MatchStr < Item THEN OccurCnt += 1
  308.     ELSE IF Relate = ">" THEN
  309.       IF MatchStr > Item THEN OccurCnt += 1
  310.     ELSE IF Relate = "<=" OR Relate = "=<" THEN
  311.       IF MatchStr <= Item THEN OccurCnt += 1
  312.     ELSE IF Relate = ">=" OR Relate = "=>" THEN
  313.       IF MatchStr >= Item THEN OccurCnt += 1
  314.     ELSE IF Relate = "<>" OR Relate = "><" THEN
  315.       IF MatchStr <> Item THEN OccurCnt += 1
  316.     ELSE IF Relate = ":" THEN
  317.       IF INSTR(MatchStr, Item) THEN OccurCnt += 1
  318.     ELSE IF Relate = "^" THEN
  319.       IF NOT ISNUMERIC(INSTR(MatchStr, Item)) THEN OccurCnt += 1
  320.     ELSE
  321.       BB_POS = 0
  322.       EXIT FUNCTION
  323.     END IF
  324.     IF OccurVal > 0 THEN
  325.       IF OccurCnt = OccurVal THEN GOTO Done
  326.     END IF
  327.   NEXT ScanPos
  328.  
  329.   Done:
  330.  
  331.   IF OccurVal = 0 THEN
  332.     BB_POS = OccurCnt
  333.   ELSE IF OccurCnt THEN
  334.     BB_POS = ScanPos
  335.   ELSE
  336.     BB_POS = 0  
  337.   END IF
  338.  
  339. END FUNCTION
  340.  

bbtest.sb
Code: Script BASIC
  1. ' bb.inc test script
  2.  
  3. IMPORT bb.inc
  4.  
  5.  
  6. PRINT "HTA()\n"
  7. hta = BB_HTA("Script BASIC")
  8. PRINT hta,"\n\n"
  9. PRINT "ATH()\n"
  10. PRINT BB_ATH(hta),"\n\n"
  11. PRINT "PAD()\n"
  12. s = BB_PAD("BASIC",10,2," ")
  13. PRINT "|" & s & "|\n\n"
  14. PRINT "POS()\n"
  15. s = "The quick brown fox"
  16. ' yields 5
  17. PRINT BB_POS("q",s,"="),"\n"
  18. ' yields 0
  19. PRINT BB_POS("z",s,"="),"\n"
  20. ' yields 13
  21. PRINT BB_POS("o",s,"=") ,"\n"
  22. ' yields 18 - Scan from end (fox)
  23. PRINT BB_POS("o",s,"=",-1),"\n"
  24. ' yields 18 - Second occurrence (fox)
  25. PRINT BB_POS("o",s,"=",1,2),"\n"
  26. ' yields 13 - Checks every 2nd position
  27. PRINT BB_POS("o",s,"=",2),"\n"
  28. ' yields 6 - "u" is first char. > "r"
  29. PRINT BB_POS("r",s,"<"),"\n"
  30. PRINT "CVS()\n"
  31. s = "  sb  "
  32. PRINT "|" & BB_CVS(s,3," "),"|\n"
  33. PRINT "|" & BB_CVS(s,4,""),"|\n\n"
  34.  

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 05, 2017, 08:29:57 PM by support »