/* -*- REXX -*- */ /* @@PLEAC@@_NAME */ /* @@SKIP@@ REXX @@SKIP@@ */ /* @@PLEAC@@_WEB */ /* @@SKIP@@ http://www.rexxla.org/ @@SKIP@@ */ /* @@PLEAC@@_INTRO */ /* @@SKIP@@ REXX is an interpreted, general purpose programming language that @@SKIP@@ */ /* @@SKIP@@ is used for both system and applications programming, as well as @@SKIP@@ */ /* @@SKIP@@ scripting tasks on a number of platforms ranging from mainframes @@SKIP@@ */ /* @@SKIP@@ to hand-held devices. @@SKIP@@ */ /* @@SKIP@@ @@SKIP@@ */ /* @@SKIP@@ ANSI Standard of the REXX language released in 1996. The language has @@SKIP@@ */ /* @@SKIP@@ undergone extensive development over time, and is now available in @@SKIP@@ */ /* @@SKIP@@ two flavours: @@SKIP@@ */ /* @@SKIP@@ @@SKIP@@ */ /* @@SKIP@@ * REXX or 'classic' REXX @@SKIP@@ */ /* @@SKIP@@ * Object Oriented REXX or ooREXX @@SKIP@@ */ /* @@SKIP@@ @@SKIP@@ */ /* @@SKIP@@ The difference between these two flavours can be likened to that @@SKIP@@ */ /* @@SKIP@@ between the C, and C++ languages: syntactically similar, but the @@SKIP@@ */ /* @@SKIP@@ latter extended to support object oriented programming. @@SKIP@@ */ /* @@SKIP@@ @@SKIP@@ */ /* @@SKIP@@ More information is available at: http://en.wikipedia.org/wiki/REXX @@SKIP@@ */ /* @@SKIP@@ @@SKIP@@ */ /* @@SKIP@@ Comments about the examples: @@SKIP@@ */ /* @@SKIP@@ @@SKIP@@ */ /* @@SKIP@@ * Incomplete examples are marked with the relevant PLEAC tags @@SKIP@@ */ /* @@SKIP@@ * Complete, but untranslateable, examples are so-marked @@SKIP@@ */ /* @@SKIP@@ * Extensive use of third-party libraries made [see Appendix] @@SKIP@@ */ /* @@SKIP@@ * Regina 3.3 interpreter used for testing [*NIX and Win32] @@SKIP@@ */ /* @@PLEAC@@_APPENDIX */ /* Some of the libraries used: * http://home.interlog.com/~ptjm/software.html REXXUtil General Purpose Utilities - System Information - Basic Console Control - File / Directory Manipulation REXXMath Common Mathematical Functions RxHash Associative Array Support REXXRe Regular Expressions * http://rxsock.sourceforge.net/index.html RxSock TCP/IP Sockets * http://rexxsql.sourceforge.net/index.html REXX/SQL SQL Library * http://rexxtk.sourceforge.net/index.html REXX/Tk TK Toolkit * http://rexxcurses.sourceforge.net/index.html REXX/Curses Curses Toolkit /* ----------------------------- */ A REXX script is assumed to commence with the following lines: options 'STRICT_ANSI' ; trace 'OFF' ; signal on NOVALUE FALSE = 0 ; TRUE = 1 ; NULL = "" ; SPACE = ' ' ; NEWLINE = "0A"X NaN = "NaN" globals = "sys. env. args. $. FALSE TRUE NULL NEWLINE SPACE NaN" /* ----------------------------- */ REXXToolkit routines [when documented] will appear here /* ----------------------------- */ */ /* @@PLEAC@@_1.0 */ string = '\n' /* two characters, \ and an n, though not a newline */ string = "\n" /* two characters, \ and an n, though not a newline */ string = "0A"X /* newline character code [hex] */ string = "1010"B /* newline character code [binary] */ string = "Newline" "0A"X "here" /* embedded newline in string */ string = 'Jon ''Maddog'' Orwant' /* literal single quotes */ string = "Jon ""Maddog"" Orwant" /* literal double quotes */ string = "Jon 'Maddog' Orwant" /* embedded literal single quotes */ string = 'Jon "Maddog" Orwant' /* embedded literal double quotes */ /* ----------------------------- */ /* HERE documents not supported, but multi-line string allowed */ a = "This is a multiline string that is not a HERE document" , "but consists of a series of concatenated strings" , "each on its own line courtesy of the 'comma' which, when" , "it appears as the last, space-separated character on a" , "line, acts as a line continuation character" /* ----------------------------- */ /* Pseudo implementation of a HERE document */ signal HEREDOC /* Line 1 ... Line 2 ... Line 3 */ HEREDOC: a = NULL do i = SIGL + 1 line = SOURCELINE(i) if line = "*/" then leave a = a||NEWLINE||line end /* @@PLEAC@@_1.1 */ /* ------------------------------------------------------------------ */ /* * REXX offers string manipulation built-in functions [BIF's] many */ /* being equivalent to Perl offerings. However, all REXX BIF's */ /* return copies of the transformed string; original is unaltered. */ /* Therefore this type of usage is illegal: */ /* */ /* SUBSTR(string, offset, count) = newstring */ /* */ /* Instead, variable storing original must be reassigned with the */ /* altered copy */ /* */ /* * REXX implements PARSE instruction which provides a faster means */ /* of: */ /* - tokenising strings [from several sources: string, file, stack] */ /* - assigning tokens to variables */ /* - initialisng and swapping variables, multi-line assignments */ /* */ /* Examples of both approaches shown wherever applicable */ /* ------------------------------------------------------------------ */ string = "a value" /* ----------------------------- */ offset = 3 ; count = 9 ; padchar = 'X' parse var string =(offset) v v = SUBSTR(string, offset) /* "value " */ parse var string =(offset) v +(count) v = SUBSTR(string, offset, count) /* "value " */ v = SUBSTR(string, offset, count, padchar) /* "valueXXXX" */ /* ----------------------------- */ offset = 2 ; count = 2 ; padchar = '*' ; newstr = "Z" v = INSERT(newstr, string, offset, count, padchar) /* "a Z*value" */ v = OVERLAY(newstr, string, offset, count, padchar) /* "aZ*alue" */ /* ----------------------------- */ /* *** Unfinished *** - UNPACK */ /* ----------------------------- */ /* PARSE VAR instruction equivalent, but more efficient, than SUBSTR */ string = "This is what you have" slen = LENGTH(string) parse var string =1 first +1 first = SUBSTR(string, 1, 1) /* "T" */ parse var string =6 start +2 start = SUBSTR(string, 6, 2) /* "is" */ parse var string =14 rest rest = SUBSTR(string, 14) /* "you have" */ parse var string =(slen) last +1 last = SUBSTR(string, slen, 1) /* "e" */ parse var string =(slen) -3 end end = SUBSTR(string, slen - 3) /* "have" */ parse var string =(slen) -7 piece +3 piece = SUBSTR(string, slen - 7, 3) /* "you" */ /* Display contents of string */ say string /* Change "is" to "wasn't" : This wasn't what you have */ string = CHANGEWORD("is", string, "wasn't") /* Replace last 12 characters : This wasn't wondrous */ newstr = "ondrous" ; slen = LENGTH(string) ; nlen = LENGTH(newstr) /* 1 - slow */ string = OVERLAY(newstr, string, slen - 11) string = DELSTR(string, LASTPOS(newstr, string) + nlen) /* 2 - faster */ string = LEFT(string, slen - 12) || newstr /* 3 - fastest */ sparse = slen - 12 parse var string string +(sparse) string = string || newstr /* delete first character : his wasn't wondrous */ parse var string =2 string string = DELSTR(string, 1, 1) string = RIGHT(string, slen - 1) /* Return last 15 characters : wasn't wondrous */ slen = LENGTH(string) parse var string =(slen) -14 string +15 string = SUBSTR(string, slen - 14, 15) string = RIGHT(string, 15) /* Delete last 10 characters : wasn' */ slen = LENGTH(string) ; sparse = slen - 10 parse var string string +(sparse) string = DELSTR(string, slen - 9, 10) string = LEFT(string, slen - 10) /* *** Unfinished *** */ /* @@PLEAC@@_1.2 */ /* ------------------------------------------------------------------ */ /* REXX Boolean values are strictly: */ /* */ /* 1 - TRUE */ /* 0 - FALSE */ /* */ /* All other values force an syntax error if used in a Boolean */ /* context; Boolean expression can be forced via a comparision */ /* operation [see example below] */ /* */ /* REXX does not support conditional structures other than the 'IF' */ /* and 'SELECT' instructions; there is no ternary operator, nor a */ /* conditional assignment expression. This can, however, be mimiced */ /* via function; examples below use an 'iif' function implementation */ /* that, rather crudely, supports this type of operation */ /* */ /* iif(CONDITION, TRUE_VALUE, FALSE_VALUE) */ /* */ /* It is also worth mentioning that the WORD BIF can also be used for */ /* performing conditional assignment. It can be used where alternate */ /* values can be placed in the same string, and relies on: */ /* */ /* * The fact that in REXX all data are strings */ /* * The values of FALSE and TRUE being exactly 0, and 1, respectively*/ /* */ /* See example at end of this section */ /* ------------------------------------------------------------------ */ condition = TRUE ; b = 'B' ; c = 'C' ; x = TRUE ; y = 'Y' /* Use 'b' if 'condition' is TRUE, else return 'c' */ a = iif(condition, b, c) /* Use 'b' if 'b' is TRUE, else 'c' */ a = iif(, b, c) /* Set 'x' to 'y' unless 'x' is already TRUE */ x = iif(, \x, y) /* As above; Boolean expression forced in case 'x' non-Boolean */ x = iif(, \(x == TRUE), y) /* ----------- */ /* Use 'b' if 'b' is defined, else 'c' */ a = iif(SYMBOL('b') == "VAR", b, c) bar = "ANOTHER VALUE" foo = iif(SYMBOL('bar') \= "VAR", bar, "DEFAULT VALUE") exit 0 /* ----------- */ iif : procedure expose (globals) if ARG(1, 'E') then cond = ARG(1) ; else cond = ARG(2) if cond == TRUE then return ARG(2) ; else return ARG(3) /* ----------------------------- */ condition = TRUE ; alternatives = "B C" /* condition: FALSE -> 'B' returned condition: TRUE -> 'C' returned */ WORD(alternatives, condition + 1) /* @@PLEAC@@_1.3 */ /* ------------------------------------------------------------------ */ /* No multiple-assignment support, but PARSE VALUE instruction may be */ /* used to perform: */ /* */ /* * Multiple variable initialisation */ /* * Multiple variable assignment [even swap values without temps] */ /* ------------------------------------------------------------------ */ parse value 1 2 with VAR1 VAR2 parse value VAR1 VAR2 with VAR2 VAR1 /* ----------------------------- */ a = 1 ; b = 2 temp = a ; a = b ; b = temp /* ----------------------------- */ parse value 57 72 103 with alpha beta production parse value beta production alpha with alpha beta production /* @@PLEAC@@_1.4 */ /* ------------------------------------------------------------------ */ /* REXX is a typeless language: all data are strings. This means: */ /* */ /* * REXX has no notion of objects, or aggregate types like arrays */ /* * It does not support 'primitive' types, those usually mapped to */ /* hardware registers */ /* */ /* In order to support mathematical operations, however, strings in */ /* Base 10 format [containing 0-9, leading + or -, a decimal point, */ /* exponent indicator 'E' and exponent] are recognised as 'numeric' */ /* strings in such contexts [whilst hex and binary strings are not]. */ /* */ /* The benefit of this approach: */ /* */ /* * Simplifies interpreter implementation on new platforms */ /* * Implicit support for arbitrary precision arithmetic */ /* * Language kept simple - no declarations, casting or conversions */ /* */ /* A set of conversion BIF's is supplied to facilitate the conversion */ /* of strings to / from various numeric representations, though it is */ /* understood that this is not a type conversion, but a 'form' */ /* conversion, one that may facilitate data printing or storage: */ /* */ /* * C2D / D2C [Character to Decimal / vice versa] */ /* * C2X / X2C [Character to Hex / vice versa] */ /* * X2B / B2X [Hex to Binary / vice versa] */ /* ------------------------------------------------------------------ */ char = 'A' /* or: char = '41'X [ASCII] */ num = C2D(char) char = D2C(num) /* ----------------------------- */ char = 'e' say "Number" C2D(char) "is" char /* Number 101 is e */ /* ----------------------------- */ string = "ABCDE" ascii = C2X(string) /* ascii [hex]: 4142434445 */ string = X2C(ascii) /* string: ABCDE */ /* ----------------------------- */ /* Contents: 73616D706C65 */ ascii_character_numbers = C2X("sample") /* Output will now be: 73 61 6D 70 6C 65 */ out = "" ; acn = ascii_character_numbers do while acn <> NULL parse var acn token +2 acn out = out token end say STRIP(out) /* Output will now be: sample */ out = X2C(ascii_character_numbers) say out /* ----------------------------- */ hal = "HAL" ; ibm = "" do while hal <> NULL parse var hal token +1 hal ibm = ibm||D2C(C2D(token) + 1) end /* Output will now be: IBM */ say ibm /* @@PLEAC@@_1.6 */ /* ------------------------------------------------------------------ */ /* The task of reversing strings is easily and efficiently performed */ /* via the REVERSE BIF. Implementation of a palindome-checking routine*/ /* is probably best accomplished via its use since it involves a */ /* single function call, thus incurs minimal calling overhead. Since */ /* REXX is typically used as an interpreted language, it often becomes*/ /* a significant issue. Performance comparision of the following two */ /* 'isPalindrome' functions should clearly reveal it's impact. */ /* */ /* isPalindrome : procedure */ /* i = 1 ; j = LENGTH(ARG(1)) */ /* do until i >= j */ /* if SUBSTR(ARG(1),i,1) \= SUBSTR(ARG(1),j,1) ; then return FALSE*/ /* i = i + 1 ; j = j - 1 */ /* end */ /* return TRUE */ /* */ /* isPalindrome : procedure */ /* return REVERSE(ARG(1)) == ARG(1) */ /* */ /* The task of reversing words within a string can quite easily be */ /* accomplished in several ways: */ /* */ /* * PARSE instruction together with the stack operations PUSH and */ /* PARSE PULL [stack and queue structures are native to REXX, and */ /* are used for many diverse tasks including interprocess comms] */ /* */ /* * Word-oriented BIF's ['reverseWords' is a recursive function that */ /* uses two of these: DELWORD and WORD. Anyone familiar with LISP or*/ /* Scheme will note how they are being used like 'car' and cdr'] */ /* */ /* reverseWords : procedure */ /* if ARG(1) == "" then ; return "" */ /* return STRIP(reverseWords(DELWORD(ARG(1), 1, 1)) WORD(ARG(1), 1))*/ /* ------------------------------------------------------------------ */ string = "A horse is a horse, of course, of course !" /* Reverse string using REXX BIF */ revbytes = REVERSE(string) /* ----------------------------- */ /* Tokenise 'string', and place each token on stack */ do while string <> NULL parse var string token string push token end /* Build 'revwords' by extracting tokens from stack */ revwords = "" do while QUEUED() > 0 parse pull token revwords = revwords token end /* ----------------------------- */ string = 'Yoda said, "can you see this?"' /* Reverse the word order in a string [custom function - see header] */ revwords = reverseWords(string) say revwords /* ----------------------------- */ word = "reviver" /* Check whether string is palindrome [custom function - see header] */ is_palindrome = isPalindrome(word) /* @@PLEAC@@_2.0 */ /* ------------------------------------------------------------------ */ /* REXX uses floating point-based, arbitrary precision arithmetic */ /* which, unlike most computer languages, operates not on hardware- */ /* mapped bit collections, but on strings which represent numbers. */ /* */ /* The immediately-obvious disadvantage of this approach is slower, */ /* less memory-efficient number crunching capabilities when compared */ /* to scripting languages like Perl or Python. On the other hand, this*/ /* design approach simplifies REXX interpreter implementation across */ /* platforms, as well as eliminating most of the loss-of-precision and*/ /* related problems so often encountered when 'number crunching'. So, */ /* from an end-user perspective, arithmetic operations should nearly */ /* always generate 'unsurprising' results, and not cause the naive or */ /* unwary user any confusion. */ /* ------------------------------------------------------------------ */ /* @@PLEAC@@_2.1 */ /* ------------------------------------------------------------------ */ /* The REXX-idiomatic numeric validation approach is to use the */ /* 'DATATYPE' BIF. For more complex validation needs the 'VERIFY' BIF */ /* may also be used but since it only checks for the presence or the */ /* absence of characters it needs to be augmented with other checks. */ /* */ /* Regex-based validation [once implemented] requires the least work. */ /* The examples make use of a REXXToolkit routine, 'match', which */ /* uses the 'RxRe' external library. See Appendix for details. */ /* ------------------------------------------------------------------ */ /* REXX BIF-based Validation */ /* Accepts: +9 -9 9.0 9.0e+2 9.0E-3 */ if \DATATYPE(string, 'N') then ; say "not a decimal number" /* Accepts: +9 -9 Rejects: 9.0 9.0e+2 9.0E-3 */ if \(DATATYPE(string, 'W') & POS(".", string) == 0) then say "not an integer" /* ----------- */ /* Checks for presence / absence of characters, but does not check position of characters, or presence of patterns. Useful for quick, but not thorough, validation */ if VERIFY(string, "0123456789") \= 0 then ; say "has nondigits" if VERIFY(string, "+-.Ee0123456789") \= 0 then ; say "not a decimal" /* ----------- */ /* Custom function, 'isDecimal', which uses a combination of the PARSE instruction, and DATATYPE BIF to thoroughly validate a decimal value */ tbl = "+934.521e-2 -934.521 934 ", "+934.521e-a +934.521f-2 +934.!e-2 ", "e934.521e-2" entries = WORDS(tbl) do i = 1 for entries entry = WORD(tbl, i) if isDecimal(entry) then ; say entry "is decimal" else ; say entry "is NOT decimal" end exit 0 /* ----------- */ isDecimal : procedure expose (globals) parse upper value ARG(1) with whole "." frac "E" exp if exp \= NULL then ; if \DATATYPE(exp, 'W') then ; return FALSE if frac \= NULL then ; if \DATATYPE(frac, 'W') then ; return FALSE if whole \= NULL then ; if \DATATYPE(whole, 'W') then ; return FALSE return TRUE /* ----------------------------- */ /* Regex-based Validation */ if match(string, "PATTERN") then /* Is a number */ else /* Is not */ /* ----------- */ /* Also rejects: +9 -9 9.0 */ if match(string, "[^[:digit:]]") then ; say "has nondigits" /* Also rejects: +9 -9 9.0 */ if \match(string, "^[[:digit:]]+$") then ; say "not a natural number" /* Rejects: +9 9.0 Accepts: -9 */ if \match(string, "^-?[[:digit:]]+$") then ; say "not an integer" /* Rejects: 9.0 Accepts: +9 -9 */ if \match(string, "^[+-]?[[:digit:]]+$") then ; say "not an integer" /* Accepts: +9 -9 9.0 9.0e+2 9.0E-3 */ decimalRE = "^[+-]?[[:digit:]]+\.?[[:digit:]]+[e|E][+-]?[[:digit:]]+$" if \match(string, decimalRE) then say "not a decimal number" /* @@PLEAC@@_2.2 */ /* ------------------------------------------------------------------ */ /* The NUMERIC instruction allows adjustment of: */ /* */ /* * Significant digits used in arithmetic operations [DIGITS] */ /* * Digits to be ignored during arithmetic comparisons [FUZZ] */ /* */ /* Default values are usually adequate. Increasing DIGITS increases */ /* precision, but slows down arithmetic operations. FUZZ is by default*/ /* 0, so all digits are significant in comparison operations. */ /* */ /* The FORMAT BIF may be used like the C-derived, 'sprintf', function */ /* to compare floating point values as strings. */ /* ------------------------------------------------------------------ */ numeric digits 11 a = 1234567.8234 ; b = 1234567.8237 /* Compare 'DIGITS - FUZZ' [11] number of digits */ numeric fuzz 0 if a = b then ; say "a = b" /* FALSE */ /* Compare 'DIGITS - FUZZ' [10] number of digits */ numeric fuzz 1 if a = b then ; say "a = b" /* FALSE */ /* Compare 'DIGITS - FUZZ' [9] number of digits */ numeric fuzz 2 if a = b then ; say "a = b" /* TRUE */ /* ----------------------------- */ /* Returns TRUE if 'num1' and 'num2' are equal to 'accuracy' number of decimal places */ isEqual(num1, num2, accuracy) /* ----------------------------- */ a = 1234567.8234 ; b = 1234567.8237 /* isEqual(a, b, 1) ==> TRUE isEqual(a, b, 2) ==> TRUE isEqual(a, b, 3) ==> TRUE isEqual(a, b, 4) ==> FALSE */ exit 0 /* ----------- */ isEqual : procedure expose (globals) places = ARG(3) ; numeric fuzz 0 return FORMAT(ARG(1),, places) == FORMAT(ARG(2),, places) /* ----------------------------- */ wage = 536 /* $ 5.36 / hr */ week = 40 * wage /* $ 214.40 */ say "One week's wage is: $" FORMAT(week / 100,, 2) /* @@PLEAC@@_2.3 */ /* ------------------------------------------------------------------ */ /* The 'FORMAT' BIF is REXX's equivalent to the much-used, C-derived */ /* 'sprintf' function. */ /* ------------------------------------------------------------------ */ /* Truncate to integer value */ truncated = TRUNC(value, length) /* Round value [and possibly justify] */ rounded = FORMAT(value, n_before_decimal, n_after_decimal) /* ----------------------------- */ a = 0.255 ; b = FORMAT(a, 1, 2) say "Unrounded:" a "Rounded:" b say "Unrounded:" a "Rounded:" FORMAT(a, 1, 2) /* Unrounded: 0.255 Rounded: 0.26 Unrounded: 0.255 Rounded: 0.26 */ /* ----------------------------- */ /* Example illustrating external library routine use. Not, however, that the FORMAT BIF can be used to perform the same tasks as 'NInt', 'Floor' and 'Ceil', making library routine use unnecessary */ /* Load [rexxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs' call mathLoadFuncs tbl = "3.3 3.5 3.7 -3.3" say cstr2rxstr("number\tint\tfloor\tceil") do while tbl <> NULL parse var tbl n tbl line = FORMAT(n, 2, 1) || "\t" ||, FORMAT(NInt(n), 2, 1) || "\t" ||, FORMAT(Floor(n), 2, 1) || "\t" ||, FORMAT(Ceil(n), 2, 1) say cstr2rxstr(line) end /* number int floor ceil 3.3 3.0 3.0 4.0 3.5 4.0 3.0 4.0 3.7 4.0 3.0 4.0 -3.3 -3.0 -4.0 -3.0 */ /* Unload math functions */ call mathDropFuncs exit 0 /* ----------- */ cstr2rxstr : procedure expose (globals) s = ARG(1) ; tbl = "\n 0A \r 0D \t 09" do while tbl \= NULL parse var tbl esc replc tbl s = CHANGESTR(esc, s, X2C(replc)) end return s /* @@PLEAC@@_2.4 */ /* ------------------------------------------------------------------ */ /* Binary, hexadecimal, decimal interconversion is well-supported via */ /* the following BIF's: */ /* */ /* * X2D, D2X [hex->dec, dec->hex, respectively] */ /* * X2B, B2X [hex->bin, bin->hex, respectively] */ /* */ /* Easily combined to create functions that interconvert binary and */ /* decimal. */ /* ------------------------------------------------------------------ */ /* Convert binary string to decimal */ decimal = B2D('0110110') /* Convert decimal value to binary string */ binary = D2B(54) exit 0 /* ----------- */ B2D : procedure expose (globals) return X2D(B2X(ARG(1))) D2B : procedure expose (globals) return X2B(D2X(ARG(1))) /* @@PLEAC@@_2.5 */ /* ------------------------------------------------------------------ */ /* The 'do' loop is the REXX-idiomatic control structure for */ /* repetitive tasks such as list traversal. Recursive solutions are */ /* possible but less efficient due to argument passing overhead, and */ /* lack of tail-call optimisation. */ /* ------------------------------------------------------------------ */ x = 1 ; y = 5 ; step = 1 /* Number sequence is traversed using 'do' loop */ /* 'i' set from value of 1 through to 5 in 'step' increments */ do i = x to y by step /* do something with 'i' */ end /* ----------- */ /* 'i' set from value of 1 through to 5; default increment of 1 */ do i = x to y /* do something with 'i' */ end /* ----------------------------- */ call CHAROUT , "Infancy is: " do i = 0 to 2 ; call CHAROUT , i || SPACE ; end say NULL call CHAROUT , "Toddling is: " do i = 3 to 4 ; call CHAROUT , i || SPACE ; end say NULL call CHAROUT , "Childhood is: " do i = 5 to 12 ; call CHAROUT , i || SPACE ; end say NULL /* ----------------------------- */ /* REXX does not sport a native 'foreach' control structure, but it is possible to implement similar behaviour provided certain conventions are followed such as generating lists of SPACE or COMMA-separated sequences */ /* ----------------------------- */ sequence = makeIntegerSequence(1, 5, 1) do while sequence <> NULL parse var sequence value sequence call CHAROUT , value || SPACE end /* ----------- */ /* Partial reimplementation of earlier example */ infancy = makeIntegerSequence(0, 2, 1) call CHAROUT , "Infancy is: " do while infancy <> NULL parse var infancy value infancy call CHAROUT , value || SPACE end /* ... */ exit 0 /* ----------- */ /* Iterative ['do' loop-based] */ makeIntegerSequence : procedure expose (globals) x = ARG(1) ; y = ARG(2) ; step = ARG(3) seq = x ; x = x + 1 ; do i = x to y by step ; seq = seq i ; end return seq /* Recursive */ makeIntegerSequenceR : procedure expose (globals) x = ARG(1) ; y = ARG(2) ; step = ARG(3) if x > y then ; return NULL return x makeIntegerSequenceR(x + step, y, step) /* Iterative [Tail Recursive] */ makeIntegerSequenceI : procedure expose (globals) x = ARG(1) ; y = ARG(2) ; step = ARG(3) ; seq = ARG(4) if x > y then ; return STRIP(seq) return makeIntegerSequenceI(x + step, y, step, (seq x)) /* @@PLEAC@@_2.6 */ /* ------------------------------------------------------------------ */ /* REXX sports no inbuilt Roman numeral-handling routines. A custom */ /* implementation appears below. */ /* ------------------------------------------------------------------ */ roman = arabic2roman(arabic) arabic = roman2arabic(roaman) /* ----------------------------- */ roman_fifteen = arabic2roman(15) say "Roman for fifteen is" roman_fifteen arabic_fifteen = roman2arabic(roman_fifteen) say "Converted back" roman_fifteen "is" arabic_fifteen exit 0 /* ----------- */ roman2arabic : procedure tbl.I = 1 ; tbl.V = 5 ; tbl.X = 10 ; tbl.L = 50 tbl.C = 100 ; tbl.D = 500 ; tbl.M = 1000 tbl.IV = 4 ; tbl.IX = 9 ; tbl.XL = 40 ; tbl.XC = 90 tbl.CD = 400 ; tbl.CM = 900 roman = " " || TRANSLATE(STRIP(ARG(1))) ; arabic = 0 do i = LENGTH(roman) - 1 to 1 by -1 r = SUBSTR(roman, i, 2) if SYMBOL('tbl.r') == 'VAR' then ; i = i - 1 else ; r = RIGHT(r, 1) arabic = arabic + tbl.r end return arabic /* ----------- */ arabic2roman : procedure arabic = REVERSE(ARG(1)) ; len = LENGTH(arabic) ; roman = "" tbl.1 = "I II III IV V VI VII VIII IX" tbl.2 = "X XX XXX XL L LX LXX LXXX XC" tbl.3 = "C CC CCC CD D DC DCC DCCC CM" if len < 4 then do i = 1 to len j = SUBSTR(arabic, i, 1) ; if j == 0 then ; iterate roman = WORD(tbl.i, j) || roman end else ; do do i = 1 to 3 j = SUBSTR(arabic, i, 1) ; if j == 0 then ; iterate roman = WORD(tbl.i, j) || roman end roman = COPIES("M", REVERSE(SUBSTR(arabic, 4))) || roman end return roman /* @@PLEAC@@_2.7 */ /* ------------------------------------------------------------------ */ /* Random number [well, pseudo-random :)] generation is typically */ /* performed using the 'RANDOM' BIF. */ /* ------------------------------------------------------------------ */ random = RANDOM(maxval) /* 0 - maxval [maxval <= 100000] */ random = RANDOM(minval, maxval) /* minval - maxval [as above] */ /* ----------------------------- */ tbl = "abcdefghijklmnop" elt = randomChoice(tbl) /* One of 'a', 'b', ... */ tbl = "12 67 asde cvs +++ &fgt klmnop" elt = randomChoice(tbl) /* One of 12, 67, ... */ /* ----------------------------- */ /* Generate 8 character-length password with randomly chosen chars */ chars = XRANGE("A", "Z") || XRANGE("a", "z") ||, XRANGE("0", "9") || "!$%#@*&" password = NULL do 8 password = password || randomChoice(chars) end exit 0 /* ----------- */ randomChoice : procedure expose (globals) tbl = ARG(1) ; items = WORDS(tbl) if items == 1 then do items = LENGTH(tbl) ; item = SUBSTR(tbl, RANDOM(1, items), 1) end ; else do item = WORD(tbl, RANDOM(1, items)) end return item /* @@PLEAC@@_2.8 */ /* ------------------------------------------------------------------ */ /* See comments in previous section */ /* ------------------------------------------------------------------ */ random = RANDOM(,, seed) /* Each such call reseeds the RNG */ /* @@PLEAC@@_2.9 */ /* ------------------------------------------------------------------ */ /* Custom functions for this type of task are easily written in REXX. */ /* Examples include: */ /* */ /* * 'lcg', simple linear-congruential RNG */ /* * 'randomSlice' - see example below */ /* ------------------------------------------------------------------ */ random = 47523 ; reps = 10 do reps random = lcg(random) /* do something with 'random' ... */ end /* ----------------------------- */ reps = 10 do reps /* Random length digit sequence; sliced from random position of a default-length 'RANDU'-generated digit sequence */ random = randomSlice() /* 3 digit sequence; as previous */ random = randomSlice(3) /* 4 digit sequence; sliced from random position of a 13 digit length 'RANDU'-generated digit sequence */ random = randomSlice(4, 13) end /* ----------- */ lgc : procedure expose (globals) numeric digits 17 return 16807 * ARG(1) // 2147483647 randomSlice : procedure expose (globals) sizeSlice = ARG(1) ; sizePool = ARG(2) if sizePool == NULL | sizePool > 17 then ; sizePool = 17 if sizeSlice == NULL then ; sizeSlice = RANDOM(1, sizePool - 1) if sizeSlice >= sizePool then ; sizeSlice = sizePool - 1; posSlice = RANDOM(1, sizePool - sizeSlice) numeric digits sizePool parse value RANDU() with "." frac return SUBSTR(frac, posSlice, sizeSlice) /* @@PLEAC@@_2.10 */ /* ------------------------------------------------------------------ */ /* Gaussian RNG */ /* ------------------------------------------------------------------ */ /* Need this for access to non-standard, 'RANDU', function */ options 'AREXX_BIFS' /* Using 'rexxMath' Library Routines */ /* Load [rexxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs' call mathLoadFuncs /* ----------- */ mean = 25.0 ; sdev = 2.0 ; salary = gaussian_rand() * mean + sdev say "You have been hired at:" FORMAT(salary,, 2) /* ----------- */ /* Unload math functions */ call mathDropFuncs exit 0 /* ----------- */ gaussian_rand : procedure w = 2.0 do while w > 1.0 u1 = 2.0 * RANDU() - 1.0 ; u2 = 2.0 * RANDU() - 1.0 w = u1 * u1 + u2 * u2 end w = Sqrt((-2.0 * Log10(w)) / w) ; g2 = u1 * w ; g1 = u2 * w return g1 /* @@PLEAC@@_2.11 */ /* ------------------------------------------------------------------ */ /* Aside from supporting the usual arithmetic operations, including */ /* exponentiation [via the '**' operator], and a few BIF's including */ /* 'MIN', 'MAX', 'SIGN' and 'ABS', REXX offers no built-in support for*/ /* mathematical operations. Instead the programmer can implement the */ /* required functionality themselves, or make use of external library */ /* routines. */ /* */ /* REXX-native mathematical functions are easily implementable, but */ /* the string-expressable, arbitrary precision arithmetic model used */ /* ensures they will not be as 'high performance' as hardware-based */ /* implementations, precluding their use for 'serious' number crunch- */ /* ing. On the other hand, external library routines are [like the one*/ /* illustrated here] to be hardware-based, hence offer performance */ /* comparable to that of other languages after both function call and */ /* data conversion overhead is taken into account. */ /* ------------------------------------------------------------------ */ /* Using 'rxMath' Library Routines */ /* Load [rxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rxMath', 'mathLoadFuncs' call mathLoadFuncs /* Accepts argumets in either degree, radian, or gradian form */ say rxCalcSin(30, 'D') say FORMAT(rxCalcSin(60, 'D'),,3) /* Unload math functions */ call mathDropFuncs exit 0 /* ----------- */ /* Using native REXX Routines [need 'Sin' from external library] */ radians = DEG2RAD(degrees) degrees = RAD2DEG(radians) /* ----------------------------- */ /* Load [rexxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs' call mathLoadFuncs say degree_sin(30) say FORMAT(degree_sin(60),,3) /* Unload math functions */ call mathDropFuncs exit 0 /* ----------- */ degree_sin : procedure expose (globals) /* ARG(1) - Degrees --- 'Sin' [a 'rexxMath' library routine] expects its argument in radians so 'DEG2RAD' used to perform the conversion */ return Sin(DEG2RAD(ARG(1))) DEG2RAD : procedure expose (globals) return ARG(1) / 180 * PI() RAD2DEG : procedure expose (globals) return ARG(1) / PI() * 180 PI : procedure expose (globals) return 3.14159265358979323846264338327 /* @@PLEAC@@_2.12 */ /* ------------------------------------------------------------------ */ /* See comments in previous section header */ /* ------------------------------------------------------------------ */ /* Using 'rxMath' Library Routines */ /* Load [rxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rxMath', 'mathLoadFuncs' call mathLoadFuncs /* Accepts argumets in either degree, radian, or gradian form */ theta = 1.7 ; tan = rxCalcSin(theta, 'R') / rxCalcCos(theta, 'R') say "tan of theta" theta "[radians]:" tan say "tan of theta" FORMAT(theta,, 3) "[radians]:" FORMAT(tan,, 3) /* ----------- */ say "tan of theta" theta "[radians]:" rxCalcTan(theta, 'R') say "tan of theta" FORMAT(theta,, 3) "[radians]:", /* ----------- */ theta = 0.37 ; say "acos of" theta "[radians]:" rxCalcArcCos(theta, 'R') /* ----------- */ /* Unload math functions */ call mathDropFuncs exit 0 /* ----------------------------- */ /* Using 'rexxMath' Library Routines */ /* Load [rexxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs' call mathLoadFuncs theta = 1.7 ; tan = Sin(theta) / Cos(theta) say "tan of theta" theta "[radians]:" tan say "tan of theta" FORMAT(theta,, 3) "[radians]:" FORMAT(tan,, 3) /* ----------- */ say "tan of theta" theta "[radians]:" Tan(theta) say "tan of theta" FORMAT(theta,, 3) "[radians]:" FORMAT(Tan(theta),, 3) /* ----------- */ theta = 0.37 ; say "acos of" theta "[radians]:" ACos(theta) /* ----------- */ /* Unload math functions */ call mathDropFuncs exit 0 /* @@PLEAC@@_2.13 */ /* ------------------------------------------------------------------ */ /* See comments in previous section header */ /* ------------------------------------------------------------------ */ /* Using 'rxMath' Library Routines */ /* Load [rxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rxMath', 'mathLoadFuncs' call mathLoadFuncs log_e = rxCalcLog(value) /* ----------- */ log_10 = rxCalcLog10(value) /* ----------- */ answer = rxlog_base(10, 10000) say "log_base(10, 10000) ==>" FORMAT(answer,, 2) say "log10(10000) ==>" FORMAT(rxCalcLog10(10000),, 2) /* ----------- */ /* Unload math functions */ call mathDropFuncs exit 0 /* ----------- */ rxlog_base : procedure expose (globals) base = ARG(1) ; value = ARG(2) return rxCalcLog(value) / rxCalcLog(base) /* ----------------------------- */ /* Using 'rexxMath' Library Routines */ /* Load [rexxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs' call mathLoadFuncs log_e = Log(value) /* ----------- */ log_10 = Log10(value) /* ----------- */ answer = log_base(10, 10000) say "log_base(10, 10000) ==>" FORMAT(answer,, 2) say "log10(10000) ==>" FORMAT(Log10(10000),, 2) /* ----------- */ /* Unload math functions */ call mathDropFuncs exit 0 /* ----------- */ log_base : procedure expose (globals) base = ARG(1) ; value = ARG(2) return Log(value) / Log(base) /* @@PLEAC@@_2.14 */ /* ------------------------------------------------------------------ */ /* REXX offers no matrix-handling BIF's. Below can be found a custom */ /* implementation that, perhaps unusually, represents matrices as str-*/ /* ings. Notes: */ /* */ /* * Since strings are immutable, matrix manipulations result in new */ /* strings being created; high performance, therefore, should not be*/ /* expected */ /* */ /* * Only a smattering of operations are offered, and some of them use*/ /* rather naive algorithms [e.g. multiplication - Winograd's algori-*/ /* thm could instead be used] */ /* */ /* * There is much code redundancy [e.g. 'madd' and 'msub' are identi-*/ /* save for the arithmetic operation performed]. This could have be-*/ /* en avoided via use of both the VALUE BIF and INTERPRET instructi-*/ /* on [an approach much used in Chapter 4], but it was felt that co-*/ /* de would be more readable, and perhaps more easily adapted if ke-*/ /* pt simple, despite the repetition. */ /* */ /* * Decision to model matrices as strings was based on two factors: */ /* */ /* - Avoiding global array use */ /* - Illustrate how ADT's may be modelled using strings, and showca-*/ /* se the REXX PARSE instruction and string manipulation BIF's */ /* */ /* Performance can be significantly improved without resorting to the */ /* use of global arrays by using an external library like T. J. McPhe-*/ /* e's, 'rxHash', that implements arrays as special strings that may */ /* be freely passed around. Chapter 4 makes extensive use of this very*/ /* versatile library. I hope to provide an expanded version of the */ /* present library using this technique as part of the REXXToolkit [to*/ /* be found in the Appendix] sometime in 2007. */ /* ------------------------------------------------------------------ */ /* Global Constants */ FALSE = 0 ; TRUE = 1 ; NULL = "" ; NEWLINE = "0A"X ; SPACE = ' ' NaN = "NaN" /* Matrix-specific global constants */ MTAG = "" ; MHSEP = "|" ; MRAWSEP = "; " ; MRSEP = ";" MTYPE_REGULAR = "R" ; MTYPE_SINGULAR = "S" ; MTYPE_ZERO = "Z" MTYPE_IDENTITY = "I" ; MTYPE_VECTOR = "V" /* -- */ /* Global Roots and 'expose' list */ globals = "sys. env. args. $. FALSE TRUE NULL NEWLINE SPACE NaN" /* Matrix-specific 'expose' list */ matdefs = "MTAG MHSEP MTYPE_REGULAR MTYPE_SINGULAR" , "MTYPE_ZERO MTYPE_IDENTITY MTYPE_VECTOR" , "MRSEP" , "MRAWSEP" /* ----------------------------- */ x = makeMatrix("3 2 3;5 9 8;") ; y = makeMatrix("4 7;9 3;8 1;") z = mmul(x, y) say "z =" ; call mdump z /* ----------------------------- */ say "z determinant:" mdet(z) say "z inverse =" ; call mdump minverse(z), 8 say "trace: " mtrace(z) say "z transpose =" ; call mdump mtranspose(z) exit 0 /* ----------------------------- */ /* * *** IMPORTANT *** Matrix rows and columns numbered from 1, and *not* 0 like so many zero-index-based languages * Variable size, delimited strings represent the matrix type. Each such string has a header section followed by a data section; typically, the string is split, metadata extracted from the header, and the data section returned for subsequent processing * Easy to view matrix contents: just SAY the string. The 'mdump' routine is available for pretty printing * Simple error-handling approach used: a value of, 'NaN', is returned where any error is detected [applies only to routines that do error checking - 'stupid' usage merely sees the script crash] * Matrix Format [EBNF]: ::=
::= ::= + ::= '' ::= ::= ::= 'S' | 'R' | 'V' | 'Z' | 'I' ::= '|' ::= + ::= ';' ::= digit+ ::= | digit+ '.' digit+ ::= '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' * Matrix Format Examples: - 1-row matrices considered vectors 1x1 -> "1 1 V|7;" 1x3 -> "1 3 V|7 8 9;" - Square Matrices; regular, zero, or identity 2x2 Regular -> "2 2 R|1 2;4 5;" 3x3 Regular -> "3 3 R|1 2 3;4 5 6;7 8 9;" 3x3 Zero -> "3 3 Z|0 0 0;0 0 0;0 0 0;" 3x3 Identity -> "3 3 I|1 0 0;0 1 0;0 0 1;" - Singular Matrices 2x3 -> "2 3 S|1 2 3;4 5 6;" 3x2 -> "3 2 S|1 2;3 4;5 6;" * Matrix string contains both metadata and uses a delimiter to mark out rows. Using only one of these items would have allowed determination of the other [i.e. compute metadata by counting delimiters, or tokenise into rows using metadata], but using both allowed for easy type-checking and simplified tokenisation via the PARSE instruction * Routines classed as follows: - Constructors [makeVector, makeMatrix, makeDiagonal] - Type Checkers [isVector, isMatrix, is1x1, is2x2] - Metadata [mrows, mcols] - Comparators [meql] - Selectors [extractMatrix, mrow, mcol, msubset, mminor] - Matrix Arithmetic [madd, msub, mmul, mdiv] - Matrix OPerations [mtranspose, mcofactor, mdet1x1, mdet2x2, mdet, minv1x1, minverse, mtrace] - Elementary Row / Column Operations [mswapc, mswapr, maddc, maddr, mmulc, mmulr]. These are needed for solving linear equations via Echelon method - Pretty Print [mdump] * Routine documentation has the following structure: Parameter List --- Description --- Routine Example(s) Parameter list conventions include: - x | y | z -> One of x or y or z - [optional arguments ...] - Types: + s, s1, s2 -> string(s) + n, n1, n2 -> numeric + v, v1, v2 -> vector(s) + m, m1, m2 -> matrices */ /* ----------- */ makeVector : procedure expose (globals) (matdefs) /* s | n1 [, n2, ...] --- Returns a vector created by parsing, 's', or assembling, 'n1', 'n2' ... --- v = makeVector("1 2 3;") v = makeVector(1, 2, 3) */ argc = ARG() ; if argc == 0 then ; return NaN if argc == 1 then do v = ARG(1) ; argc = WORDS(v) end ; else do v = NULL ; do i = 1 for argc ; v = v ARG(i) ; end ; v = STRIP(v) end return MTAG || 1 argc MTYPE_VECTOR || MHSEP || v || MRSEP makeMatrix : procedure expose (globals) (matdefs) /* s | v1 [, v2, ...] --- Returns a matrix created by parsing, 's', or assembling, 'v1', 'v2' ... --- m = makeMatrix("1 2 3;4 5 6;7 8 9;") m = makeMatrix(makeVector(1, 2, 3)) m = makeMatrix(makeVector(1, 2, 3), makeVector(4, 5, 6),, makeVector(7, 8, 9)) */ argc = ARG() ; if argc == 0 then ; return NaN if argc == 1 then do m = ARG(1) ; if isVector(m) then ; return m rows = COUNTSTR(MRSEP, m) cols = WORDS(SUBSTR(m, 1, POS(MRSEP, m) - 1)) rv = NULL ; do i = 1 for rows parse var m row (MRSEP) m ; rv = rv || row || MRSEP end end ; else do rows = argc ; rv = NULL ; do i = 1 for rows parse value ARG(i) with (MTAG) . cols . (MHSEP) data rv = rv || data end end select when cols == rows then ; type = MTYPE_REGULAR otherwise ; type = MTYPE_SINGULAR end return MTAG || rows cols type || MHSEP || STRIP(rv) makeDiagonal : procedure expose (globals) (matdefs) /* s | v | n1 [, n2, ...] --- Returns a square matrix with a leading diagonal having the values obtained by parsing, 's', assembling, 'v1', 'v2', or from, 'v' --- m = makeDiagonal("1 2 3;") m = makeDiagonal(1, 2, 3) m = makeDiagonal(makeVector(1, 2, 3)) */ argc = ARG() ; if argc == 0 then ; return NaN ONE_ONLY = TRUE ; chksum = 0 if argc == 1 then do v = ARG(1) ; if isVector(v) then do parse var v (MTAG) . cols . (MHSEP) data end ; else do cols = WORDS(SUBSTR(v, 1, POS(MRSEP, v) - 1)) ; data = v end parse var data row (MRSEP) . rows = cols ; rv = NULL ; do i = 1 for rows do j = 1 for cols if i == j then do parse var row item row chksum = chksum + item ; rv = rv item if item > 1 then ; ONE_ONLY = FALSE end ; else ; rv = rv 0 end rv = rv || MRSEP end end ; else do cols = argc ; rows = cols ; rv = NULL do i = 1 for rows do j = 1 for cols if i == j then do value = ARG(i) ; chksum = chksum + value ; rv = rv value if value > 1 then ; ONE_ONLY = FALSE end ; else ; rv = rv 0 end rv = rv || MRSEP end end select when chksum == 0 then ; type = MTYPE_ZERO when chksum == rows & ONE_ONLY then ; type = MTYPE_IDENTITY otherwise ; type = MTYPE_REGULAR end return MTAG || rows cols type || MHSEP ||, STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)) /* -- */ isMatrix : procedure expose (globals) (matdefs) /* m --- TRUE if 'm' determined to be a matrix --- if \isMatrix(m) then ; return NaN */ parse value WORD(ARG(1), 1) with marker +3 rows . return marker == MTAG & rows >= 1 isVector : procedure expose (globals) (matdefs) /* m --- TRUE if 'm' determined to be a vector, a 1-row matrix. Note that a vector is still a matrix, merely a more specialised one --- if \isVector(v) then ; return NaN */ parse value WORD(ARG(1), 1) with marker +3 rows . return marker == MTAG & rows == 1 is2x2 : procedure expose (globals) (matdefs) /* m --- TRUE if 'm' determined to be a 2x2 matrix. Required in recursive matrix operations like determinant, cofactor and inverse --- if is2x2(m) then ; return mdet2x2(m) */ parse value ARG(1) with (MTAG) rows cols . (MHSEP) . return rows == cols & rows == 2 is1x1 : procedure expose (globals) (matdefs) /* m --- TRUE if 'm' determined to be a 1x1 matrix, a single-element, square matrix. Required in recursive matrix operations like determinant, cofactor and inverse --- if is1x1(m) then ; return mdet1x1(m) */ parse value ARG(1) with (MTAG) rows cols . (MHSEP) . return rows == cols & rows == 1 /* ----------- */ mrows : procedure expose (globals) (matdefs) /* m --- Returns number of rows matrix, 'm', possesses --- rows = mrows(m) */ parse value ARG(1) with (MTAG) rows . . (MHSEP) . ; return rows mcols : procedure expose (globals) (matdefs) /* m --- Returns number of columns matrix, 'm', possesses --- columns = mcols(m) */ parse value ARG(1) with (MTAG) . cols . (MHSEP) . ; return cols /* -- */ meql : procedure expose (globals) (matdefs) /* m1, m2 --- TRUE if 'm1' and 'm2' determined to be equal, that is: * Structurally identical i.e. same number of rows and columns * Same type * Same contents --- if meql(m1, m2) then ; return ... */ return ARG(1) == ARG(2) /* -- */ extractMatrix : procedure expose (globals) (matdefs) /* m --- Returns matrix data sans header --- data = extractMatrix(m) */ parse value ARG(1) with (MTAG) . . . (MHSEP) data ; return data mrow : procedure expose (globals) (matdefs) /* m, row --- Extracts specified row number, 'row', from matrix, 'm' --- row = mrow(m, 2) */ parse value ARG(1) with (MTAG) rows . . (MHSEP) data ; r = ARG(2) if r < 1 | r > rows then ; return NaN do i = 1 while data <> NULL parse var data row (MRSEP) data ; if i == r then ; leave end ; return row mcol : procedure expose (globals) (matdefs) /* m, col --- Extracts specified column number, 'col', from matrix, 'm' --- column = mcol(m, 2) */ parse value ARG(1) with (MTAG) . cols . (MHSEP) data ; c = ARG(2) if c < 1 | c > cols then ; return NaN col = NULL ; do while data <> NULL parse var data row (MRSEP) data ; col = col WORD(row, c) end ; return STRIP(col) msubset : procedure expose (globals) (matdefs) /* m, row, col [[, xlen], ylen] --- Returns a matrix extracted from matrix, 'm', data starting from row number, 'row', and column number, 'col'. Entire length of specified items is returned unless an optional length value is specified for each item --- m2 = msubset(m1, 2, 3) m2 = msubset(m1, 2, 3, 5, 5) m2 = msubset(m1, 2, 3, , 5) m2 = msubset(m1, 2, 3, 5) */ argc = ARG() ; rv = NaN if argc <> 3 | argc <> 5 then ; return rv x = ARG(2) ; y = ARG(3) parse value ARG(1) with (MTAG) rows cols . (MHSEP) data if x > rows | y > cols then ; return rv xlen = rows ; if ARG(4, 'E') then ; xlen = ARG(4) ylen = cols ; if ARG(5, 'E') then ; ylen = ARG(5) /* ... to be completed ... */ return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mminor : procedure expose (globals) (matdefs) /* m, row, col --- Returns a matrix extracted from matrix, 'm', data consisting of all rows and columns except the specified row number, 'row', and column number, 'col'. Such a matrix is known as the 'minor' and is needed for computing a matrix's determinant --- minor = mminor(m, 1, 3) */ argc = ARG() ; rv = NaN if argc <> 3 then ; return rv x = ARG(2) ; y = ARG(3) parse value ARG(1) with (MTAG) rows cols . (MHSEP) data if x > rows | y > cols then ; return rv rv = NULL ; do i = 1 while data <> NULL parse var data row (MRSEP) data if i == x then ; iterate do j = 1 while row <> NULL parse var row item row if j == y then ; iterate rv = rv item end ; rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) /* -- */ mdump : procedure expose (globals) (matdefs) /* m [, width] --- Pretty prints matrix, 'm'; default width used unless specified --- call mdump m call mdump m, 8 */ parse value ARG(1) with (MTAG) . . . (MHSEP) data cellwidth = 4 ; if ARG(2, 'E') then ; cellwidth = ARG(2) do while data <> NULL parse var data row (MRSEP) data out = "|" ; do while row <> NULL parse var row item row ; out = out LEFT(item, cellwidth) "|" end say out end ; return /* -- */ madd : procedure expose (globals) (matdefs) /* m1, m2 | n --- Returns matrix where: * 'n' added to each element, or * corresponding elements of matrices added together [each matrix must have the same size i.e. m1:RxC == m2:RxC] --- m3 = madd(m1, m2) m3 = madd(m1, 5) */ m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN if \isMatrix(m1) then ; return rv parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data if isMatrix(m2) then do parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data if m1rows <> m2rows | m1cols <> m2cols then ; return rv rv = NULL ; do while m1data <> NULL parse var m1data m1row (MRSEP) m1data parse var m2data m2row (MRSEP) m2data do while m1row <> NULL parse var m1row m1item m1row ; parse var m2row m2item m2row rv = rv (m1item + m2item) end ; rv = rv || MRSEP end end ; else do rv = NULL ; do while m1data <> NULL parse var m1data m1row (MRSEP) m1data do while m1row <> NULL parse var m1row m1item m1row ; rv = rv (m1item + m2) end ; rv = rv || MRSEP end end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) msub : procedure expose (globals) (matdefs) /* m1, m2 | n --- Returns matrix where: * 'n' subtracted from to each element, or * corresponding elements of matrices subtracted [each matrix must have the same size i.e. m1:RxC == m2:RxC] --- m3 = msub(m1, m2) m3 = msub(m1, 5) */ m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN if \isMatrix(m1) then ; return rv parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data if isMatrix(m2) then do parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data if m1rows <> m2rows | m1cols <> m2cols then ; return rv rv = NULL ; do while m1data <> NULL parse var m1data m1row (MRSEP) m1data parse var m2data m2row (MRSEP) m2data do while m1row <> NULL parse var m1row m1item m1row ; parse var m2row m2item m2row rv = rv (m1item - m2item) end ; rv = rv || MRSEP end end ; else do rv = NULL ; do while m1data <> NULL parse var m1data m1row (MRSEP) m1data do while m1row <> NULL parse var m1row m1item m1row ; rv = rv (m1item - m2) end ; rv = rv || MRSEP end end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mmul : procedure expose (globals) (matdefs) /* m1, m2 | n --- Returns matrix where: * 'n' multiplied with each element, or * corresponding elements of matrices multiplied [matrices must meet condition m1:C == m2:R; m3 -> m1:Rxm2:C] --- m3 = mmul(m1, m2) m3 = mmul(m1, 5) */ m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN if \isMatrix(m1) then ; return rv parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data if isMatrix(m2) then do parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data if m1cols <> m2rows then ; return rv /* Extract matrix data, load into compound variables, 'a' and 'b' */ r = 1 ; c = 1 ; a.0 = m1rows ; a.0.0 = m1cols do while m1data <> NULL parse var m1data m1row (MRSEP) m1data do while m1row <> NULL parse var m1row item m1row ; a.r.c = item c = c + 1 end r = r + 1 ; c = 1 end r = 1 ; c = 1 ; b.0 = m2rows ; b.0.0 = m2cols do while m2data <> NULL parse var m2data m2row (MRSEP) m2data do while m2row <> NULL parse var m2row item m2row ; b.r.c = item c = c + 1 end r = r + 1 ; c = 1 end /* Perform multiplication using compound variables */ do i = 1 to a.0 /* m1rows */ do j = 1 to b.0.0 /* m2cols */ c.i.j = 0 ; do k = 1 to b.0 /* m2rows */ c.i.j = c.i.j + a.i.k * b.k.j end end end /* Return computed values as new matrix */ rv = NULL ; do i = 1 to m1rows do j = 1 to m2cols ; rv = rv c.i.j ; end rv = rv || MRSEP end end ; else do rv = NULL ; do while m1data <> NULL parse var m1data m1row (MRSEP) m1data do while m1row <> NULL parse var m1row m1item m1row ; rv = rv (m1item * m2) end ; rv = rv || MRSEP end end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mdiv : procedure expose (globals) (matdefs) /* m1, m2 | n --- Returns matrix where: * 'n' divided into each element, or * corresponding elements of matrices divided [matrices must meet condition m1:C == m2:R, and m2 must be square; m3 -> m1:Rxm2:C] --- m3 = mdiv(m1, m2) m3 = mdiv(m1, 5) */ m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN if \isMatrix(m1) then ; return rv parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data if isMatrix(m2) then do parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data if m1cols <> m2rows | m2cols <> m2rows then ; return rv return mmul(m1, minverse(m2)) end ; else do rv = NULL ; do while m1data <> NULL parse var m1data m1row (MRSEP) m1data do while m1row <> NULL parse var m1row m1item m1row ; rv = rv (m1item / m2) end ; rv = rv || MRSEP end end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) /* -- */ maddr : procedure expose (globals) (matdefs) /* m, n | v, row --- Returns matrix with all elements of row number, 'row', of matrix, 'm': * Having, 'n' added, or * corresponding elements from, 'v', added [assumes m:R == v:R] --- m2 = maddr(m1, 4, 3) m2 = maddr(m1, makeVector("1 2 3;"), 3) */ m = ARG(1) ; v = ARG(2) ; row = ARG(3) ; rv = NaN ; isVector = FALSE if \isMatrix(m) then ; return rv parse var m (MTAG) mrows mcols . (MHSEP) mdata if isVector(v) then do parse var v (MTAG) . vcols . (MHSEP) vrow (MRSEP) if row > mrows | mcols <> vcols then ; return rv isVector = TRUE end rv = NULL ; do i = 1 while mdata <> NULL parse var mdata mrow (MRSEP) mdata if i == row then do while mrow <> NULL parse var mrow mitem mrow if isVector then ; parse var vrow vitem vrow ; else ; vitem = v rv = rv (mitem + vitem) end else rv = rv || mrow rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) maddc : procedure expose (globals) (matdefs) /* m, n | v, col --- Returns matrix with all elements of column number, 'col', of matrix, 'm': * Having, 'n' added, or * corresponding elements from, 'v', added [assumes m:C == v:C] --- m2 = maddc(m1, 4, 3) m2 = maddc(m1, makeVector("1 2 3;"), 3) */ m = ARG(1) ; v = ARG(2) ; col = ARG(3) ; rv = NaN ; isVector = FALSE if \isMatrix(m) then ; return rv parse var m (MTAG) mrows mcols . (MHSEP) mdata if isVector(v) then do parse var v (MTAG) . vcols . (MHSEP) vrow (MRSEP) if col > mcols | mrows <> vcols then ; return rv isVector = TRUE end rv = NULL ; do while mdata <> NULL parse var mdata mrow (MRSEP) mdata do j = 1 while mrow <> NULL parse var mrow mitem mrow if j == col then do if isVector then ; parse var vrow vitem vrow ; else ; vitem = v rv = rv (mitem + vitem) end ; else do rv = rv mitem end end rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mmulr : procedure expose (globals) (matdefs) /* m, n, row --- Returns matrix with all elements of row number, 'row', of matrix, 'm', multiplied by, 'n' --- m2 = mmulr(m1, 4, 3) */ m = ARG(1) ; n = ARG(2) ; row = ARG(3) ; rv = NaN if \isMatrix(m) then ; return rv parse var m (MTAG) mrows mcols . (MHSEP) mdata if row > mrows then ; return rv rv = NULL ; do i = 1 while mdata <> NULL parse var mdata mrow (MRSEP) mdata if i == row then do while mrow <> NULL parse var mrow mitem mrow ; rv = rv (mitem * n) end else rv = rv mrow rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mmulc : procedure expose (globals) (matdefs) /* m, n, col --- Returns matrix with all elements of column number, 'col', of matrix, 'm', multiplied by, 'n' --- m2 = mmulc(m1, 4, 3) */ m = ARG(1) ; n = ARG(2) ; col = ARG(3) ; rv = NaN if \isMatrix(m) then ; return rv parse var m (MTAG) mrows mcols . (MHSEP) mdata if col > mcols then ; return rv rv = NULL ; do while mdata <> NULL parse var mdata mrow (MRSEP) mdata do j = 1 while mrow <> NULL parse var mrow mitem mrow if j == col then ; rv = rv (mitem * n) else ; rv = rv mitem end rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mswapr : procedure expose (globals) (matdefs) /* m, x, y --- Returns matrix with row numbers, 'x', and 'y', of matrix, 'm', swapped --- m2 = mswapr(m1, 1, 3) */ m = ARG(1) ; x = ARG(2) ; y = ARG(3) ; rv = NaN if \isMatrix(m) then ; return rv parse var m (MTAG) rows . . (MHSEP) data if x > rows | y > rows then ; return rv xr = mrow(m, x) ; yr = mrow(m, y) rv = NULL ; do i = 1 while data <> NULL parse var data row (MRSEP) data if i == x then ; rv = rv yr else ; if i == y then ; rv = rv xr else ; rv = rv row rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mswapc : procedure expose (globals) (matdefs) /* m, x, y --- Returns matrix with column numbers, 'x', and 'y', of matrix, 'm', swapped --- m2 = mswapc(m1, 1, 3) */ m = ARG(1) ; x = ARG(2) ; y = ARG(3) ; rv = NaN if \isMatrix(m) then ; return rv parse var m (MTAG) rows cols . (MHSEP) data if x > cols | y > cols then ; return rv r = 1 ; c = 1 ; a.0 = rows ; a.0.0 = cols do while data <> NULL parse var data row (MRSEP) data do while row <> NULL parse var row item row ; a.r.c = item c = c + 1 end r = r + 1 ; c = 1 end do i = 1 to a.0 tmp = a.i.x ; a.i.x = a.i.y ; a.i.y = tmp end rv = NULL ; do i = 1 to a.0 do j = 1 to a.0.0 ; rv = rv a.i.j ; end rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) /* -- */ mtranspose : procedure expose (globals) (matdefs) /* m --- Returns matrix consisting of the transpose of 'm' [i.e. corresponding row / column positions swapped] --- transpose = mtranspose(m) */ m = ARG(1) ; rv = NaN if \isMatrix(m) then ; return rv parse var m (MTAG) rows cols . (MHSEP) data r = 1 ; c = 1 ; a.0 = rows ; a.0.0 = cols do while data <> NULL parse var data row (MRSEP) data do while row <> NULL parse var row item row ; a.r.c = item c = c + 1 end r = r + 1 ; c = 1 end rv = NULL ; do j = 1 to a.0.0 do i = 1 to a.0 ; rv = rv a.i.j ; end rv = rv || MRSEP end return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))) mcofactor : procedure expose (globals) (matdefs) /* m, i, j --- Returns the cofactor of the matrix; sign determined via values of row and column numbers, 'i', and 'j', respectively --- cofactor = mcofactor(m, i, j) */ m = ARG(1) ; i = ARG(2) ; j = ARG(3) if ((i + j) // 2) <> 0 then ; sign = -1 ; else ; sign = 1 if is1x1(m) then ; return sign * mdet(m) return sign * mdet(mminor(m, i, j)) mdet1x1 : procedure expose (globals) (matdefs) /* m --- Returns the determinant of a 1x1 square matrix --- determinant = mdet1x1(m) */ parse value ARG(1) with (MTAG) . . . (MHSEP) a (MRSEP) . return a mdet2x2 : procedure expose (globals) (matdefs) /* m --- Returns the determinant of a 2x2 square matrix --- determinant = mdet2x2(m) */ parse value ARG(1) with (MTAG) . . . (MHSEP) a b (MRSEP) c d (MRSEP) . return a * d - b * c mdet : procedure expose (globals) (matdefs) /* m --- Returns the determinant of the square matrix --- determinant = mdet(m) */ m = ARG(1) if is1x1(m) then ; return mdet1x1(m) if is2x2(m) then ; return mdet2x2(m) parse var m (MTAG) . cols . (MHSEP) row (MRSEP) . det = 0 ; do j = 1 to cols det = det + WORD(row, j) * mcofactor(m, 1, j) end ; return det minv1x1 : procedure expose (globals) (matdefs) /* m --- Returns the inverse of the 1x1 matrix --- inverse = minv1x1(m) */ parse value ARG(1) with (MTAG) . . . (MHSEP) a (MRSEP) . return 1 / a minverse : procedure expose (globals) (matdefs) /* m --- Returns the inverse of the square matrix --- inverse = minverse(m) */ m = ARG(1) ; if \isMatrix(m) then ; return NaN parse var m (MTAG) rows cols . (MHSEP) data if rows <> cols then ; return NaN if is1x1(m) then ; return makeVector(minv1x1(m)) rv = NULL ; det = mdet(m) ; do i = 1 for rows do j = 1 for cols ; rv = rv (mcofactor(m, i, j) / det) ; end rv = rv || MRSEP end return mtranspose(makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))) mtrace : procedure expose (globals) (matdefs) /* m --- Returns the trace of the square matrix [i.e. sum of the leading diagonal elements] --- trace = mtrace(m) */ m = ARG(1) ; trace = 0 if \isMatrix(m) then ; return NaN parse var m (MTAG) rows cols . (MHSEP) data if rows <> cols then ; return NaN do i = 1 while data <> NULL parse var data row (MRSEP) data do j = 1 while row <> NULL parse var row item row ; if i == j then ; trace = trace + item end end return trace /* @@PLEAC@@_2.15 */ /* ------------------------------------------------------------------ */ /* REXX offers no complex number-handling BIF's. However, there are */ /* native-REXX implementations available from: */ /* */ /* http://www.geocities.com/zabrodskyvlada/aat/a_contents.html */ /* */ /* just as there are implementations of many other classic algorithms.*/ /* */ /* The code below, however, is not adapted from the examples at this */ /* site, but is instead inspired by a Scheme implementation in the */ /* very well known publication, 'Structure and Interpretation of Prog-*/ /* rams' by Abelson and Sussman. See: */ /* */ /* http://mitpress.mit.edu/sicp/full-text/sicp/book/node43.html */ /* ------------------------------------------------------------------ */ /* Using 'rexxMath' Library Routines */ /* Load [rexxMath] math functions from external library */ call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs' call mathLoadFuncs /* ----------- */ a = makeComplex(3, 5) ; b = makeComplex(2, -2) c = cmul(a, b) say "c =" asComplex(c) /* ----------- */ c = cmul(makeComplex(3, 5), makeComplex(2, -2)) say "c =" asComplex(c) /* ----------- */ d = makeComplex(3, 4) say "d =" asComplex(d) say "sqrt(d) =" asComplex(csqrt(d)) /* ----------- */ say "Rectangualar Notation:" asComplex(csqrt(makeComplex(3, 4))) say "Polar Notation:" asPolar(csqrt(makeComplex(3, 4))) /* ----------- */ /* Unload math functions */ call mathDropFuncs exit 0 /* ----------------------------- */ makeComplex : procedure return " " ARG(1) " " ARG(2) makeFromPolar : procedure r = ARG(1) ; a = ARG(2) return makeComplex(r * Cos(a), r * Sin(a)) real : procedure parse value ARG(1) with "" real . ; return real imag : procedure parse value ARG(1) with "" . imag . ; return imag magnitude : procedure parse value ARG(1) with "" real imag . return Sqrt(real * real + imag * imag) angle : procedure parse value ARG(1) with "" real imag . return ATan(imag, real) isNaN : procedure return ARG(1) == "NaN" isComplex : procedure return LEFT(ARG(1), 3) == "" asComplex : procedure z = ARG(1) ; if \isComplex(z) then ; return "NaN" else ; do parse var z "" real imag . dec = 3 ; if ARG(2, E) then ; dec = ARG(2) sign = "+" ; if imag < 0 then ; sign = "-" return FORMAT(real,, dec) sign FORMAT(ABS(imag),, dec) || "i" end asPolar : procedure z = ARG(1) ; if \isComplex(z) then ; return "NaN" else ; do parse var z "" real imag . dec = 3 ; if ARG(2, E) then ; dec = ARG(2) return "(" || FORMAT(magnitude(z),, dec) || ",", FORMAT(angle(z),, dec) || ")" end /* ----------- */ cadd : procedure z1 = ARG(1) ; z2 = ARG(2) if \isComplex(z1) | \isComplex(z1) then ; return "NaN" rz1 = real(z1) ; rz2 = real(z2); iz1 = imag(z1) ; iz2 = imag(z2) return makeComplex((rz1 + rz2), (iz1 + iz2)) csub : procedure z1 = ARG(1) ; z2 = ARG(2) if \isComplex(z1) | \isComplex(z1) then ; return "NaN" rz1 = real(z1) ; rz2 = real(z2); iz1 = imag(z1) ; iz2 = imag(z2) return makeComplex((rz1 - rz2), (iz1 - iz2)) cmul : procedure z1 = ARG(1) ; z2 = ARG(2) if \isComplex(z1) | \isComplex(z1) then ; return "NaN" mz1 = magnitude(z1) ; mz2 = magnitude(z2) ; az1 = angle(z1) az2 = angle(z2) return makeComplex((mz1 * mz2), (az1 + az2)) cdiv : procedure z1 = ARG(1) ; z2 = ARG(2) if \isComplex(z1) | \isComplex(z1) then ; return "NaN" mz1 = magnitude(z1) ; mz2 = magnitude(z2) ; az1 = angle(z1) az2 = angle(z2) return makeComplex((mz1 / mz2), (az1 - az2)) csqrt : procedure z = ARG(1) ; if \isComplex(z) then ; return "NaN" r = magnitude(z) ; a = angle(z) u = makeComplex(Sqrt(r) * Cos(a / 2.0), Sqrt(r) * Sin(a / 2.0)) t = makeComplex(-real(u), -imag(u)) if \(angle(u) < angle(t)) then ; u = t return u /* @@PLEAC@@_2.16 */ /* ------------------------------------------------------------------ */ /* Whilst binary, hexadecimal, decimal interconversion is quite well */ /* supported in REXX, octal support is non-existent. This is because */ /* of REXX's mainframe heritage: octal is simply not used on these */ /* platforms. */ /* */ /* It is, however, quite easy to implement suitable custom functions */ /* as has been done here. */ /* ------------------------------------------------------------------ */ hexadecimal = "2A" ; octal = "10" number = X2D(hexadecimal) number = O2D(octal) hexadecimal = D2X(number) octal = D2O(number) /* ----------------------------- */ /* Assumes following input formats: decimal - plain digits octal - leading '0' character hexadecimal - leading '0x' | '0X' character sequence e.g. 14 -> 016 -> 0xE */ call CHAROUT , "Gimme a number in decimal, octal, or hex: " parse value LINEIN() with "0x" hex =1 "0" oct =1 dec select when hex \= NULL then ; number = X2D(hex) when oct \= NULL then ; number = O2D(oct) when dec \= NULL then ; number = dec end say number "d" D2X(number) "h" D2O(number) "o" exit 0 /* ----------- */ D2O : procedure expose (globals) parse arg d, o do until d = 0 ; r = d // 8 ; d = d % 8 ; o = r || o ; end return o O2D : procedure expose (globals) parse value ARG(1) LENGTH(ARG(1)) 0 with ov sp dv do i = 1 for sp parse var ov =(i) oi +1 if oi == "8" | oi == "9" then ; return NULL parse value (dv + ((8 ** (sp - i)) * oi)) with dv end return dv /* @@PLEAC@@_2.17 */ /* ------------------------------------------------------------------ */ /* REXX-idiomatic approach to this task is via 'do' loop and string */ /* manipulation BIF since it is cross-platform and guarantees the best*/ /* performance. However, a recursive solution is easily implementable */ /* ------------------------------------------------------------------ */ /* REXX-idiomatic 'do' loop and BIF Example */ commified = commify("12345678") ; say commified exit 0 /* ----------- */ commify : procedure expose (globals) s = ARG(1) ; l = LENGTH(s) - 3 do i = l by -3 while i > 0 ; s = INSERT(",", s, i) ; end return s /* ----------------------------- */ /* Recursive Implementation */ commified = commify("12345678") ; say commified exit 0 /* ----------- */ commify : procedure expose (globals) return STRIP(commify_(REVERSE(ARG(1))), 'T', ",") commify_ : procedure expose (globals) parse value ARG(1) with car +3 cdr if car == NULL then ; return NULL return commify_(cdr) || REVERSE(car) || "," /* @@PLEAC@@_2.18 */ /* ------------------------------------------------------------------ */ /* REXX-idiomatic approach to this task is via 'do' loop and the PARSE*/ /* instruction. */ /* ------------------------------------------------------------------ */ duration = 1 say "It took" duration pluralise(duration, "hour") say duration pluralise(duration, "hour"), pluralise(duration, "", "is", "are"), "enough" duration = 5 say "It took" duration pluralise(duration, "hour") say duration pluralise(duration, "hour"), pluralise(duration, "", "is", "are"), "enough" exit 0 /* ----------- */ pluralise : procedure value = ARG(1) ; root = ARG(2) singular = "" ; if ARG(3, 'E') then ; singular = ARG(3) plural = "s" ; if ARG(4, 'E') then ; plural = ARG(4) if value == 1 then ; return root || singular return root || plural /* ----------------------------- */ list = "mess index leaf puppy" do while list <> "" parse var list word list say LEFT(word, 6) "->" plural(word) end exit 0 /* ----------- */ plural : procedure endings = "ss:sses ph:phes sh:shes ch:ches ey:eys ix:ices", "ff:ffs z:zes f:ves y:ies s:ses x:xes" singular = ARG(1) ; plural = singular ; do while endings <> NULL parse var endings key ":" value endings /* === Both approaches below work. First one makes exclusive use of string manipulation BIF's, while the second one uses the PARSE instruction to split a string, and is probably faster /* 1 */ if RIGHT(singular, LENGTH(key)) == key then do plural = LEFT(singular, LENGTH(singular) - LENGTH(key)) || value leave end /* 2 */ pos = LENGTH(singular) - LENGTH(key) parse var singular car +(pos) cdr if cdr == key then do ; plural = car || value ; leave ; end === */ pos = LENGTH(singular) - LENGTH(key) parse var singular car +(pos) cdr if cdr == key then do ; plural = car || value ; leave ; end end return plural /* @@PLEAC@@_3.0 */ /* ------------------------------------------------------------------ */ /* Unlike Perl, REXX has no predefined, global date/time variables */ /* [e.g. '$year', '$mday' etc]. Instead, native date/time support is */ /* offered by two built-in functions [BIFs]: */ /* */ /* * DATE([option_out [, date [, option_in]]]) */ /* * TIME([option_out [, time [, option_in]]]) */ /* */ /* These BIFs operate in two modes: */ /* */ /* * Generate a date/time string formatted according to 'option_out' */ /* using the current date/time */ /* */ /* * Accept a date/time string in format specified by 'option_in', and*/ /* use it to generate a string as specified by 'option_out' */ /* */ /* Typical REXX code will see either direct use of these BIF's along */ /* with parsing / formatting code, or more likely, used as part of */ /* custom date/time routines. It is this latter approach that will be */ /* used here as most of the examples use routines from the REXXToolkit*/ /* Library [see Appendix for details]. */ /* */ /* It is worth mentioning that REXX, unlike Perl, and other languages,*/ /* sports no 'date' or 'time' type / structure / object, and that such*/ /* values are always represented as strings. It is, however, quite a */ /* simple matter to implement functionally equivalent entities. This */ /* has been done: a 'super'-string, the Date-Time-String [DTS], is */ /* used in many of the examples. While useful in itself the motivation*/ /* for implementing it has been to show how type / structure / object */ /* can be implemented procedurally using non-mutable strings. */ /* ------------------------------------------------------------------ */ /* @@PLEAC@@_3.1 */ /* ------------------------------------------------------------------ */ /* The usual way of obtaining the current date is to invoke the DATE()*/ /* BIF to generate a recognised date format, parse, then manipulate, */ /* the resulting string as required. */ /* */ /* However since additional string manipulation of the resulting item */ /* is usually required, it is usual to see custom native REXX routines*/ /* implemented for such tasks. The examples make use of such as set of*/ /* routines [REXXToolkit Library - see appendix for details] */ /* ------------------------------------------------------------------ */ /* Generate, then parse, date string in 'standard' format: YYYYMMDD */ parse value DATE('S') with year +4 month +2 day /* ----------------------------- */ /* Formatting via basic string manipulation */ SEP = SPACE say "The current date is" year || SEP || month || SEP || day SEP = DATESEP say "The current date is" year || SEP || month || SEP || day /* ----------------------------- */ /* Using 'makeYMD' helper function */ say "The current date is" makeYMD(SPACE, year, month, day) say "The current date is" makeYMD(SPACE) say "The current date is" makeYMD(DATESEP, year, month, day) say "The current date is" makeYMD(DATESEP) say "The current date is" makeYMD() /* Optional date validity check */ current = makeYMD() if current == NULL then ; current = "*invalid date*" say "The current date is" current /* Alternative date validity check */ current = makeYMD() if \isYMD(current) then ; current = "*invalid date*" say "The current date is" current /* ----------------------------- */ /* Using 'localtime' and 'YMDHMS...' helper functions */ say "The current date is" YMDHMS2YMD(EPS2YMDHMS(localtime()), SPACE) say "The current date is" YMDHMS2YMD(EPS2YMDHMS(localtime())) /* ----------------------------- */ /* Using 'strftime' helper function */ say "The current date is" strftime("+%Y %m %d") say "The current date is" strftime("+%Y-%m-%d") /* @@PLEAC@@_3.2 */ /* ------------------------------------------------------------------ */ /* UNIX-derived languages Perl and C store date/time values as 32 bit */ /* entities - epoch seconds [seconds since Jan 1, 1970]. This provides*/ /* for a simple, efficient, easily manipuable, and readily convertable*/ /* format [i.e. minimal storage use, easy to perform date arithmetic].*/ /* */ /* Since all REXX values are strings, and all arithmetic is string- */ /* based, there are no efficiency benefits in doing the same in REXX. */ /* However, since epoch second use is so widespread, the 'DATE' BIF */ /* supports it via the 'T' option, thus allowing for some of the same */ /* Perl / C techniques to be mimiced in REXX. */ /* ------------------------------------------------------------------ */ /* Get current date/time in Epoch Seconds */ /* Local timezone */ say "Epoch seconds:" DATE('T') /* REXX BIF */ say "Epoch seconds:" localtime() /* Custom routines */ say "Epoch seconds:" strftime("+%s") /* UTC */ say "Epoch seconds:" gmtime() /* ----------------------------- */ /* Convert YMDHMS-formatted current date/time to Epoch Seconds */ ymdhms = makeYMDHMS(makeYMD(), makeHMS()) /* Convert to Epoch Seconds [alternative: localtime(ymdhms)] */ eps = YMDHMS2EPS(ymdhms) /* ----------------------------- */ /* Convert YMDHMS-formatted date/time to Epoch Seconds */ /* Literal string in YMDHMS format */ ymdhms = "2004-04-17 13:03:55" /* Alternatively, make YMDHMS-formatted date/time from components */ y = 2004 ; mth = 4 ; d = 17 ; h = 13 ; m = 3 ; s = 55 ymdhms = makeYMDHMS(makeYMD(DATESEP, y, mth, d),, makeHMS(TIMESEP, h, m, s)) /* Convert to Epoch Seconds [alternative: localtime(ymdhms)] */ eps = YMDHMS2EPS(ymdhms) /* @@PLEAC@@_3.3 */ /* ------------------------------------------------------------------ */ /* See comments in previous section header */ /* ------------------------------------------------------------------ */ /* Convert Epoch Seconds to date/time [YMDHMS-format] */ eps = localtime() /* or: gmtime(), or DATE('T') */ /* Convert to YMDHMS */ ymdhms = EPS2YMDHMS(eps) /* ----------------------------- */ /* Parse YMDHMS into components, format and print */ parse var ymdhms, year (DATESEP) month (DATESEP) day, hour (TIMESEP) minute (TIMESEP) second fmtdate = hour || TIMESEP || minute || TIMESEP || second || "-" ||, year || "/" || month || "/" || day say "Dateline:" fmtdate /* ----------------------------- */ /* Use helpers to suitably format date for printing */ fmtdate = YMDHMS2HMS(ymdhms, TIMESEP) || "-" || YMDHMS2YMD(ymdhms, "/") say "Dateline:" fmtdate /* @@PLEAC@@_3.4 */ /* ------------------------------------------------------------------ */ /* Date/time arithmetic may be performed: */ /* */ /* * Directly on date/time components */ /* * Converting to a base value, performing arithmetic, then back to */ /* date/time format */ /* */ /* REXX supports base value conversion approach via 'DATE' and 'TIME' */ /* BIFs, and does so in two ways: */ /* */ /* * Base Date Method */ /* * UNIX-derived 'epoch seconds' Method */ /* */ /* The latter method is widely used so will not be described, but the */ /* examples well illustrate its usage. The 'base date' method is day */ /* based [days since 1 Jan 0001 AD], and quite simple to use if date */ /* arithmetic is day-based. If finer granularity is needed then both */ /* the 'DATE' and 'TIME' BIF's must be used making this method less */ /* convenient to use. Despite this, it is the method of choice if */ /* cross-platform portability is a concern as not all REXX interpreter*/ /* are guaranteed to support the 'epoch seconds' method. */ /* ------------------------------------------------------------------ */ when = now + difference then = now - difference /* ----------------------------- */ /* Helper function use: 'dateOffset', and 'dateInterval' */ now = YMDHMS2EPS(makeYMDHMS(makeYMD(DATESEP, 2003, 8, 6), makeHMS())) diff1 = dateOffset("day=1") ; diff2 = dateOffset("weeks=-2") say "One day in the future is:" EPS2YMDHMS(now + diff1) say "Two weeks in the past is:" EPS2YMDHMS(now + diff2) d1 = YMDHMS2EPS(makeYMDHMS(makeYMD(DATESEP, 2003, 8, 6),, makeHMS(TIMESEP))) d2 = YMDHMS2EPS(makeYMDHMS(makeYMD(DATESEP, 2000, 8, 6),, makeHMS(TIMESEP))) interval = d1 - d2 say "Interval - weeks:" dateInterval("weeks", interval) say "Interval - days:" dateInterval("days", interval) say "Interval - hours:" dateInterval("hours", interval) say "Interval - minutes:" dateInterval("minutes", interval) say "Interval - seconds:" dateInterval("seconds", interval) /* ----------------------------- */ /* Epoch second-based arithmetic */ /* 18th January, 1973 3:45:50 am */ birthtime = YMDHMS2EPS(makeYMD(DATESEP, 1973, 1, 18), makeHMS(TIMESEP, 3, 45, 50)) interval = 5 + , /* 5 seconds */ 17 * 60 + , /* 17 minutes */ 2 * 60 * 60 + , /* 2 hours */ 55 * 60 * 60 * 24 /* 55 days */ then = birthtime + interval say "Then is:" YMDHMS2UNIX(EPS2YMDHMS(then)) /* ----------- */ /* REXX 'Base Date'-based arithmetic */ /* 18th January, 1973 3:45:50 am */ bday = DATE('B', "19730118", 'S') ; btime = TIME('S', "03:45:50", 'N') interval_days = 55 ; interval_secs = 5 + 17 * 60 + 2 * 3600 then_days = bday + interval_days ; then_secs = btime + interval_secs parse value DATE('S', then_days, 'B'), TIME('N', then_secs, 'S'), LEFT(DATE('W', then_days, 'B'), 3), LEFT(DATE('M', then_days, 'B'), 3) with, year +4 month +2 day +2 hms downame monthname say "Then is:" downame monthname day hms year /* ----------------------------- */ /* 18th January, 1973 3:45:50 am */ birth = YMDHMS2EPS(makeYMD(DATESEP, 1973, 1, 18), makeHMS(TIMESEP, 3, 45, 50)) say "Nat was 55 days old on:", YMD2US(YMDHMS2YMD(EPS2YMDHMS(birth + dateOffset("days=55"))),," / ") /* ----------- */ /* 18th January, 1973 3:45:50 am */ bday = DATE('B', "19730118", 'S') parse value DATE('S', bday + 55, 'B') with year +4 month +2 day +2 say "Nat was 55 days old on:" month "/" day "/" year /* @@PLEAC@@_3.5 */ /* ------------------------------------------------------------------ */ /* See comments in previous section header */ /* ------------------------------------------------------------------ */ when = now + difference then = now - difference /* ----------------------------- */ bree = YMDHMS2EPS(makeYMD(DATESEP, 1981, 6, 16), makeHMS(TIMESEP, 4, 35, 25)) nat = YMDHMS2EPS(makeYMD(DATESEP, 1973, 1, 18), makeHMS(TIMESEP, 3, 45, 50)) diff = bree - nat say "There were" dateInterval("minutes", diff) "minutes", "between Nat and Bree" /* ----------- */ say "There were" dateInterval("weeks", diff) "weeks,", diff // dateOffset("weeks=1") % dateOffset("days=1") || ", days,", S2HMS(diff // dateOffset("days=1")) "between Nat and Bree" /* ----------- */ say "There were" dateInterval("days", diff) "days", "between Nat and Bree" /* @@PLEAC@@_3.6 */ /* ------------------------------------------------------------------ */ /* The REXX-idiomatic approach to this task is to perform arithmetic */ /* using the value obtained from the relevant 'DATE' BIF call. */ /* However, as with many other date/time tasks, packaging them as */ /* custom routines allows them to be more reliably, and conveniently */ /* performed. */ /* ------------------------------------------------------------------ */ /* REXX-idiomatic approach using 'DATE' BIF */ day_of_week = DATE('B') // 7 + 1 day_of_week = DATE('B', YMDHMS2EPS(ymdhms), 'T') // 7 + 1 day_of_year = DATE('D') day_of_year = DATE('D', YMDHMS2EPS(ymdhms), 'T') week_of_year = day_of_year % 7 + 1 /* ----------------------------- */ /* DTS Format ['extractDTS' / 'updateDTS' indices below]: yyyy-mm-dd hh:mm:ss +HHMM DOWNAME DOW DOY WOY EPS 1 2 3 4 5 6 7 8 9 10 11 12 */ dts = makeDTS(makeYMD(), makeHMS()) day_of_week = extractDTS(dts, 9) day_of_year = extractDTS(dts, 10) week_of_year = extractDTS(dts, 11) /* ----------------------------- */ day_of_week = strftime("+%w") day_of_year = strftime("+%j") week_of_year = strftime("+%W") /* ----------- */ day_of_week = getDOW() day_of_year = getDOY() week_of_year = getWOY() /* ----------------------------- */ ymdhms = makeYMDHMS(makeYMD(DATESEP, 1981, 6, 16), makeHMS(TIMESEP)) say YMDHMS2YMD(ymdhms, "/") "was a" getDOWName(ymdhms) say "in week" getWOY(ymdhms) || "." /* ----------- */ dts = makeDTS(makeYMD(DATESEP, 1981, 6, 16), makeHMS(TIMESEP)) say YMDHMS2YMD(DTS2YMDHMS(dts), "/") "was a" extractDTS(dts, 8) say "in week" extractDTS(dts, 11) || "." say YMDHMS2YMD(DTS2YMDHMS(dts), "/") "was a" getDOWName(dts) say "in week" getWOY(dts) || "." /* @@PLEAC@@_3.7 */ /* ------------------------------------------------------------------ */ /* REXX date/time validation can be performed a few ways: */ /* */ /* * Make 'DATE' / 'TIME' BIF calls, and check whether a SYNTAX */ /* condition is generated [indicating a 'bad' date/time value] */ /* * Parse date/time values, and check individual component values */ /* * Regular expressions [via 'RxRe' external library] */ /* */ /* The first approach is easy to implement, but probably best used */ /* to create custom validation routines rather than in inline code. */ /* This is because condition-checking requires the use of SIGNAL, and */ /* jumping to labels - such code is best quarantined within a routine */ /* body. */ /* */ /* The second approach sees the PARSE instruction used to break up */ /* date/time strings into components which are then conditionally */ /* tested. In short, very typical procedural code, of which several */ /* examples appear below. Of particular note is an implementation of */ /* the C-derived 'strptime' function, a very convenient validation */ /* routine. */ /* */ /* The third approach is language-neutral, and is available in most */ /* modern languages. Not all REXX interpreters can be expected to */ /* offer it since it depends on external library availability */ /* ------------------------------------------------------------------ */ /* Custom Validation Routine [REXXToolkit] Examples */ date = "1998-06-03" if \isYMD(date) then ; say "*invalid date*" time = "22:19:34" if \isHMS(date) then ; say "*invalid time*" /* ----------- */ parse var date yyyy (DATESEP) mm (DATESEP) dd if \acceptableYMDValues(yyyy, mm, dd) then ; say "*invalid date*" parse var time h (TIMESEP) m (TIMEEP) s if \acceptableHMSValues(h, m, s) then ; say "*invalid time*" /* ----------------------------- */ /* 'strptime' Examples */ /* *** incomplete *** */ /* ----------------------------- */ /* Regex-based Examples */ /* *** incomplete *** */ /* @@PLEAC@@_3.8 */ /* ------------------------------------------------------------------ */ /* Formatting date/time values for printing or other output purposes */ /* sees 'raw' components [e.g. year, month, etc] variously converted, */ /* and combined to meet requirements. Since such components are just */ /* strings in REXX, it amounts to no more than a string manipulation */ /* exercise. As such, no specialised date formatting facilities are */ /* offered - it is left to the programmer to perform as they see fit. */ /* A few things are worth mentioning: */ /* */ /* * The 'DATE' and 'TIME' BIF's allow some inter-format conversions */ /* but are too limited to be of much practical value on their own - */ /* additional string manipulation is nearly always required */ /* */ /* * The more common date formatting, conversion and validation tasks */ /* are packaged as native REXX 'helper' routines in the REXXToolkit */ /* */ /* * The UNIX-derived [now POSIX standard] 'strftime' facility and */ /* accompanying mini 'date formatting language' have proved to be so*/ /* versatile that a native REXX implementation is offered in the */ /* REXXToolkit's set of date/time routines */ /* ------------------------------------------------------------------ */ /* 'DATE' and 'TIME' examples */ ymd = "20050825" ; hms = "11:08:04" downame = DATE('W', ymd, 'S') ; monthname = DATE('M', ymd, 'S') parse var ymd year +4 month +2 day /* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */ unix = LEFT(downame, 3) LEFT(monthname, 3) day hms year /* As per Perl example */ say "'DATE' gives:" downame month || "/" || day || "/" || RIGHT(year, 2) /* ----------------------------- */ /* 'strftime' examples */ ymdhms = "2005-08-25 11:08:04" /* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */ unix = strftime("+%c", ymdhms) unix = strftime("+%a %b %d %T %Y", ymdhms) /* As per Perl example */ say "strftime gives:" strftime("+%A %D", ymdhms) /* ----------------------------- */ /* Miscellaneous REXXToolkit routines examples */ /* Year-Month-Day Formats */ ymd = makeYMD() /* 2005-08-25 */ say ymd say makeYMD("/") /* 2005/08/25 */ say makeYMD(SPACE) /* 2005 08 25 */ say makeYMD(NULL) /* 20050825 */ /* Other Year-Month-Day Formats */ say YMD2US(ymd) /* 08/25/2005 */ say YMD2UK(ymd) /* 25/08/2005 */ say YMD2ISOWD(ymd) /* 2005-W34-4 */ say YMD2ISODDD(ymd) /* 2005-237 */ /* ----------- */ /* Hour-Minute-Second Formats */ say makeHMS(TIMESEP) /* 00:00:00 */ say makeHMS() /* 11:08:04 */ say makeHMS(".", 11, 8, 4) /* 11.08.04 */ say makeHMS(SPACE, 11, 8, 4) /* 11 08 04 */ say makeHMS(NULL, 11, 8, 4) /* 110804 */ /* ----------- */ /* YMDHMS Examples */ /* 2005-08-25 11:08:04 */ ymdhms = EPS2YMDHMS(localtime()) ymdhms = makeYMDHMS(makeYMD(), makeHMS()) /* Standard ISO Format: 2005-08-25T11:08:04 */ iso = YMDHMS2ISO(ymdhms) iso = CHANGESTR(SPACE, ymdhms, ISOSEP) /* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */ unix = YMDHMS2UNIX(ymdhms) unix = LEFT(getDOWName(ymdhms), 3) LEFT(getMonthName(ymdhms), 3), getDay(ymdhms) YMDHMS2HMS(ymdhms) getYear(ymdhms) /* As per Perl example */ say "YMDHMS gives:" getDOWName(ymdhms) YMD2US(YMDHMS2YMD(ymdhms), 'S') /* ----------- */ /* Date-Time-Structure [DTS] Examples */ /* 2005-08-25 11:08:04 +1000 August Thursday 4 237 34 1124932084 */ dts = makeDTS(makeYMD(), makeHMS()) /* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */ unix = LEFT(extractDTS(dts, 9), 3) LEFT(extractDTS(dts, 8), 3), extractDTS(dts, 3) YMDHMS2HMS(DTS2YMDHMS(dts)) extractDTS(dts, 1) unix = LEFT(getDOWName(dts), 3) LEFT(getMonthName(dts), 3), getDay(dts) YMDHMS2HMS(DTS2YMDHMS(dts)) getYear(dts) /* As per Perl example */ say "DTS gives:" extractDTS(dts, 9), YMD2US(YMDHMS2YMD(DTS2YMDHMS(dts)), 'S') /* @@PLEAC@@_3.9 */ /* ------------------------------------------------------------------ */ /* Timing in REXX is usually performed with the 'TIME' BIF, and it may*/ /* take three forms: */ /* */ /* * High resolution [sub-second-based] timing via, TIME('L') */ /* * Low resolution [second-based] timing via, TIME('T') */ /* * Stop watch [second-based] timing via, TIME('R') and TIME('E') */ /* */ /* The precision of high resolution timing is platform-specific, so */ /* caution is needed in interpreting the microsecond-based value */ /* returned from TIME('L') calls. On UNIX / Win32 desktop systems it */ /* is probably safest to assume that values are in the millisecond */ /* range, and no more accurate than about +/- 20 ms. */ /* */ /* Low resolution timing via TIME('T') [i.e. Epoch second] calls is */ /* easily performed, but not all REXX interpreters may offer this */ /* option. */ /* */ /* Stop watch timing is platform-independant, easy to use, hence quite*/ /* widely used; it would qualifiy as a REXX-idiomatic practice */ /* ------------------------------------------------------------------ */ /* High resolution timer [i.e. microsecond (us) granularity] */ /* Start time - time of day ['long' format to us. resolution] */ t1 = TIME('L') /* Perform timed operation(s) here */ /* Stop Time */ t2 = TIME('L') /* Extract us. values, and compute elapsed time in ms.*/ parse var t1 . "." t1us ; parse var t2 . "." t2us elapsed_ms = (t2us - t1us) / 1000 /* For timings likely to exceed 1 second then other time components need to be extracted. The helper function, 'LHMS2S' computes time in fractional seconds [to ms. precision] */ elapsed_s = LHMS2S(t2) - LHMS2S(t1) /* ----------------------------- */ /* Low resolution timer [i.e. second (s) granularity] */ /* Start time - time of day [Epoch seconds] */ t1 = TIME('T') /* Perform timed operation(s) here */ /* Stop Time */ t2 = TIME('T') /* Compute elapsed time in seconds */ elapsed = t2 - t1 /* ----------- */ /* Low resolution 'stopwatch' timer [i.e. second (s) granularity] */ /* Reset timer */ call TIME 'R' /* Perform timed operation(s) here */ /* Seconds since last timer reset */ elapsed = TIME('E') /* ----------------------------- */ /* Load general-purpose functions from external library */ call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs' call sysLoadFuncs /* Extract before and after times for operation */ before = TIME('L') call CHAROUT , "Press any key ..." ; call sysGetKey after = TIME('L') /* Compute elapsed time in fractional seconds [to ms. precision] */ elapsed = LHMS2S(after) - LHMS2S(before) say "You took" elapsed "seconds" /* Unload general-purpose functions */ call sysDropFuncs exit 0 /* ----------------------------- */ /* Load general-purpose functions from external library */ call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs' call sysLoadFuncs stem.0 = 500 ; repetitions = 100 ; total_time = 0 do repetitions /* Load array */ do i = 1 for stem.0 stem.i = RANDOM() end /* Time sort operation */ start = TIME('L') call sysStemSort 'stem.' stop = TIME('L') /* Extract timings and accumulate */ /* Given the sub-second duration of the operation, the following approach could be used: parse var start . "." start ; parse var stop . "." stop elapsed = (stop - start) / 1000000 However, for maximum safety, best use 'LHMS2S' */ elapsed = LHMS2S(stop) - LHMS2S(start) total_time = total_time + elapsed end say "On average, sorting" stem.0 "random numbers takes", total_time / repetitions "seconds" drop stem. /* Unload general-purpose functions */ call sysDropFuncs exit 0 /* @@PLEAC@@_3.10 */ /* ------------------------------------------------------------------ */ /* Given the platform-specific nature of this task, REXX offers no */ /* in-built support for it aside, of course, from allowing a 'busy */ /* wait' loop to be implemented, an approach best avoided if possible.*/ /* */ /* As is typical for such tasks, the needed functionality is obtained */ /* either from a third party library, or by invoking a system command */ /* utility. Examples of each follow. */ /* ------------------------------------------------------------------ */ /* 'busy waiting' using built-in 'TIME' function - *AVOID* */ stoptime = TIME('S') + 3.5 /* 3.5 second pause */ do while TIME('S') < stoptime /* Do nothing, except burn CPU cycles :) ! */ nop end /* ----------------------------- */ /* Invoking 'sysSleep' function: fine granularity, no CPU wastage */ /* Load general-purpose functions from external library */ call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs' call sysLoadFuncs call sysSleep 3.5 /* 3.5 second pause */ call sysSleep 0.35 /* 0.35 second pause */ call sysSleep 0.035 /* 0.035 second pause */ /* Unload general-purpose functions */ call sysDropFuncs exit 0 /* ----------------------------- */ /* Command: UNIX / Win32 'sleep' utility, granularity is seconds */ cmd = "sleep" ; seconds = 3 address SYSTEM cmd seconds with OUTPUT STREAM 'NUL:' ERROR STREAM 'NUL:' /* @@PLEAC@@_4.0 */ /* ------------------------------------------------------------------ */ /* REXX is perhaps an unusual language in that it does not implement */ /* either C-style structures or C-style arrays. Instead, it implements*/ /* what are called 'compound variables' which, under the covers, are a*/ /* form of associative array [or 'hash', to use the Perl treminology].*/ /* Compound variable usage will be further discussed in Chapter 5 in */ /* the context of Perl 'hashes'. */ /* */ /* Compound variable usage aside, array-like functionality may be had */ /* via: */ /* */ /* * Third party libraries ['rxHash' library illustrated here] which */ /* merely involves manipulating array-like objects using relevant */ /* library subroutines. Any mention of 'arrays' in this chapter is */ /* to be understood as referring to entities created using this */ /* library, and it should be appreciated that such code is not truly*/ /* portable, but specific to platforms on which this library is */ /* available [currently UNIX / Linux, Win32, OS/2] */ /* */ /* * Delimited strings; a character (usually a SPACE) delimits a set */ /* of character sequences, each of which may be considered to be a */ /* 'word' or 'element'. BIF's such as WORD, WORDS, and DELWORD allow*/ /* delimited strings to model sets, records, and both single and */ /* multi-dimension arrays. Whilst very useful, they suffer from two */ /* problems: */ /* */ /* - Immutable, so any modification sees a copy made [read: poor */ /* performance when compared to in-place modification] */ /* */ /* - Cannot be [easily] nested, so do not have quite the utility of */ /* true lists like those found in functional languages */ /* */ /* In order to improve the readability of examples, and to avoid the */ /* presence of too much redundant code, a number of custom helper */ /* subroutines / functions will be used. Most of these routines are */ /* functionally similar to Perl or Python counterparts such as 'split'*/ /* and 'join', while others are similar to Scheme routines such as */ /* 'foreach', 'map', and 'reduce'. Code and documentation for these */ /* will be found in the Appendix; listed here for easy reference: */ /* */ /* * Constructors / Finaliser */ /* - array = makeArray(var1, var2, ...) */ /* - array = makeArrayRange(start, end, increment) */ /* - dropArray(array1, array2, ...) */ /* */ /* * Array Manipulation */ /* - array = ajoin(array1, array2, ...) */ /* */ /* * Perl / Python Hybrids */ /* - array = split(string, delimiter) */ /* - array = chop(string, length) */ /* - string = join(array, delimiter) */ /* */ /* * Functional Hybrids */ /* - forupdate(array, procname, procargs, ...) */ /* - foreach(array, procname, procargs, ...) */ /* - reduction = reduce(array, reduction, procname, procargs, ...) */ /* - array = map(array, procname, procargs, ...) */ /* */ /* In addition, the 'rxHash' library will be used to implement other */ /* useful data structure-handling routines, including: */ /* */ /* * ... */ /* */ /* REXX purists will certainly criticise the approach taken as one */ /* that is: */ /* */ /* * Non-portable, particularly to 'large-system' environments */ /* * Inefficient, particularly any use of the INTERPRET instruction */ /* * Non-REXX idiomatic, by trying to mimic Python or Scheme idioms */ /* */ /* However, I simply wish to counter by saying that this approach: */ /* */ /* * Helps REXX examples more closely resemble the Perl-originals */ /* * Non-compound variable 'arrays' are not REXX-idiomatic anyway, so */ /* it shouldn't be a concern [compound variable use will be covered */ /* in the chapter on hashes] */ /* * Showcases the versatility of the REXX language */ /* */ /* Third-party library directions: */ /* */ /* Use of 'rxHash' assumes the following prologue / epilogue: */ /* */ /* call rxFuncAdd 'arrLoadFuncs', 'rxhash', 'arrLoadFuncs' */ /* call arrLoadFuncs */ /* ... */ /* call arrDropFuncs */ /* */ /* whilst use of 'rexxUtil' requires: */ /* */ /* call rxFuncAdd 'sysLoadFuncs', 'rexxutil', 'sysLoadFuncs' */ /* call sysLoadFuncs */ /* ... */ /* call sysDropFuncs */ /* */ /* A final thing worth mentioning is the reason for using 'rxHash' to */ /* implement numerically-indexed arrays [which need to have elements */ /* 'shuffled' when middle element insertions and deletions are made] */ /* rather than other data structures like lists. The reason was so ma-*/ /* ximum utility could be maintained: */ /* */ /* * Only numeric arrays can easily be converted to compound variables*/ /* [and vice versa] by library functions */ /* * Only numeric arrays can easily be sorted, both by a supplied lib-*/ /* rary function [thus providing fast sorting] and in general, w/o */ /* the need for copying elememts */ /* * Only numeric arrays are traversable via DO ... END; otherwise the*/ /* 'arrStemDoOver' has to be used, and it neither iterates in order */ /* nor does it allow the number of elements to be discerned */ /* ------------------------------------------------------------------ */ /* Load general-purpose functions from external library */ call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs' call sysLoadFuncs /* Load array functions from external library */ call rxFuncAdd 'arrLoadFuncs', 'rxHash', 'arrLoadFuncs' call arrLoadFuncs /* ----------------------------- */ nested = makeArray("this", "that", "the", "other") ; call arrDrop nested /* ----------- */ /* NESTED arrays are possible, though somewhat awkward to use because references to any 'contained' arrays must be explicitly created and explicitly destroyed [though they can be inlined if the 'containing' array will be freed using the 'dropArray' routine]. The situation is analogous to managing C pointers [in fact, that *is* what is being done, albeit indirectly :)] */ /* Make inner array, store reference, add it as outer array element */ lvl_1 = makeArray("the", "other") nested = makeArray("this", "that", lvl_1) /* Take care to destroy inner array reference before container itself */ call arrDrop lvl_1 ; call arrDrop nested /* ----------- */ /* Alternative to above, but *must* free with 'dropArray'; preferable to use latter anyway since it accepts multiple arguments except on large arrays, or those containing deeply-nested arrays */ nested = makeArray("this", "that", makeArray("the", "other")) call dropArray nested /* ----------------------------- */ tune = makeArray("The", "Star-spangled", "Banner") ; call dropArray tune /* @@PLEAC@@_4.1 */ /* ------------------------------------------------------------------ */ /* Array management entails: */ /* */ /* * Creating an array, and saving its 'handle' */ /* * Using the handle for subsequent access, and updates */ /* * Explicitly destroying the array via the handle; failure to do */ /* this will see memory leakages occur */ /* */ /* Really no different to managing pointers in a language like C. Of */ /* course since it is a library facility rather than an language elem-*/ /* ent, it is less convenient [i.e. no inlining of array creation cal-*/ /* -ls, no 'array literals' etc] to use. */ /* ------------------------------------------------------------------ */ a = makeArray("quick", "brown", "fox") ; call dropArray a /* ----------------------------- */ a = split("Why are you teasing me?") ; call dropArray a /* ----------------------------- */ lines = makeArray() signal HEREDOC /* The boy stood on the burning deck, It was as hot as glass. */ HEREDOC: do i = SIGL + 1 line = SOURCELINE(i) if line = "*/" then ; leave call asplice lines, -1, "IA", line end call dropArray lines /* ----------------------------- */ bigarray = makeArray() parse value LINEIN("mydatafile.txt") with line do while line <> NULL call asplice bigarry, -1, "IA", line parse value LINEIN("mydatafile.txt") with line end call dropArray bigarray /* ----------------------------- */ banner = "The Mines of Moria" banner = 'The Mines of Moria' /* ----------------------------- */ name = "Gandalf" banner = "Speak," name || ", and enter." /* ----------------------------- */ his_host = "www.perl.com" host_info = nslookup(his_host) /* ----------- */ nslookup : procedure expose (globals) cmd = "nslookup" ARG(1) ; out = NULL address SYSTEM cmd with OUTPUT STEM cmdout. do i = 1 for cmdout.0 ; out = out NEWLINE cmdout.i ; end return STRIP(out) /* ----------------------------- */ banner = makeArray("Costs", "only", "$4.95") ; call dropArray banner banner = split("Costs only $4.95") ; call dropArray banner /* ----------------------------- */ brax = split('"' "'" "( ) < > { } [ ]", SPACE) rings = split("'They're" '"Nenya Narya Vilya"' || "'", SPACE) tags = split("LI TABLE TR TD A IMG H1 P", SPACE) call dropArray brax, rings, tags banner = "The '\' is often used in regular expressions." /* ----------------------------- */ /* For unicode support see 'rexxUtil' library's 'sysToUnicode' and 'sysFromUnicode' functions */ /* @@PLEAC@@_4.2 */ say commify_series(NULL) say commify_series("red") say commify_series("red yellow") say commify_series("red yellow green") mylist = "red yellow green" say "I have" commify_series(mylist) "marbles." exit 0 /* ----------- */ commify_series : procedure expose (globals) if ARG() > 1 then ; return NULL list = ARG(1) ; n = WORDS(list) select when n == 0 then ; return NULL when n == 1 then ; return WORD(list, 1) when n == 2 then ; return WORD(list, 1) "and" WORD(list, 2) otherwise series = WORD(list, 1) do i = 2 to n - 1 ; series = series || "," WORD(list, i) ; end return STRIP(series) || ", and" WORD(list, n) end /* ----------------------------- */ /* Implementation uses nested arrays */ data = makeArray(, makeArray("just one thing"),, split("Mutt Jeff"),, split("Peter Paul Mary"),, makeArray("To our parents", "Mother Theresa", "God"),, makeArray("pastrami", "ham and cheese",, "peanut butter and jelly", "tuna"),, makeArray("recycle tired, old phrases",, "ponder big, happy thoughts"),, makeArray("recycle tired, old phrases",, "ponder big, happy thoughts",, "sleep and dream peacefully")) call foreach data, "print_list" call dropArray data exit 0 /* ----------- */ print_list : procedure expose (globals) say "The list is:" commify_series(ARG(1)) || "." return /* -- */ commify_series : procedure expose (globals) if ARG() > 1 then ; return NULL /* handle array */ if isArray(ARG(1)) then do current = ARG(1) ; n = getArray(current, 0) select when n == 0 then ; return NULL when n == 1 then ; return getArray(current, 1) when n == 2 then ; return getArray(current, 1) "and", getArray(current, 2) otherwise series = getArray(current, 1) do i = 2 to n - 1 current_word = getArray(current, i) if POS(",", current_word) > 0 then sepchar = ";" else sepchar = "," series = series || sepchar current_word end return STRIP(series) || sepchar "and" getArray(current, n) end end ; else do /* handle multi-word string */ list = ARG(1) ; n = WORDS(list) select when n == 0 then ; return NULL when n == 1 then ; return WORD(list, 1) when n == 2 then ; return WORD(list, 1) "and" WORD(list, 2) otherwise series = WORD(list, 1) do i = 2 to n - 1 current_word = WORD(list, i) if POS(",", current_word) > 0 then sepchar = ";" else sepchar = "," series = series || sepchar current_word end return STRIP(series) || sepchar "and" WORD(list, n) end end /* @@PLEAC@@_4.3 */ /* ------------------------------------------------------------------ */ /* Arrays, as implemented in the REXXToolkit functions [see Appendix] */ /* using the 'rexxUtil' library, cannot be grown / shrunk to specified*/ /* sizes as most of the examples in this section require. Their size */ /* does, however, dynamically alter as elements are added / removed */ /* via applications of the 'asplice' function. */ /* ------------------------------------------------------------------ */ people = split("Crosby Stills Nash Young", SPACE) call what_about_that_array people /* Output: The list has 4 elements. The index of the last element is 4. Element #4 is Young. Note: REXX convention is for 1-based numerically-indexed arrays */ /* ----------- */ call asplice people, -1, 'D' 1 call what_about_that_array people /* Output: The list has 3 elements. The index of the last element is 3. Element #4 is . Note: An invalid array element returns the empty-string, "" / NULL */ /* ----------------------------- */ /* Growing / shrinking arrays to specified sizes is inapplicable */ /* ----------------------------- */ call dropArray people exit 0 /* ----------- */ what_about_that_array : procedure expose (globals) arr = ARG(1) say "The list has" arrGet(arr, 0) "elements." say "The index of the last element is" arrGet(arr, 0) || "." say "Element #4 is" arrGet(arr, 4) || "." return /* @@PLEAC@@_4.4 */ /* ------------------------------------------------------------------ */ /* The canonical means of iterating in REXX is via the DO ... END con-*/ /* trol structure. To traverse an array [quickly]: */ /* */ /* do i = 1 for arrGet(oldarr, 0) */ /* call arrSet newarr, i, arrGet(oldarr, i) */ /* end */ /* */ /* or more safely: */ /* */ /* do i = 1 for getArrayLength(oldarr) */ /* call setArray newarr, i, getArray(oldarr, i) */ /* end */ /* */ /* For convenience this functionality is packaged in the REXXToolkit's*/ /* 'foreach' and 'forupdate' functions. The former is modelled after */ /* the 'foreach' routine that is found in many functional and scripti-*/ /* ng languages in which each element of a data structure is visited */ /* and a specified function is invoked. 'forupdate' is a variant that */ /* updates each visited element. */ /* */ /* Of course if maximum performance is required, say, when working on */ /* very large arrays which may be traversed multiple times, an inline */ /* DO ... END structure that uses the array-access primitives like */ /* 'arrGet' and 'arrSet', should be used. */ /* */ /* It is also worth noting that Perl seems to make little distinction */ /* between arrays and lists. In REXX, however, a language that doesn't*/ /* implement a 'list' data structure, it is common to see strings of */ /* space-separated words used as lists, and use made of the PARSE ins-*/ /* truction to 'traverse the list' much as one might use CAR and CDR */ /* in LISP or Scheme to do the same. Example: */ /* */ /* list = "one two three" */ /* do while list <> NULL */ /* parse var list token list */ /* ... do something with 'token' ... */ /* end */ /* ------------------------------------------------------------------ */ mylist = makeArray(1, 2, 3, 4, 5) ; procname = "print" call foreach mylist, procname call dropArray mylist exit 0 /* ----------- */ print : procedure expose (globals) say ARG(1) ; return /* ----------------------------- */ bad_users = makeArray("Tom", "Dick", "Harry") call foreach bad_users, "complain" call dropArray bad_users exit 0 /* ----------- */ complain : procedure expose (globals) say "You are a *** very bad *** user," ARG(1) ; return /* ----------------------------- */ /* Extract environment data into a compound variable, and sort */ address SYSTEM "set" with OUTPUT STEM environ. call sysStemSort 'environ.' /* Array from compound variable; print with 'foreach' and helper */ arr = arrFromStem('environ.') call foreach arr, "showEnvironInfo" call dropArray arr ; drop environ. /* A more idiomatic REXX approach would be to access the compound variable directly, so avoiding array conversion and access overhead: do i = 1 for environ.0 parse value environ.i with key "=" val say key "=" val end */ exit 0 /* ----------- */ showEnvironInfo : procedure expose (globals) parse value ARG(1) with key "=" val say key "=" val ; return /* ----------------------------- */ all_users = split(get_all_users(), SPACE) MAX_QUOTA = get_max_quota() call foreach all_users, "complain_if_overquota", MAX_QUOTA call dropArray all_users exit 0 /* ----------- */ complain_if_overquota : procedure expose (globals) user = ARG(1) ; MAX_QUOTA = ARG(2) if get_usage(user) >