/* author: Rony G. Flatscher, copyright 2008, all rights reserved date: 2007-06-01 - 2007-06-02; 2007-07-30; 2007-08-02, 2007-08-07, 2007-08-15, 2007-10-20, 2007-10-23 2007-12-30 - made NumberComparator more flexible, allows to use intermixed non-numbers, if programmer wishes to do so - MessageComparator: now allows collection of message-names and/or message objects to use for comparisons 2008-01-08 - added "/numeric" hint for message names 2008-02-15 - changed StringComparator to be more flexible with its argument 2008-02-16 - changed StringComparator to be simpler & more flexible, as well as sort2, stableSort2; created samples (f:\test\orx\rgf_util2) 2008-02-17 - changed/improved StringColumnComparator, created samples for it 2008-02-19 - removed usage of built-in comparators in sort2() and stableSort2(), so none of the 3.2.0 specialized Comparators are needed - added "-length" to ABBREV2(), 2008-02-20 - added "-count" to CHANGESTR2() ("change last 'count' needle occurrences) - added negative starting position to lastPos2() - added left2()-BIF, handling with negative start position - added right2()-BIF, handling with negative start position - added/enhanced pos2()-BIF with negative start position 2008-02-21 - added DELSTR2(), LOWER2(), SUBSTR2(), UPPER2() which now all accept negative numbers 2008-02-22 - added OVERLAY2(), which now accepts negative numbers 2008-02-25 - added PARSEWORDS2() 2008-03-13 - changed DUMP2 to cater for the different kind of collections, ones), will not sort OrderedCollections, but honor their order [will show exact array-index values (including multi-dimensional], will sort by index-value otherwise, in the case of "allAt"-collections (e.g. Relation) will give a list of the items associated with the same index 2008-03-14 - changed DUMP2() to display item, if allAt() returns a collection containing only one item; added SUBCHAR2() allowing negative positions as well added negative position to WORDPOS2() added DELWORD2, SUBWORD2(), WORD2(), WORDINDEX2(), WORDLENGTH2() 2008-03-16 - tested and fixed StringOfWords class 2008-03-19 - recoded sort2() and stableSort2() to take advantage of .StringComparator and .StringColumnComparator 2008-03-27 - allow in list of messages array-elements with two entries, where - arr[1]=messageString|messageObject - arr[2]=flagString - added option "M" (message sort) to sort2() and stableSort2() 2008-03-29, - sort2() and stableSort2() now accept as their first argument an object with a "makeArray" method in addition to instances of array - .MessageComparator: if an array-element is given, then index 3 in addition to index 2 are regarded to be flag (parts) 2008-03-16: - dump2 now gracefully deals with non-collection and non-supplier objects: an appropriate hint is given, as well as the type and (string) value of the argument 2009-03-15: - changed default of string-routines to use the "caseless" version 2009-03-20: - changed NumericComparator to use caseless comparison in case relaxed comparisons are carried out - change default sort2() and stableSort2() to use "N", i.e. ascending sort with numeric comparisons, and caseless comparisons - added MakeArray to class StringOfWords purpose: set of 3.2 utilities to ease programming of 3.2.0, e.g. offer sort2()- and stableSort2()-BIFs that handle all kind of standard sorting needs, thereby removing the need for "low level" coding in ooRexx itself TODO: - ? create a DateTime2 class with renaming existing conversion methods to start with "to"; also supply epoch-related conversions (from/to); also allow to define the date when Julian calendar took effect; supply method to determine Easter Sunday (depending on the calendar in use) - create routines "leftWord([-]n)", "rightWord([-]n)" license: LGPL 3.0, (as of: 2008-02-17) version: 1.0.3 */ .local~rgf.non.printable=xrange("00"x,"1F"x)||"FF"x .local~rgf.alpha.low="abcdefghijklmnopqrstuvwxyz" .local~rgf.alpha.upper =.rgf.alpha.low~upper .local~rgf.alpha =.rgf.alpha.low || .rgf.alpha.upper .local~rgf.numbers ="0123456789" .local~rgf.alphanumeric=.rgf.alpha || .rgf.numbers .local~rgf.symbol.chars=".!_?" parse version "_" v "(" if v<4 then -- ooRexx smaller than 4.0.0, then use ".public_routines" do -- make version"2" BIFs globally available do idx over .methods .public_routines~put(.methods[idx], idx) end -- make the classes seen globally via .local directory .local~messageComparator =.messageComparator .local~NumberComparator =.NumberComparator .local~StringComparator =.StringComparator .local~StringColumnComparator=.StringColumnComparator .local~StringOfWords =.StringOfWords end else -- running under ooRexx 4.0.0 or higher do thisPackage=.context~package do idx over .methods routine=.routine~new(idx, .methods[idx]~source) thisPackage~addPublicRoutine(idx, routine) end -- make the classes seen globally via the package's public classes thisPackage~addPublicClass("MessageComparator" , .messageComparator ) thisPackage~addPublicClass("NumberComparator" , .NumberComparator ) thisPackage~addPublicClass("StringComparator" , .StringComparator ) thisPackage~addPublicClass("StringColumnComparator", .StringColumnComparator) thisPackage~addPublicClass("StringOfWords" , .StringOfWords ) end /* ======================================================================= */ /* === methods to be used for new BIFs === */ /* ======================================================================= */ -- 2008-02-19, rgf: abbrev info, string [, n-length] /* if length is negative, then */ /* ======================================================================= */ ::method "abbrev2" use strict arg arg1, arg2, ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=4 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="abbrev" -- base name for the message to send bCaseDependent =.false -- default to caseless version if argNr>=BIFpos, \datatype(arg(argNr),"N") then do letter=arg(argNr)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (argNr, "CI", arg(argNr)) bCaseDependent=(letter="C") argNr-=1 -- decrease one from total number of arguments end newArr=.array~new -- create new array for the arguments newArr[1]=arg2 -- save info if arg(3,"Exists"), datatype(arg(3),"N") then do arg3=arg(3) -- negative? if arg3<0 then -- length, i.e. extract from right do newArr[1]=arg2~right(-arg3) -- get the chars from the right end else do newArr[2]=arg3 end end -- now invoke the operation if bCaseDependent then return .message~new(arg(1), methName, "A", newArr)~send else return .message~new(arg(1), "caseless"methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ /* if count is negative, then the number of changes occur from the right side ("change the last 'count' of 'needle' occurrences in string") */ ::method "changeStr2" -- (needle,haystack,newNeedle[,[-]count][,CI]) use strict arg arg1needle, arg2haystack, arg3newNeedle, ... -- make sure at least three args are supplied parse arg arg1needle, arg2haystack, arg3newNeedle, arg4count argNr=arg() -- get maximum number of arguments BIFpos=3 -- last mandatory BIF argument position maxArgs=5 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="changeStr" -- base name for the message to send bCaseDependent =.false -- default to caseless version newArr=.array~new -- create new array for the arguments newArr[1]=arg1needle newArr[2]=arg3newNeedle signal on syntax if argNr>(BIFpos) then -- either count or "CI" do count=.nil if \datatype(arg(argNr),"W") then -- "C" or "I" do letter=arg(argNr)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (argNr, "CI", arg(argNr)) bCaseDependent=(letter="C") if argNr>4, arg(4,"E") then -- check for "count" argument count=arg4count -- save count-value end else count=arg4count -- save count-value end if datatype(count,"N") then -- count is numeric, check it out do if count<0 then -- change the "count" last occurrences in string! do -- search starting position for changes len=length(arg2haystack) -- remember length of string pos=len -- start out with last position of string -- find starting position do i=1 to -count until pos=0 oldPos=pos if oldPos<=1 then leave -- already at beginning! if bCaseDependent then do pos= lastPos(arg1needle, arg2haystack, oldPos-(1-(len=oldPos))) end else -- ignore case do pos=lastPos2(arg1needle, arg2haystack, oldPos-(1-(len=oldPos)), "I") end end -- carry out the changes if oldPos>1, pos>0 then -- o.k., not all "needle"s to change: split, change and return do -- extract part that does not get changed mb=.MutableBuffer~new~~append( arg2haystack~substr(1,Pos-1) ) -- change needle in remainder, add changed string to MutableBuffer if bCaseDependent then mb~append( .message~new(arg2haystack~substr(Pos), methName, "A", newArr)~send) else mb~append( .message~new(arg2haystack~substr(Pos), "caseless"methName, "A", newArr)~send) return mb~string -- return changed string end end else do newArr[3]=arg4count -- save "count" argument end end -- now invoke the operation if bCaseDependent then return .message~new(arg2haystack, methName, "A", newArr)~send else return .message~new(arg2haystack, "caseless"methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ -- string1, string2[, [padChar] [,{C|I}]] ::method "compare2" use strict arg arg1string1, arg2string2, arg3padChar=" ", ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArg=4 signal on syntax if argNr>maxArg then -- too many arguments ? raise syntax 93.902 array ("at most" maxArg) methName="compare" -- base name for the message to send bCaseDependent =.false -- default to caseless version if argNr>BIFpos then do letter=arg(maxArg)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (argNr, "CI", arg(maxArg)) bCaseDependent=(letter="C") argNr-=1 -- decrease one from total number of arguments end newArr=.array~new -- create new array for the arguments newArr[1]=arg2string2 -- other string newArr[2]=arg3padChar -- pad character -- now invoke the operation if bCaseDependent then return .message~new(arg1string1, methName, "A", newArr)~send else return .message~new(arg1string1, "caseless"methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ -- not a BIF ::method "compareTo2" /* ======================================================================= */ -- needle, haystack[,{C|I}] ::method "countStr2" use strict arg arg1needle, arg2haystack, ... argNr=arg() -- get maximum number of arguments BIFpos=2 -- last classic BIF argument position maxArg=3 signal on syntax if argNr>maxArg then -- too many arguments ? raise syntax 93.902 array ("at most" maxArg) methName="countStr" -- base name for the message to send bCaseDependent =.false -- default to caseless version if argNr>BIFpos then do letter=arg(maxArg)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (maxArg, "CI", arg(maxArg)) bCaseDependent=(letter="C") end -- now invoke the operation if bCaseDependent then return .message~new(arg2haystack, methName, "I", arg1needle )~send else return .message~new(arg2haystack, "caseless"methName, "I", arg1needle )~send syntax: raise propagate -- 2008-02-21, rgf: delStr2(string ,n-start [, n-length]) /* if length is negative, then */ /* ======================================================================= */ ::method "delStr2" use strict arg arg1, ... -- make sure we have at least one arg parse arg ., arg2, arg3 argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=3 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="delStr" -- base name for the message to send len1=length(arg1) -- get length of string newArr=.array~new -- create new array for the arguments if datatype(arg2,"W") then -- start do if arg2<0 then -- negative, start from right do tmp=len1+arg2+1 -- get starting position if tmp<2 then -- start at first char arg2=1 else arg2=tmp end newArr[1]=arg2 -- start position end else do raise syntax 93.905 array('2 ("start position")', arg2) end if arg(3,"Exists") then -- length do if datatype(arg2, "W") then do if arg3<0 then -- we need to move the starting point to the left! do arg2=arg2+arg3+1 -- subtract arg3 if arg2<1 then -- reset start to 1 newArr[1]=1 else -- new start pos newArr[1]=arg2 arg3=-arg3 -- turn it into a positive number end end else do raise syntax 93.905 array('3 ("length")', arg3) end newArr[2]=arg3 -- length end -- now invoke the operation return .message~new(arg(1), methName, "A", newArr)~send syntax: raise propagate -- 2008-03-14, rgf: /* ======================================================================= */ /* delWord2(string, start[, length]) ... if no words, returns received string */ ::method "delWord2" -- allows negative start and length use strict arg string, arg2, ... -- make sure we have at least one arg parse arg string, arg2, arg3 argNr=arg() -- get maximum number of arguments maxArgs=3 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="delWord" -- base name for the message to send newArr=.array~new -- create new array for the arguments nrWords=words(string) -- calc # of words if \datatype(arg2, "W") then raise syntax 93.905 array('2 ("starting word position")', arg3) newArr[1]=arg2 -- save starting pos if arg2<0 then do tmp=nrWords+arg2+1 -- calc starting position from right if tmp<1 then -- if before first word, start at first word tmp=1 newArr[1]=tmp -- save new starting position end if arg(3,"Exists") then -- if given, process length argument do if \datatype(arg3, "W") then raise syntax 93.905 array('3 ("number of words")', arg3) if arg3<0 then -- determine new starting position and number of words to delete do oldStart=newArr[1] -- save old starting position tmp=oldStart+arg3+1 if tmp<1 then -- oops, make sure we start at first word tmp=1 newArr[1]=tmp -- new start position newArr[2]=oldStart-tmp+1 -- length argument (nr of words to delete) end else do newArr[2]=arg3 -- length argument end end if nrWords=0 then -- nothing to do, return empty/spacy string return string -- now invoke the operation return .message~new(string, methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ -- not a BIF ::method "Equals2" /* ======================================================================= */ /* lastPos needle, haystack [,[n-start] [,{C|I}]] */ ::method "lastPos2" use strict arg arg1needle, arg2haystack, ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=4 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) StringPos=1 -- position of string object to work with methName="lastPos" -- base name for the message to send bCaseDependent =.false -- default to caseless version if argNr>=BIFpos, \datatype(arg(argNr),"N") then do letter=arg(argNr)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (argNr, "CI", arg(argNr)) bCaseDependent=(letter="C") argNr-=1 -- decrease one from total number of arguments end newArr=.array~new -- create new array for the arguments newArr[1]=arg1needle -- needle arg3=arg(3) if arg(3,"Exists"), datatype(arg3,"N") then do if arg3<0 then -- negative start column: count from right do len2=length(arg2haystack) -- get length of string to scan if -arg3 >= len2 then -- beyond starting position, scan string normally return 0 -- beyond start, needle cannot be found! else newArr[2]=len2+arg3+1 -- determine starting position end else -- positive start column do newArr[2]=arg3 -- save starting position end end -- now invoke the operation if bCaseDependent then return .message~new(arg2haystack, methName, "A", newArr)~send else return .message~new(arg2haystack, "caseless"methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ -- not a BIF ::method "match2" /* ======================================================================= */ /* left2 string, length [,pad] */ ::method "left2" use strict arg arg1string, arg2length, ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=3 --signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) if \datatype(arg2length,"W") then do raise syntax 93.905 array('"length"', arg2) end bLeftBIF=(arg2length>0) -- use left() or right() BIF ? newArr=.array~new -- create new array for the arguments if bLeftBIF then newArr[1]=arg2length else newArr[1]=-arg2length if arg(3,"Exists") then -- padChar supplied ? newArr[2]=arg(3) -- now invoke the operation if bLeftBIF then return .message~new(arg1string, "left", "A", newArr)~send else return .message~new(arg1string, "right", "A", newArr)~send syntax: raise propagate -- 2008-02-21, rgf: lower2(string [,[n-start] [, n-length]]) /* if length is negative, then */ /* ======================================================================= */ ::method "lower2" use strict arg arg1, ... -- make sure we have at least one arg parse arg ., arg2, arg3 argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=3 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="lower" -- base name for the message to send len1=length(arg1) -- get length of string newArr=.array~new -- create new array for the arguments if arg(2,"Exists") then -- start do if datatype(arg2, "W") then do if arg2<0 then -- negative, start from right do tmp=len1+arg2+1 -- get starting position if tmp<2 then -- start at first char arg2=1 else arg2=tmp end end else do raise syntax 93.905 array('2 ("start position")', arg2) end newArr[1]=arg2 -- start position end if arg(3,"Exists") then -- length do if datatype(arg3,"W") then do if arg3<0 then -- we need to move the starting point to the left! do arg2=arg2+arg3+1 -- subtract arg3 if arg2<1 then -- reset start to 1 newArr[1]=1 else -- new start pos newArr[1]=arg2 arg3=-arg3 -- turn it into a positive number end end else do raise syntax 93.905 array('3 ("length")', arg3) end newArr[2]=arg3 -- length end -- now invoke the operation return .message~new(arg(1), methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ -- not a BIF ::method "match2" /* ======================================================================= */ -- not a BIF ::method "matchChar2" -- 2008-02-22, rgf: overlay2(new, target [,[n-target-start] [, n-new-length]] [,pad]) --> ATTENTION: if beyond start, prepend appropriate length pad-filled ! /* ======================================================================= */ ::method "overlay2" use strict arg new1string, arg1string, ... -- make sure we have at least two arg parse arg ., ., arg2start, arg3NewLength, arg4pad argNr=arg() -- get maximum number of arguments BIFpos=5 -- last classic BIF argument position maxArgs=5 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="overlay" -- base name for the message to send len1=length(arg1string) -- get length of string newArr=.array~new -- create new array for the arguments newArr[1]=new1string -- "new"-string prepend="" -- optional prepend string (if positioning before start!) arg2startori=arg2start -- save passed-in value, if any if arg4pad=="" then arg4pad=" "-- define blank as the default pad char if arg(3,"Exists") then -- start in "target"-string do if datatype(arg2start,"W") then do if arg2start<0 then -- negative, start from right do tmp=len1+arg2start+1 -- get starting position if tmp<2 then -- start at first char do if tmp<0 then prepend=copies(arg4pad, -tmp+1) -- create prepend-string else if tmp=0 then -- fencepost prepend=arg4pad arg2start=1 end else arg2start=tmp end end else do raise syntax 93.905 array('3 ("start position in ''target'' string")', arg2start) end newArr[2]=arg2start -- start position end if arg(4,"Exists") then -- "new"-length do if datatype(arg3NewLength,"W") then do if arg3NewLength<0 then -- we need to move the starting point to the left! do arg3NewLength=-arg3NewLength -- turn into a positive number newArr[1]=right(new1string, arg3NewLength, arg4pad) -- "new"-string end else newArr[1]=left(new1string, arg3NewLength, arg4pad) -- "new"-string end else do raise syntax 93.905 array('3 ("length of ''new''-string")', arg3NewLength) end newArr[3]=arg3NewLength -- length end if arg4pad<>"" then -- pad-char newArr[4]=arg4pad -- now invoke the operation return .message~new(prepend||arg1string, methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ /* Pos needle, haystack [,[n-start] [,{C|I}]] */ ::method "Pos2" use strict arg arg1needle, arg2haystack, ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=4 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="Pos" -- base name for the message to send bCaseDependent =.false -- default to caseless version if argNr>=BIFpos, \datatype(arg(argNr),"W") then do letter=arg(argNr)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (argNr, "CI", arg(argNr)) bCaseDependent=(letter="C") argNr-=1 -- decrease one from total number of arguments end newArr=.array~new -- create new array for the arguments newArr[1]=arg1needle -- needle arg3=arg(3) if arg(3,"Exists"), datatype(arg3,"N") then do if arg3<0 then -- negative start column: count from right do len2=length(arg2haystack) -- get length of string to scan if -arg3 >= len2 then -- beyond starting position, scan string normally return 0 -- beyond start, needle cannot be found! else newArr[2]=len2+arg3+1 -- determine starting position end else -- positive start column do newArr[2]=arg3 -- save starting position end end -- now invoke the operation if bCaseDependent then return .message~new(arg2haystack, methName, "A", newArr)~send else return .message~new(arg2haystack, "caseless"methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ /* right2 string, length [,pad] */ ::method "right2" use strict arg arg1string, arg2length, ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=3 --signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) if \datatype(arg2length,"W") then do raise syntax 93.905 array('"length"', arg2) end bLeftBIF=(arg2length>0) -- use left() or right() BIF ? newArr=.array~new -- create new array for the arguments if bLeftBIF then newArr[1]=arg2length else newArr[1]=-arg2length if arg(3,"Exists") then -- padChar supplied ? newArr[2]=arg(3) -- now invoke the operation if bLeftBIF then return .message~new(arg1string, "right", "A", newArr)~send else return .message~new(arg1string, "left", "A", newArr)~send syntax: raise propagate /* ======================================================================= */ /* "Front end" to .Arrays two sort methods "sort" and "sortWith" to simplify usage. Sorts array in place, but also returns it. */ /* usage: sort2(array [,A|D][,][C|I|N]) sort2(array, comparator [,A|D]) A|D ... Ascending (default) | Descending C|I|N ... respect Case (default) | Ignore case | Numeric (Rexx-style numbers) ------------ sort2(array) ... sort() sort2(array, comparator[,"A|D"]) ... sortWith(comparator) sort2(array, collection) ... sortWith(.StringColumnComparator(...)) sort2(array, n, ...) sort2(array, ["A|D"][,"C|I|N"]) ... sortWith(.StringComparator) sort2(array, "[A[scending]|D[escending]][",C[aseDependent]|I[gnoreCase]|N[umeric]"]) sort2(array, "A[C|I|N] | D[C|I|N]"...) Sort2(array, "M[essages]", message...) ... sortWith(.MessageComparator(...)) Sort2(array, "M[essages]", arrayOfMessages...) */ ::method sort2 use strict arg arg1, arg2="A", arg3="C", ... signal on syntax if \arg1~isA(.array) then do if \arg1~hasMethod("makeArray") then raise syntax 93.948 array (1, "Array (or a class with a method 'MAKEARRAY')") arg1=arg1~makeArray -- get the array that represents the collection end argNr=arg() -- get number of args if argNr=1 then -- default sort as only array collection is given do return sort2(arg1, "N") -- sort decimal numerically and caselessly -- return arg1~sort end if arg2~isA(.Comparator) then -- o.k. a comparator given, use it do if argNr>3 then -- in this case a maximum of three args allowed raise syntax 93.902 array (3) kind="A" -- default to ascending sort if argNr=3 then -- a third argument given do kind=arg3~strip~left(1)~upper -- get first char in uppercase if pos(kind, "AD")=0 then -- not a valid argument given! raise syntax 93.914 array (3, "AD", arg3) end if kind="A" then -- sort ascendingly return arg1~sortWith(arg2) else return arg1~sortWith(.InvertingComparator~new(arg2)) end if datatype(arg2,"W") | arg2~isA(.Collection) then do if arg2~isA(.Collection) then -- a collection indicating positions, lengths, type of sort do if argNr>2 then -- in this case only two arguments allowed! raise syntax 93.902 array (2) end else -- argument is a number, hence interpreted as a starting column do arg2=arg(2,"Array") -- turn all args into an array collection end -- use a StringColumnComparator for sorting return arg1~sortWith(.StringColumnComparator~new(arg2)) end -- ---rgf, 2008-03-27: allow message(s) as arguments if arg2~isA(.string) then -- check whether "M"essage argument given do if arg2~strip~left(1)~upper="M" then do if argNr=3 then -- single argument follows comparator=.MessageComparator~new(arg3) else -- turn remaining args into an array object comparator=.MessageComparator~new(arg(3,"Array")) return arg1~sortWith(comparator) end end -- o.k. now use ".StringComparator" for sorting ("CIN") if argNr>3 then -- in this case only three args allowed at most raise syntax 93.902 array (3) if argNr=2 then -- let .StringComparator deal with the args return arg1~sortWith(.StringComparator~new(arg2)) else return arg1~sortWith(.StringComparator~new(arg2, arg3)) syntax: raise propagate /* usage: stableSort2(array [,A|D][,][C|I|N]) stableSort2(array, comparator [,A|D]) A|D ... Ascending (default) | Descending C|I|N ... respect Case (default) | Ignore case | Numeric (Rexx-style numbers) ------------ stableSort2(array) ... sort() stableSort2(array, comparator[,"A|D"]) ... sortWith(comparator) stableSort2(array, collection) ... sortWith(.StringColumnComparator(...)) stableSort2(array, n, ...) stableSort2(array, ["A|D"][,"C|I|N"]) ... sortWith(.StringComparator) stableSort2(array, "[A[scending]|D[escending]][",C[aseDependent]|I[gnoreCase]|N[umeric]"]) stableSort2(array, "A[C|I|N] | D[C|I|N]"...) stableSort2(array, "M[essages]", message...) ... sortWith(.MessageComparator(...)) stableSort2(array, "M[essages]", arrayOfMessages...) */ ::method stableSort2 use strict arg arg1, arg2="A", arg3="C", ... signal on syntax if \arg1~isA(.array) then do if \arg1~hasMethod("makeArray") then raise syntax 93.948 array (1, "Array (or a class with a method 'MAKEARRAY')") arg1=arg1~makeArray -- get the array that represents the collection end argNr=arg() -- get number of args if argNr=1 then -- default sort as only array collection is given do return stableSort2(arg1, "N") -- sort decimal numerically and caselessly -- return arg1~stableSort end if arg2~isA(.Comparator) then -- o.k. a comparator given, use it do if argNr>3 then -- in this case a maximum of three args allowed raise syntax 93.902 array (3) kind="A" -- default to ascending sort if argNr=3 then -- a third argument given do kind=arg3~strip~left(1)~upper -- get first char in uppercase if pos(kind, "AD")=0 then -- not a valid argument given! raise syntax 93.914 array (3, "AD", arg3) end if kind="A" then -- sort ascendingly return arg1~stableSortWith(arg2) else return arg1~stableSortWith(.InvertingComparator~new(arg2)) end if datatype(arg2,"W") | arg2~isA(.Collection) then do if arg2~isA(.Collection) then -- a collection indicating positions, lengths, type of sort do if argNr>2 then -- in this case only two arguments allowed! raise syntax 93.902 array (2) end else -- argument is a number, hence interpreted as a starting column do arg2=arg(2,"Array") -- turn all args into an array collection end -- use a StringColumnComparator for sorting return arg1~stableSortWith(.StringColumnComparator~new(arg2)) end -- ---rgf, 2008-03-27: allow message(s) as arguments if arg2~isA(.string) then -- check whether "M"essage argument given do if arg2~strip~left(1)~upper="M" then do if argNr=3 then -- single argument follows comparator=.MessageComparator~new(arg3) else -- turn remaining args into an array object comparator=.MessageComparator~new(arg(3,"Array")) return arg1~stableSortWith(comparator) end end -- o.k. now use ".StringComparator" for sorting ("CIN") if argNr>3 then -- in this case only three args allowed at most raise syntax 93.902 array (3) if argNr=2 then -- let .StringComparator deal with the args return arg1~stableSortWith(.StringComparator~new(arg2)) else return arg1~stableSortWith(.StringComparator~new(arg2, arg3)) syntax: raise propagate /* ======================================================================= */ /* "Front end" to .Arrays two sort methods "sort" and "sortWith" to simplify usage. Sorts array in place and returns it. usage: sort2(array [,A|D][,][C|I|N]) sort2(array, comparator [,A|D]) A|D ... Ascending (default) | Descending C|I|N ... respect Case (default) | Ignore case | Numeric (Rexx-style numbers) */ ::method sort2_bkp use strict arg arg1, arg2="A", arg3="C" if \arg1~isA(.array) then raise syntax 93.948 array (1, "Array") if arg()>3 then raise syntax 93.902 array ("up to 3") argNr=arg() -- get number of supplied arguments arg3=arg3~strip~left(1)~upper -- get first char in uppercase -- Comparator supplied, use it for sorting if arg2~isA(.Comparator) then -- a comparator object do if argNr<3 | arg3="A" then -- normal (default) sort return arg1~sortWith(arg2) ascendingNr=pos(arg3, "AD") if ascendingNr=0 then -- not a valid option given raise syntax 93.914 array (3, "AD", arg(3)) comp=arg2 -- assign comparator to variable if ascendingNr=2 then -- sort descendingly (inverted order) ? comp=.InvertingComparator~new(comp) return arg1~sortWith(comp) end args=(arg2||arg3)~space(0)~translate -- concatenate, remove spaces if args="" then args="AC" -- default to: ascending, case dependent pos=verify(args, "ADCIN") -- check whether only valid chars if pos>0 then -- point to wrong value raise syntax 93.915 array ("ADCIN", substr(args,pos,1)) orderNr=(pos("D", args)>0)+1 -- "A": default=1, "D"=2 caseNr =(pos("I", args)>0)+1 -- "C": default=1, "I"=2, "N"=3 if caseNr=1, pos("N", args)>0 then -- numeric (Rexx-style numbers) ? caseNr=3 if orderNr=1 then do if caseNr=1 then -- Ascending, Case-dependent do return arg1~sort -- default sort end else if caseNr=2 then -- Ascending, case-Independent do -- return arg1~sortWith(.CaselessComparator~new) return arg1~sortWith(.StringComparator~new("I")) -- ignore case, ascend end else -- numeric (Rexx-style-numbers do return arg1~sortWith(.NumberComparator~new) end end else do if caseNr=1 then -- Descending, Case-dependent do -- return arg1~sortWith(.DescendingComparator~new) return arg1~sortWith(.StringComparator~new("D")) -- descend end else if caseNr=2 then -- Descending, case-Independent do -- return arg1~sortWith(.CaselessDescendingComparator~new) return arg1~sortWith(.StringComparator~new("DI")) -- descend, ignore case end else -- numeric (Rexx-style-numbers) do -- return arg1~sortWith(.InvertingComparator~new(.NumberComparator~new)) return arg1~sortWith(.StringComparator~new("DN")) -- descend, numeric sort end end /* ======================================================================= */ /* "Front end" to .Arrays two stableSort methods "stableSort" and "stableSortWith" to simplify usage. Sorts array in place and returns it. usage: stableSort2(array [,A|D][,][C|I|N]) stableSort2(array, comparator [,A|D]) A|D ... Ascending (default) | Descending C|I|N ... respect Case (default) | Ignore case | Numeric (Rexx-style numbers) */ ::method stableSort2_bkp use strict arg arg1, arg2="A", arg3="C" if \arg1~isA(.array) then raise syntax 93.948 array (1, "Array") if arg()>3 then raise syntax 93.902 array ("up to 3") argNr=arg() -- get number of supplied arguments arg3=arg3~strip~left(1)~upper -- get first char in uppercase -- Comparator supplied, use it for sorting if arg2~isA(.Comparator) then -- a comparator object do if argNr<3 | arg3="A" then -- normal (default) sort return arg1~stableSortWith(arg2) ascendingNr=pos(arg3, "AD") if ascendingNr=0 then -- not a valid option given raise syntax 93.914 array (3, "AD", arg(3)) comp=arg2 -- assign comparator to variable if ascendingNr=2 then -- sort descendingly (inverted order) ? comp=.InvertingComparator~new(comp) return arg1~stableSortWith(comp) end args=(arg2||arg3)~space(0)~translate -- concatenate, remove spaces if args="" then args="AC" -- default to: ascending, case dependent pos=verify(args, "ADCIN") -- check whether only valid chars if pos>0 then -- point to wrong value raise syntax 93.915 array ("ADCIN", substr(args,pos,1)) orderNr=(pos("D", args)>0)+1 -- "A": default=1, "D"=2 caseNr =(pos("I", args)>0)+1 -- "C": default=1, "I"=2, "N"=3 if caseNr=1, pos("N", args)>0 then -- numeric (Rexx-style numbers) ? caseNr=3 if orderNr=1 then do if caseNr=1 then -- Ascending, Case-dependent do return arg1~stableSort -- default sort end else if caseNr=2 then -- Ascending, case-Independent do return arg1~stableSortWith(.StringComparator~new("I")) -- ignore case, ascend end else -- numeric (Rexx-style-numbers do return arg1~stableSortWith(.NumberComparator~new) end end else do if caseNr=1 then -- Descending, Case-dependent do return arg1~stableSortWith(.StringComparator~new("D")) -- descend end else if caseNr=2 then -- Descending, case-Independent do return arg1~stableSortWith(.StringComparator~new("DI")) -- descend, ignore case end else -- numeric (Rexx-style-numbers do return arg1~stableSortWith(.StringComparator~new("DN")) -- descend, numeric sort end end -- 2008-03-14, rgf: subChar2(string,n-pos) /* if length is negative, then position from right (end of string) */ --> ATTENTION: if beyond start, prepend appropriate length pad-filled ! /* ======================================================================= */ ::method "subchar2" use strict arg arg1, arg2 -- make sure we have at least one arg parse arg arg1, arg2 argNr=arg() -- get maximum number of arguments maxArgs=2 signal on syntax if argNr<>maxArgs then -- not correct amount of arguments ? do if argNrlen1 then-- beyond string, return empty string (i.e. no char) return "" end else do raise syntax 93.905 array('2 ("start position")', arg2) end -- now invoke the operation return arg1~substr(arg2,1) -- return extracted char syntax: raise propagate -- 2008-02-21, rgf: substr2(string [,[n-start] [, n-length]] [,pad]) /* if length is negative, then */ --> ATTENTION: if beyond start, prepend appropriate length pad-filled ! /* ======================================================================= */ ::method "substr2" use strict arg arg1, ... -- make sure we have at least one arg parse arg ., arg2, arg3, arg4 argNr=arg() -- get maximum number of arguments BIFpos=4 -- last classic BIF argument position maxArgs=4 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="substr" -- base name for the message to send len1=length(arg1) -- get length of string newArr=.array~new -- create new array for the arguments prepend="" -- optional prepend string (if positioning before start!) arg2ori=arg2 -- save passed-in value, if any if arg4=="" then arg4=" "-- define blank as the default pad char if arg(2,"Exists") then -- start do if datatype(arg2,"W") then do if arg2<0 then -- negative, start from right do tmp=len1+arg2+1 -- get starting position if tmp<2 then -- start at first char do if tmp<0 then prepend=copies(arg4, -tmp+1) -- create prepend-string else if tmp=0 then -- fencepost prepend=arg4 arg2=1 end else arg2=tmp end end else do raise syntax 93.905 array('2 ("start position")', arg2) end newArr[1]=arg2 -- start position end if arg(3,"Exists") then -- length do if datatype(arg3,"W") then do if arg3<0 then -- we need to move the starting point to the left! do tmp =arg2+arg3 -- subtract arg3 if tmp <1 then -- reset start to 1 do newArr[1]=1 -- substring from new pos "1" if tmp <0 then -- create (new?) prepend string prepend=prepend||copies(arg4, -tmp) -- create prepend-string end else -- new start pos newArr[1]=tmp+1 arg3=-arg3 -- turn it into a positive number end end else do raise syntax 93.905 array('3 ("length")', arg3) end newArr[2]=arg3 -- length end if arg4<>"" then -- pad-char newArr[3]=arg4 -- now invoke the operation return .message~new(prepend||arg1, methName, "A", newArr)~send syntax: raise propagate pp: if arg(1)=.nil then return "" else return "," arg(1) -- 2008-03-14, rgf: /* ======================================================================= */ /* subWord2(string, start[, length]) ... if no words, returns received string */ ::method "subWord2" -- allows negative start and length use strict arg string, arg2, ... -- make sure we have at least two args parse arg string, arg2, arg3 argNr=arg() -- get maximum number of arguments maxArgs=3 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="subWord" -- base name for the message to send newArr=.array~new -- create new array for the arguments nrWords=words(string) -- calc # of words if \datatype(arg2, "W") then raise syntax 93.905 array('2 ("starting word position")', arg3) newArr[1]=arg2 -- save starting pos if arg2<0 then do tmp=nrWords+arg2+1 -- calc starting position from right if tmp<1 then -- if before first word, start at first word tmp=1 newArr[1]=tmp -- save new starting position end if arg(3,"Exists") then -- if given, process length argument do if \datatype(arg3, "W") then raise syntax 93.905 array('3 ("number of words")', arg3) if arg3<0 then -- determine new starting position and number of words to delete do oldStart=newArr[1] -- save old starting position tmp=oldStart+arg3+1 if tmp<1 then -- oops, make sure we start at first word tmp=1 newArr[1]=tmp -- new start position newArr[2]=oldStart-tmp+1 -- length argument (nr of words to delete) end else do newArr[2]=arg3 -- length argument end end if nrWords=0 then -- nothing to do, return empty/spacy string return string -- now invoke the operation return .message~new(string, methName, "A", newArr)~send syntax: raise propagate -- 2008-02-21, rgf: upper2(string [,[n-start] [, n-length]]) /* if length is negative, then */ /* ======================================================================= */ ::method "upper2" use strict arg arg1, ... -- make sure we have at least one arg parse arg ., arg2, arg3 argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=3 signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="upper" -- base name for the message to send len1=length(arg1) -- get length of string newArr=.array~new -- create new array for the arguments if arg(2,"Exists") then -- start do if datatype(arg2,"W") then do if arg2<0 then -- negative, start from right do tmp=len1+arg2+1 -- get starting position if tmp<2 then -- start at first char arg2=1 else arg2=tmp end end else do raise syntax 93.905 array('2 ("start position")', arg2) end newArr[1]=arg2 -- start position end if arg(3,"Exists") then -- length do if datatype(arg3,"W") then do if arg3<0 then -- we need to move the starting point to the left! do arg2=arg2+arg3+1 -- subtract arg3 if arg2<1 then -- reset start to 1 newArr[1]=1 else -- new start pos newArr[1]=arg2 arg3=-arg3 -- turn it into a positive number end end else do raise syntax 93.905 array('3 ("length")', arg3) end newArr[2]=arg3 -- length end -- now invoke the operation return .message~new(arg(1), methName, "A", newArr)~send syntax: raise propagate -- 2008-03-14, rgf: /* ======================================================================= */ /* WORD2(string, pos) ... if beyond string, then return empty string */ ::method "word2" -- extract and return word use strict arg string, arg2 -- make sure we have at least one arg parse arg string, arg2 argNr=arg() -- get maximum number of arguments maxArgs=2 methName="word" -- base name for the message to send newArr=.array~new -- create new array for the arguments signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) if \datatype(arg2, "W") then raise syntax 93.905 array("2 (position)", arg2) -- must be a number nrWords=words(string) -- get total number of words newArr[1]=arg2 -- save position if arg2<0 then -- negative, position from right do tmp=nrWords+arg2+1 -- calc new position if tmp<1 then -- beyond string, return empty string return "" newArr[1]=tmp -- save new position end -- now invoke the operation return .message~new(string, methName, "A", newArr)~send syntax: raise propagate -- 2008-03-14, rgf: /* ======================================================================= */ /* WORDINDEX2(string, pos) ... if beyond string, then return 0 */ ::method "wordIndex2" use strict arg string, arg2 -- make sure we have at least one arg parse arg string, arg2 argNr=arg() -- get maximum number of arguments maxArgs=2 methName="wordIndex" -- base name for the message to send newArr=.array~new -- create new array for the arguments signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) if \datatype(arg2, "W") then raise syntax 93.905 array("2 (position)", arg2) -- must be a number nrWords=words(string) -- get total number of words newArr[1]=arg2 -- save position if arg2<0 then -- negative, position from right do tmp=nrWords+arg2+1 -- calc new position if tmp<1 then -- beyond string, return empty string return 0 newArr[1]=tmp -- save new position end -- now invoke the operation return .message~new(string, methName, "A", newArr)~send syntax: raise propagate -- 2008-03-14, rgf: /* ======================================================================= */ /* WORDLENGTH2(string, position) ... if beyond string, then return 0 */ ::method "wordLength2" use strict arg string, arg2 -- make sure we have at least one arg parse arg string, arg2 argNr=arg() -- get maximum number of arguments maxArgs=2 methName="wordLength" -- base name for the message to send newArr=.array~new -- create new array for the arguments signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) if \datatype(arg2, "W") then raise syntax 93.905 array("2 (position)", arg2) -- must be a number nrWords=words(string) -- get total number of words newArr[1]=arg2 -- save position if arg2<0 then -- negative, position from right do tmp=nrWords+arg2+1 -- calc new position if tmp<1 then -- beyond string, return empty string return 0 newArr[1]=tmp -- save new position end -- now invoke the operation return .message~new(string, methName, "A", newArr)~send syntax: raise propagate /* ======================================================================= */ /* WORDPOS2(phrase,string[,start][,{C|I}]) */ ::method "wordPos2" use strict arg arg1, arg2, arg3=1, ... argNr=arg() -- get maximum number of arguments BIFpos=3 -- last classic BIF argument position maxArgs=4 newArr=.array~new -- create new array for the arguments newArr[1]=arg1 -- save phrase (single or multiple word/s) to search signal on syntax if argNr>maxArgs then -- too many arguments ? raise syntax 93.902 array ("at most" maxArgs) methName="wordPos" -- base name for the message to send bCaseDependent =.false -- default to caseless version if argNr>=BIFpos, \datatype(arg(argNr),"W") then do letter=arg(argNr)~strip~left(1)~upper if pos(letter,"CI")=0 then -- illegal argument! raise syntax 93.914 array (argNr, "CI", arg(argNr)) bCaseDependent=(letter="C") argNr-=1 -- decrease one from total number of arguments end if arg(3,"Exists"), datatype(arg3,"W") then do if arg3<0 then do tmp=words(arg2)+arg3+1 -- calc starting position from the right if tmp<1 then -- beyond string, then start with first word! tmp=1 newArr[2]=tmp end else do newArr[2]=arg3 end end -- now invoke the operation if bCaseDependent then return .message~new(arg2, methName, "A", newArr)~send else return .message~new(arg2, "caseless"methName, "A", newArr)~send syntax: raise propagate /* ---rgf, 2008-02-26 parseWords2(string[, reference=char-string[, kind="D"|"W"]] [, returnType="W"ords|"P"os) ... returns a one-dimensional array of words parsed from "string" or a two-dimensional array of starting position and length of word string ... string from which words should be parsed reference ... string of characters that delimit words or constitute words; default value: " " ||2"09"x "d"elimiterChars|"W"ordChars ... "char-string" consists of all those characters that either "D"elimit (default) or constitute "W"ords "W"ords|"P"os "W"ords (default) returns a single dimensional array of the parsed words; "P"os returns a two-dimensional array of positions of start-position (index "1"), length of parsed word (index "2") and end-position (index "3", one char beyond end of word) */ ::method parseWords2 use strict arg string, reference=(" "||"09"x), kind="D", returnType="W" signal on syntax .ArgUtil~validateClass("string", string, .string) -- check for correct type .ArgUtil~validateClass("reference", reference, .string) -- check for correct type .ArgUtil~validateClass("kind", kind , .string) -- check for correct type if kind<>"D" then -- not a default value do tmp=kind~strip~left(1)~upper if pos(tmp, "DW")=0 then raise syntax 93.914 array("'kind'", "D[elimiter] | W[ord-characters]", kind) kind=tmp end .ArgUtil~validateClass("returnType", reference, .string) -- check for correct type if returnType<>"W" then -- not a default value do tmp=returnType~strip~left(1)~upper if pos(tmp, "WP")=0 then raise syntax 93.914 array("'returnType'", "W[ords] | P[ositions]", returnType) returnType=tmp end if returnType="W" then -- single-dimensioned array of words res=.array~new else -- two-dimensional array of position and length res=.array~new(0,0) maxLen=length(string) pos=1 endPos=0 do i=1 while endpos pos="pp(pos) "endPos="pp(endPos) "endPos-pos="pp(endPos-pos) "maxLen="pp(maxLen) "length(ref)="pp(length(reference)) if returnType="W" then do res[i]=string~substr(pos,endPos-pos) -- extract and save word end else do res[i,1]=pos -- save starting position res[i,2]=endPos-pos -- save length of word end end return res -- return result array syntax: -- propagate condition raise propagate /* ======================================================================= */ /* Dump collection or supplier. */ /* dumpArray2(--coll--[,-title-]-) coll ... collection or supplier object to dump in sorted order title ... optional, title to be displayed */ ::routine dump2 public use arg coll, title=("type: The" coll~class~id "class"), comparator=.nil if .nil=comparator, title~isA(.comparator) then do comparator=title title=("type: The" coll~class~id "class") end if coll~isA(.supplier) then s=coll else if \coll~isA(.Collection) then -- make sure we have a Collection else do if arg(2,"E") then -- title omitted ! say title say "DUMP2(): ---> argument to dump is *NOT* a *COLLECTION/SUPPLIER* ! <--- " say " type:" pp(coll~class) say " default string value:" pp(coll) -- .ArgUtil~validateClass("collection", coll, .Collection) -- must be of type Collection return end say title": ("coll~items "items)" say count=0 len=length(coll~items) if coll~isA(.Collection) then do s=makeSortedSupplier(coll, comparator) end -- determine maximum length of "pretty printed" index-value maxWidth=0 s2=s~copy do while s2~available maxWidth=max(maxWidth,length(ppIndex(s2~index))) s2~next end count=0 do while s~available count=count+1 say " " "#" right(count,len)":" "index="ppIndex(s~index)~left(maxWidth) "-> item="pp(s~item) s~next end say "-"~copies(50) return /* Sort a collection considering its type and return a sorted supplier object. */ makeSortedSupplier: procedure use arg coll, comparator=.nil if coll~isA(.OrderedCollection) then -- don't sort, just return the supplier return coll~supplier if coll~isA(.SetCollection) then -- use items part, sort it and return it as a supplier do arr=coll~allItems -- get array representation call sortArray arr, comparator -- sort elements return .supplier~new(arr, arr) -- return supplier with sorted elements end if coll~hasMethod('allAt') then -- handle collections with idx -> coll do arr=.set~new~union(coll~allIndexes)~makeArray -- remove duplicate indexes, if any call sortArray arr, comparator -- sort elements arr2=.array~new do i=1 to arr~items -- iterate over all indexes tmp=coll~allAt(arr[i]) -- get all items associated with index if tmp~items=1 then arr2[i]=tmp~at(1) -- save single item to show else arr2[i]=coll~allAt(arr[i]) -- save collection of associated items end return .supplier~new(arr2, arr) end -- o.k. only MapCollection/Collection left, assuming 1:1 mapping between index and item arr=coll~allIndexes -- remove duplicate indexes, if any call sortArray arr, comparator -- sort elements arr2=.array~new do i=1 to arr~items -- iterate over all indexes arr2[i]=coll[arr[i]] -- retrieve item part end return .supplier~new(arr2, arr) -- just sort the passed in array, depending on whether a comparator is needed or not sortArray: procedure use arg arr, comparator=.nil if comparator=.nil, \arr[1]~hasMethod('compareTo') then -- no comparator available, use string renderings comparator=.MessageComparator~new("string", .true) if comparator<>.nil then arr~stableSortWith(comparator) else arr~stableSort return /* ======================================================================= */ /* This comparator expects a message name or a message object to send to both objects. If a message name is given, the appropriate message object will get created and used. The result of sending the message will then be used to carry out the actual comparison. The second argument is optional (default value: .false), and if supplied must be a logical value. If .true, then the result values from sending the message will be cached in a table. .MessageComparator~new(-message-[,-bCache-]) message ... message name or message object; this will get sent to each object and its result will be used for comparison bCache ... optional (default: .false), if .true, then the result of each message will be stored in a table; if an object is contained more than once in the collection, then sending a message to it will return the cached result of the previous execution; this should help performance in situations where each execution of the message is very time consuming TODO: 20071020 - idea: allow array of message-arrays (each entry is an array with a msgName/msgObject, and optionally "I|A" and arguments for that particular msg) 20071230 - better idea: ordered collection of message names or message objects; if one message only, create own "compare"- methods for it 20080103 - added in multiple message mode the option to attach "/numeric" to a message name (=string), if values should be sorted as numbers; done 20080324 - idea: allow "/[a[scending]|d[escending]][n[umeric]|[c[ase]|i[gnore]], then apply respective comparators */ ::class "MessageComparator" mixinclass Comparator ::method init expose message cacheTable messages messageArray numericComparator caselessComparator asc use strict arg message, bCache=.false signal on syntax if \datatype(bCache,"O") then raise syntax 34.900 array ("Method argument 2 ('cache') must be a logical value, received:" bCache) bSingleMessage=\(message~isA(.collection)) -- determine whether we received a collection if \bSingleMessage, bCache=.true then raise syntax 88.900 array ("Using multiple messages for comparisons, caching not allowed! Argument 'cache' must be omitted or set to '.false'.") emptyString="" -- define empty string if bSingleMessage then do -- set var "asc" (A[sc]/D[esc]), "kind" (N|I|C) asc="A" -- default to A[scending] sort kind="" bNumericMessage=.false -- indicates whether message result should be compared as a number -- say "---> message="pp(message) "message~class="pp(message~class"...") if message~isA(.string) then -- name of a message, create message object do parse caseless var message message "/" +1 flags -- set var "asc" (A[sc]/D[esc]), "kind" (N|I|C) if flags<>"" then parse value determineSortingKind(flags) with asc kind message=.message~new(.nil, message~strip) -- make sure to strip leading & trailing space end else if \message~isA(.message) then do raise syntax 93.900 array ("Method argument 1 must be either a message name (a string) or a message object, found:" message) end if bCache then cacheTable=.table~new -- create table to use for cache if kind="N" then -- numeric sort do numericComparator=.NumberComparator~new -- create the numeric comparator if bCache then self~setMethod("compare", self~instanceMethod("cached_plain_numeric_compare"), "Object") else self~setMethod("compare", self~instanceMethod("plain_numeric_compare"), "Object") end else if kind="I" then -- case independent sort do caselessComparator=.CaselessComparator~new -- create the caseless comparator if bCache then self~setMethod("compare", self~instanceMethod("cached_plain_caseless_compare"), "Object") else self~setMethod("compare", self~instanceMethod("plain_caseless_compare"), "Object") end else -- plain sort do if bCache then self~setMethod("compare", self~instanceMethod("cached_plain_compare"), "Object") else self~setMethod("compare", self~instanceMethod("plain_compare"), "Object") end end else -- collection of messages! do -- create the comparator objects numericComparator =.NumberComparator~new caselessComparator=.CaselessComparator~new messages=.array~new -- use a list to keep all message objects -- three dimensions: 1=messageObject, 2=kind (I|N|C|""), 3=ascending (A|D) messageArray =.array~new(message~items,3) i=0 do msg over message -- iterate over received collection i+=1 asc="A" -- default to A[scending] sort kind="" -- no kind given, regular comparison if msg~isA(.array) then -- [1]=msg (a string or message), [2]=flagString [, [3]=flagString2] do flags=msg[2] -- get flags if \flags~isA(.string) then raise syntax 93.900 array ("Message item #" i": array object must have a string value ('flags') at index '2'.") if msg~hasindex(3), msg[3]~isA(.String) then -- maybe index #3 has flag information also? flags=flags msg[3] -- in this case [2]="A|D", [3]="C|I|N" if \(msg[1]~isA(.String) | msg[1]~isA(.Message)) then raise syntax 93.900 array ("Message item #" i": array object must have a string value ('methodName') or message object ('method') at index '1'.") parse value determineSortingKind(flags) with asc kind -- process flags msg=msg[1] -- now assign first element end if msg~isA(.string) then -- name of a message, create message object do -- check whether message contains a "/" which indicates flags coming up parse var msg msg "/" +1 flags -- set var "asc" (A[sc]/D[esc]), "kind" (N|I|C) -- say "msg:" pp(msg) "-> message:" pp(message) "flags:" pp(flags) if flags<>"" then parse value determineSortingKind(flags) with asc kind messageArray[i,1]=.message~new(.nil, msg~strip) -- save message object messageArray[i,2]=kind -- save "kind" (N|I|C|"") if asc="D" then messageArray[i,3]="D" -- descending sort else messageArray[i,3]="A" -- ascending sort end else if msg~isA(.message) then -- a message object in hand do messageArray[i,1]=msg -- save message object messageArray[i,2]=kind -- kind: regular comparison messageArray[i,3]=asc -- ascending sort end else -- neither string nor message object ! raise syntax 93.900 array ("Item #" i "of the supplied collection must be either a message name (a string) or a message object!") end self~setMethod("compare", self~instanceMethod("multiple_messages_compare"), "Object") end -- say /* ???*/ return /* Analyze flags return blank delimited string: A|D [N|I|C] */ determineSortingKind: procedure parse arg flags signal on syntax if words(flags)=1 then -- could be a concatenation of "nd", "ac", "di", etc. do flags=flags~strip~left(2)~translate if pos(flags~subchar(2), "NADCI")=0 then -- second char is not an option, remove it flags=flags~left(1) end else do tmpStr="" do i=1 to words(flags) -- get first character of word tmpStr=tmpStr || word(flags,i)~left(1) end flags=tmpStr~upper -- into uppercase end pos=verify(flags,"NADCI", "N") -- any non-matching chars? if pos>1 then raise syntax 93.914 array("'/flags'", "[C[aseDependent] | I[gnoreCase] | N[umeric]] [A[asc] | D[esc]]]", msg) res="" if pos("D", flags)>0 then do res="D" -- descending if pos("A", flags)>0 then raise syntax 93.300 array("Contradictionary flags: only one of the flags 'A'[scending] and 'D'[escending] must be given.") end else -- default value, if neither "D" nor "A" is given res="A" -- ascending if pos("N", flags)>0 then do res=res "N" -- numeric/number if verify(flags, "CI", "M")>0 then raise syntax 93.300 array("Contradictionary flags: only one of the flags 'C'[aseDependent], 'I'[gnoreCase] and 'N'[umeric] must be given.") end else if pos("I", flags)>0 then do res=res "I" -- ignore case if verify(flags, "CN", "M")>0 then raise syntax 93.300 array("Contradictionary flags: only one of the flags 'C'[aseDependent], 'I'[gnoreCase] and 'N'[umeric] must be given.") end else if pos("C", flags)>0 then do res=res "C" -- respect case if verify(flags, "IN", "M")>0 then raise syntax 93.300 array("Contradictionary flags: only one of the flags 'C'[aseDependent], 'I'[gnoreCase] and 'N'[umeric] must be given.") end -- say "... flags:" pp(flags) "->res:" pp(res) return res syntax: -- propagate syntax exception, if any raise propagate /* this version caches the result of the messages sent, and therefore can reuse previous message results directly */ ::method cached_plain_compare expose message cacheTable asc use strict arg left, right if \cacheTable~hasindex(left) then -- not cached yet? cacheTable[left]=message~copy~send(left) -- get value if \cacheTable~hasindex(right) then -- not cached yet? cacheTable[right]=message~copy~send(right) -- get value if asc="A" then -- ascending return cacheTable[left]~compareTo(cacheTable[right]) else -- descending return cacheTable[right]~compareTo(cacheTable[left]) ::method cached_plain_numeric_compare expose message cacheTable numericComparator asc use strict arg left, right if \cacheTable~hasindex(left) then -- not cached yet? cacheTable[left]=message~copy~send(left) -- get value if \cacheTable~hasindex(right) then -- not cached yet? cacheTable[right]=message~copy~send(right) -- get value if asc="A" then -- ascending return numericComparator~compare(cacheTable[left], cacheTable[right]) else -- descending return numericComparator~compare(cacheTable[right], cacheTable[left]) ::method cached_plain_caseless_compare expose message cacheTable caselessComparator asc use strict arg left, right if \cacheTable~hasindex(left) then -- not cached yet? cacheTable[left]=message~copy~send(left) -- get value if \cacheTable~hasindex(right) then -- not cached yet? cacheTable[right]=message~copy~send(right) -- get value if asc="A" then -- ascending return caselessComparator~compare(cacheTable[left], cacheTable[right]) else -- descending return caselessComparator~compare(cacheTable[right], cacheTable[left]) ::method plain_compare expose message asc use strict arg left, right if asc="A" then -- ascending return message~copy~send(left)~compareTo(message~copy~send(right)) else -- descending return message~copy~send(right)~compareTo(message~copy~send(left)) ::method plain_numeric_compare expose message numericComparator asc use strict arg left, right if asc="A" then -- ascending return numericComparator~compare(message~copy~send(left), message~copy~send(right)) else -- descending return numericComparator~compare(message~copy~send(right), message~copy~send(left)) ::method plain_caseless_compare expose message caselessComparator asc use strict arg left, right if asc="A" then -- ascending return caselessComparator~compare(message~copy~send(left), message~copy~send(right)) else -- descending return caselessComparator~compare(message~copy~send(right), message~copy~send(left)) ::method multiple_messages_compare expose messageArray numericComparator caselessComparator use strict arg left, right do i=1 to messageArray~dimension(1) -- process all messages until a comparison yields unequal msg=messageArray[i,1] -- get message object if messageArray[i,2]="" then -- regular comparison do if messageArray[i,3]="A" then -- Ascending sort res=msg~copy~send(left)~compareTo(msg~copy~send(right)) else res=msg~copy~send(right)~compareTo(msg~copy~send(left)) end else if messageArray[i,2]="I" then -- case independent comparison! do if messageArray[i,3]="A" then -- Ascending sort res=caselessComparator~compare(msg~copy~send(left), msg~copy~send(right)) else res=caselessComparator~compare(msg~copy~send(right), msg~copy~send(left)) end else if messageArray[i,2]="N" then -- numeric comparison! do if messageArray[i,3]="A" then -- Ascending sort res=numericComparator~compare(msg~copy~send(left), msg~copy~send(right)) else res=numericComparator~compare(msg~copy~send(right), msg~copy~send(left)) end else -- standard comparison do if messageArray[i,3]="A" then -- Ascending sort res=msg~copy~send(left)~compareTo(msg~copy~send(right)) else res=msg~copy~send(right)~compareTo(msg~copy~send(left)) end if res<>0 then return res end return 0 -- default return value -- ???????????????????????????? ::class "MessageComparator_bkp on 20080325 (works!)" mixinclass Comparator ::method init expose message messages arraySortKind numericComparator caselessComparator use strict arg message, cache=.false if \datatype(cache,"O") then raise syntax 34.900 array ("Method argument 2 ('cache') must be a logical value, received:" cache) bSingleMessage=\(message~isA(.collection)) -- determine whether we received a collection if \bSingleMessage, cache=.true then raise syntax 88.900 array ("Using multiple messages for comparisons, caching not allowed! Argument 'cache' must be omitted or set to '.false'.") numericComparator=.NumberComparator~new -- make sure we have a number comparator in case if bSingleMessage then do bNumericMessage=.false -- indicates whether message result should be compared as a number if message~isA(.string) then -- name of a message, create message object do parse caseless var message message "/numeric" +0 rest bNumericMessage=(rest<>"") -- to compare numerically? message=.message~new(.nil, message~strip) -- make sure to strip leading & trailing space end else if \message~isA(.message) then raise syntax 93.900 array ("Method argument 1 must be either a message name (a string) or a message object!") if cache then -- cache results of messages? do cacheTable=.table~new -- create table to use for cache if bNumericMessage then self~setMethod("compare", self~instanceMethod("cached_plain_numeric_compare"), "Object") else self~setMethod("compare", self~instanceMethod("cached_plain_compare"), "Object") end else -- use the uncached version do if bNumericMessage then self~setMethod("compare", self~instanceMethod("plain_numeric_compare"), "Object") else self~setMethod("compare", self~instanceMethod("plain_compare"), "Object") end end else -- collection of messages! do messages=.array~new -- use a list to keep all message objects messagesNumericIndicator=.array~new -- indicates whether comparison should be numeric i=0 do msg over message -- iterate over received collection i=i+1 if msg~isA(.string) then -- name of a message, create message object do -- check whether message contains a "/" which indicates -- a numeric comparison should be carried out with it parse caseless var msg msg "/numeric" +0 rest messagesNumericIndicator~append(rest<>"") msg=.message~new(.nil, msg) end else if msg~isA(.message) then -- a message object in hand messagesNumericIndicator~append(.false) else -- neither string nor message object ! raise syntax 93.900 array ("Item #" i "of the supplied collection must be either a message name (a string) or a message object!") messages~append(msg) -- append this message object end self~setMethod("compare", self~instanceMethod("multiple_messages_compare"), "Object") end /* this version caches the result of the messages sent, and therefore can reuse previous message results directly */ ::method cached_plain_compare expose message cache cacheTable use strict arg left, right if \cacheTable~hasindex(left) then -- not cached yet? cacheTable[left]=message~copy~send(left) -- get value if \cacheTable~hasindex(right) then -- not cached yet? cacheTable[right]=message~copy~send(right) -- get value return cacheTable[left]~compareTo(cacheTable[right]) ::method cached_plain_numeric_compare expose message cache cacheTable numericComparator use strict arg left, right if \cacheTable~hasindex(left) then -- not cached yet? cacheTable[left]=message~copy~send(left) -- get value if \cacheTable~hasindex(right) then -- not cached yet? cacheTable[right]=message~copy~send(right) -- get value return numericComparator~compare(cacheTable[left], cacheTable[right]) ::method plain_compare expose message use strict arg left, right return message~copy~send(left)~compareTo(message~copy~send(right)) ::method plain_numeric_compare expose message numericComparator use strict arg left, right return numericComparator~compare(message~copy~send(left), message~copy~send(right)) ::method multiple_messages_compare expose messages messagesNumericIndicator numericComparator use strict arg left, right do i=1 to messages~items -- process all messages until a comparison yields unequal msg=messages[i] -- get message object if messagesNumericIndicator[i]=.false then do res=msg~copy~send(left)~compareTo(msg~copy~send(right)) end else -- numeric comparison! do -- res=(msg~copy~send(left) - msg~copy~send(right))~sign res=numericComparator~compare(msg~copy~send(left), msg~copy~send(right)) end if res<>0 then return res end return res -- ???????????????????????????? /* ======================================================================= */ /* Compares Rexx (string) numbers. If the instance is created with an (optional) argument of .true, then numbers are compared as numbers, but if one or both arguments are not numbers, then the normal string "compareTo" will be employed. Comparison of numbers is carried out under NUMERIC DIGITS 40, which allows comparing numbers in the 2**128 range */ ::class "NumberComparator" mixinclass Comparator ::method init use arg bIgnoreNonNumbers=.true if bIgnoreNonNumbers=.false then return -- just use the plain number comparisons (default: method "compare") if \datatype(bIgnoreNonNumbers, "O") then -- not boolean/lOgical ! raise syntax 34.901 array (bIgnoreNumbers) -- default method to use self~setMethod("compare", self~instanceMethod("compareWithNonNumbers")) -- number only version, if non-number let runtime raise the syntax error ::method compare use strict arg left, right numeric digits 40 -- allow to deal with numbers up to 2**128 return (left-right)~sign -- returns -1 (leftright), 0 (left=right) ::method compareWithNonNumbers expose stringIgnoreCase use strict arg left, right if var("stringIgnoreCase")=.false then stringIgnoreCase=.StringComparator~new("AI") -- 20090520, rgf numeric digits 40 -- allow to deal with numbers up to 2**128 if datatype(left, "n"), datatype(right, "n") then return (left-right)~sign -- returns -1 (leftright), 0 (left=right) return stringIgnoreCase~compare(left,right) -- rgf, 20090520 -- return left~compareTo(right)-- use the String's "compareTo" ::method compareWithNonNumbersDescending -- used by StringComparator expose stringIgnoreCase use strict arg left, right if var("stringIgnoreCase")=.false then stringIgnoreCase=.StringComparator~new("DI") -- 20090520, rgf numeric digits 40 -- allow to deal with numbers up to 2**128 if datatype(left, "n"), datatype(right, "n") then return -((left-right)~sign) -- returns -1 (leftright), 0 (left=right) return stringIgnoreCase~compare(left,right) -- rgf, 20090520 -- return -(left~compareTo(right))-- use the String's "compareTo" /* ======================================================================= */ /* Single class to wrap comparators for string objects: - ascending, case-dependent (Comparator: "A", "C"), also: "AC", "CA" - descending, case-dependent (DescendingComparator: "D", "C"), also: "DC", "CD" - ascending, case-independent (CaselessComparator: "A", "I"), also: "AI", "IA" - descending, case-independent (CaselessDescendingComparator: "D", "I"), also: "DI", "ID" .StringComparator~new([A|D][,][C|I|N]) A|D ... optional: "A"scending (default), "D"escending C|I|N ... optional: "C"ase dependent (default), "I"gnore case, "N"umeric (Rexx-style numbers) [hint: argument letters and sequence from SysStemSort] */ ::class "StringComparator" mixinclass Comparator ::method init parse upper arg one, two args=(one||two)~space(0) -- concatenate, remove spaces if args="" then args="AC" -- default to: ascending, case dependent pos=verify(args, "ADCIN") -- check whether only valid chars if pos>0 then -- point to wrong value raise syntax 93.915 array ("ADCIN", substr(args,pos,1)) orderNr=(pos("D", args)>0)+1 -- "A": default=1, "D"=2 caseNr =(pos("I", args)>0)+1 -- "C": default=1, "I"=2 if caseNr=1, pos("N",args)>0 then -- "N"umeric in hand? caseNr=3 if orderNr=1 then do if caseNr=1 then -- Ascending, Case-dependent self~setMethod("compare", "use strict arg left, right; return left~compareTo(right)") else if caseNr=2 then -- Ascending, case-Independent do self~setMethod("compare", "use strict arg left, right; return left~caselessCompareTo(right)") -- self~setMethod("compare", "use strict arg left, right; say '['left']/['right']'; return left~caselessCompareTo(right)") end else if caseNr=3 then -- "N"umeric (Rexx-style numbers) self~setMethod("compare", .NumberComparator~method("compareWithNonNumbers")) end else do if caseNr=1 then -- Descending, Case-dependent self~setMethod("compare", "use strict arg left, right; return -left~compareTo(right)") else if caseNr=2 then -- Descending, case-Independent self~setMethod("compare", "use strict arg left, right; return -left~caselessCompareTo(right)") else if caseNr=3 then -- "N"umeric (Rexx-style numbers) self~setMethod("compare", .NumberComparator~method("compareWithNonNumbersDescending")) end /* say "**debug (StringComparator): order="order "orderNr="orderNr "| case="case "caseNr="caseNr -- say " " self~instanceMethod("compare")~source~toString"..." say " method code:" .endOfLine || ppMethod(self~instanceMethod("compare"), "0909"x) */ ::method compare abstract -- by default abstract to define the protocol /* ======================================================================= */ /* usage: NEW({pos [,length] [,A|D} [,C|I|N]} [, ...]) NEW(coll [,defaultAD [,defaultCIN]]) sorts by the given column, there can be as many columns as the user sees fit where arguments: pos start position length optional, indicates comparison length A|D optional, sort "A"scending/"D"escending C|I|N optional, use "C"ase-sensitive|case-"I"ndependent| "N"umberComparator "O"numberComparator relaxed (treats non-numbers as 0) coll ordered collection or supplier object containing the arguments in the above described sequence defaultAD default value for sorting order, in case it is omitted defaultCIN default value for comparison type, in case it is omitted there can be any number of columns, two consecutive numbers are interpreted as pos and length; 'length' is omitted if 'pos' is followed by a non-numeric argument (A|D or C|I|N) */ ::class 'StringColumnComparator' mixinclass Comparator ::method init expose numberComparator use strict arg arg1, ... def="" if datatype(arg(2),"M") then def=arg(2) if datatype(arg(3),"M") then def=def||arg(3) -- check and set sort options parse value checkSortOptions(def) with def defAD defCIN /* if argument is an ordered collection or supplier, then use its content to set up the comparison code */ if arg1~isA(.OrderedCollection) | arg1~isA(.Supplier) then args=arg1~allItems -- get items/values as an array else args=arg(1, "A") -- get arguments as an array -- comparator for Rexx numbers (defaults to allow comparing numbers with strings as well) numberComparator=.numberComparator~new -- analyze columns and type of comparison, store in temp array resArr=.array~new -- [1]...'pos', [2]...'length' or .nil, [3]...A|D, [4]...C|I count=0 -- index into resulting array items=args~items -- number of args do i=1 to items -- expecting position val=args[i] -- get argument -- if \datatype(val, "W") & val>0 then if \datatype(val, "W") | val<1 then raise syntax 93.907 array (i, val) -- raise an error count=count+1 -- new column to sort resArr[count,1]=val -- save starting position -- set default sorting options resArr[count,3]=defAD -- use default a/descending order resArr[count,4]=defCIN -- use case-sensitive, insensitive, number if i=items then leave -- no more infos -- length available ? i+=1 -- position on next arg, if available val=args[i] if datatype(val, "W") then do resArr[count,2]=val -- save length if i=items then leave -- already last item processed? if datatype(args[i+1],"W") then -- a number coming up, i.e. a new starting position! iterate i -- iterate i+=1 -- position on next item, i.e. sorting option val=args[i] -- a sorting options end -- a sorting option in hand? if i0 then return res") methArr~append("") end else methArr~append('return' createCodeSnippet(resArr,i)) end /* now use this code for a method 'compare', use object's scope */ self~setMethod("compare", methArr, "Object") -- filler="09"x||"***"||"09"x -- say "**debug StringColumnComparator:" ||.endOfLine || ppMethod(self~instanceMethod('compare'), filler) return /* -------------- check for options ------------------- */ -- check options, make sure all are set checkSortOptions: procedure parse upper arg def, arg2 def=(def||arg2)~space(0) -- check for "A"scdending, "D"escending pos=verify("AD", def, "M") -- find matching char if pos=0 then def=def||"A" -- add ascending as default -- check for "C"ase-sensitive, case "I"nsensitive, "N"umber comparison pos=verify("CIN", def, "M") -- find matching char if pos=0 then def=def||"C" -- add case-sensitive as default pos=verify(def, "ADCIN", "N") -- find non-matching char if pos<>0 then -- error: non-matching char in option string! raise syntax 93.915 array ("ADCIN", def":" substr(def,pos,1)) return def - substr(def, verify(def, "AD" , "M") ,1) - -- extract option letter substr(def, verify(def, "CIN", "M"),1) -- extract option letter /* -------------- create comparison code -------------- */ createCodeSnippet: procedure use arg resArr, idx -- determine starting position and (optional) length startPosAndLength=resArr[idx,1] -- start column if .nil<>resArr[idx,2] then -- length given? startPosAndLength=startPosAndLength","resArr[idx,2] pos=pos(resArr[idx,4], "CIN") -- determine which kind of comparison if pos<3 then -- string comparisons using "[caseless]CompareTo" do if pos=2 then -- case-Independent comparisons tmpStr="left~caselessCompareTo(right," else -- CASE-dependent comparisons tmpStr="left~compareTo(right," tmpStr=tmpStr startPosAndLength -- supply start position (and optional length) end else -- Rexx numbers to compare! do -- if pos=3 then -- "N": compare numbers tmpStr="numberComparator~compare(left~subStr("startPosAndLength")," - "right~substr("startPosAndLength")" /* else -- "O": compare numbers, but relax (use value 0 for non-numbers) tmpStr="numberComparator~compare(left~subStr("startPosAndLength")," - "right~substr("startPosAndLength"), .true" */ end if resArr[idx,3]="D" then -- sort descending: invert result return "-"tmpStr")" -- return the comparison statement return tmpStr")" -- return the comparison statement /* ======================================================================= */ /* Enclose string in square brackets show non-printable chars as Rexx hex-strings. If non-string object, then show its string value and hash-value. */ ::routine pp public use strict arg a1 if \a1~isA(.string) then do if a1~isA(.Collection) then return "["a1~string "("a1~items "items)" "id#_" || (a1~identityHash)"]" else return "["a1~string "id#_" || (a1~identityHash)"]" end return "["escape(a1)"]" /* ======================================================================= */ /* Enclose string in square brackets show non-printable chars as Rexx hex-strings. If non-string object, then show its string value and hash-value. Formats Index-values. */ ::routine ppIndex public use strict arg a1 if \a1~isA(.string) then do if a1~isA(.array), a1~dimension=1 then do -- if a1~dimension=1 then -- create comma-delimited list of index-values? do tmpStr="" bFirst=.true minWid=1 maxElements=5 do i=1 to a1~items for maxElements tmpVal=a1[i] if datatype(tmpVal,"W"), length(tmpVal)maxElements then do tmpStr=", ..." end return "["tmpStr"]" end end return "["a1~string "id#_" || (a1~identityHash)"]" end return "["escape(a1)"]" /* Escape non-printable chars in Rexx-style. */ ::routine escape public parse arg a1 res="" do while a1\=="" pos1=verify(a1, .rgf.non.printable, "M") if pos1>0 then do pos2=verify(a1, .rgf.non.printable, "N" , pos1) if pos2=0 then pos2=length(a1)+1 if pos1=1 then do parse var a1 char +(pos2-pos1) a1 bef="" end else parse var a1 bef +(pos1-1) char +(pos2-pos1) a1 if res=="" then do if bef \=="" then res=enquote(bef) '|| ' end else do res=res '||' enquote(bef) '|| ' end res=res || '"'char~c2x'"x' end else do if res<>"" then res=res '||' enquote(a1) else res=a1 a1="" end end return res /* ======================================================================= */ /* Returns a new relation object created from the passed in collection object. If the second argument is given, it must be a message name or a message object. makeRelation2(coll [,message]) coll ... collection or supplier object to turn into a relation object message ... optional, must be the name of a message or a message object which gets sent to each object in the collection and which result object is used as the index object to which the collection object should be associated with in the new relation */ ::routine makeRelation2 public use strict arg coll, message=.nil if .nil=message then -- only one argument, assuming collection object do return .relation~new~~putAll(coll~supplier) end if message~isA(.string) then -- name of a message, create message object message=.message~new(.nil, message) else if \message~isA(.message) then raise syntax 36.900 array ("Argument 2 must be a message name (a string) or a message object!") rel=.relation~new do o over coll rel[message~copy~send(o)]=o -- use message result as index for o end return rel /* ======================================================================= */ /* Enquote string, escape quote/apostrophe. Optionally supply character(s) to serve as quote/apostrophe. */ ::routine enquote public use arg string, quote='"' return quote || string~changestr(quote, quote~copies(2)) || quote /* ======================================================================= */ /* Expects a method object and an optional string for indenting/prefixing. Returns a string containing the source code or a comment indicating that no source code is available for the method. */ ::routine ppMethod public use strict arg meth, indent="" src=meth~source /* get source */ tmpStr="" bFirst=.true do s over src if bfirst then do tmpStr=indent||s bFirst=.false end else tmpStr=tmpStr || .endOfLine || indent || s end if tmpStr="" then /* no source code available */ return "/* no source code available */" return tmpStr /* Class that allows to define deliberately which characters constitute delimiters of words or which characters constitute words. All word-related BIFs are implemented as methods. Operations that change the string value (methods delWord, subWord) will change the instance's string value accordingly. The characters that serve either as word-delimiters or as constituting words are available via the attribute "reference", the interpretation of the reference characters is controlled via the attribute "kind" (values "D"elimiter- or "W"ord-characters). The string value to operate on is available via the attribute "string". The following attributes are available: string ... the string to work upon reference ... a string of characters that either serve as word delimiters or define the characters that constitute words (e.g. allows for defining all letters in German, including umlauts!) kind ... determines how "reference" is interpreted: "D"elimiter characters or "W"ord characters (characters that constitute a word) wordArray ... a read-only attribute that supplies a one-dimensional array of words extracted from "string" according to "reference" characters interpreted according to "kind" positionArray ... a read-only attribute that supplies a two-dimensional array of positions and lengths of the words contained in "string" according to "reference" characters interpreted according to "kind" */ ::class "StringOfWords" /* Arguments: string ... mandatory reference ... optional (default: " "||"09"x), defines a string of characters kind ... optional (default: "D"), determines whether "reference" contains characters that "d"elimit words or constitute "w"ords. */ ::method init expose string oldKind positionArray wordArray signal on syntax -- check arguments use strict arg string, reference=(" "||"09"x), kind="D" .ArgUtil~validateClass("string", string, .string) -- check for correct type .ArgUtil~validateClass("reference", reference, .string) -- check for correct type if reference=="" then -- empty string, define default: blank/tab reference=" "||"09"x self~reference=reference -- assign reference .ArgUtil~validateClass("kind", kind , .string) -- check for correct type self~kind=kind -- check & assign "kind"-value return syntax: raise propagate ::attribute string get ::attribute string set expose string posDirty? wordDirty? parse arg string -- make sure arrays are regenerated at access time posDirty?=.true wordDirty?=.true ::attribute reference get -- character-string used for VERIFY()-reference ::attribute reference set expose reference oldReference dirty? parse arg tmp if reference\==tmp then -- save "D" or "W" to use directly with parseWords2() do reference=tmp -- save "D" or "W" to use directly with parseWords2() posDirty?=.true -- on next access of pos+len-array, re-create array object wordDirty?=.true -- on next access of pos+len-array, re-create array object end -- determines whether "reference" is used for determining space or word characters -- "D"elimiter-chars, "W"ord-chars ::attribute kind get ::attribute kind set expose internalKind kind posDirty? wordDirty? parse arg tmp . signal on syntax tmp1=tmp~left(1)~upper if pos(tmp1, "DW")=0 then raise syntax 93.914 array("'kind'", "D[elimiter] | W[ord-characters]", tmp) kind=tmp if internalKind<>tmp1 then -- save "D" or "W" to use directly with parseWords2() do internalKind=tmp1 -- save "D" or "W" to use directly with parseWords2() posDirty?=.true -- on next access of pos+len-array, re-create array object wordDirty?=.true -- on next access of pos+len-array, re-create array object end return syntax: raise propagate ::attribute positionArray get -- execute "parseWords2" expose posDirty? internalKind positionArray reference string if posDirty? then -- string/reference/kind changed, make sure we (re-)generate the position/length array do /* TODO: parseWords2() vs. parseWords() ? */ positionArray=parseWords2(string, reference, internalKind, "P") posDirty?=.false end return positionArray~copy ::attribute wordArray get expose wordArray wordDirty? internalKind reference string if wordDirty? then -- string/reference/kind changed, make sure we (re-)generate the position/length array do /* TODO: parseWords2() vs. parseWords() ? */ wordArray=parseWords2(string, reference, internalKind, "W") wordDirty?=.false end return wordArray~copy ::method makeArray forward message (wordArray) /* /* - parses string for words according to "reference"-chars and "kind"-option - argument: "W"...create single-dimensioned array of parsed words "P"...create two-dimensional array of position and length of words - returns a new array object */ ::method parseWords expose string reference internalKind posDirty? wordDirty? positionArray wordArray signal on syntax use strict arg returnType .ArgUtil~validateClass("returnType", reference, .string) -- check for correct type if returnType<>"W" then -- not a default value do tmp=returnType~strip~left(1)~upper if pos(tmp, "WP")=0 then raise syntax 93.914 array("'returnType'", "W[ords-array] | P[ositions-array]", returnType) returnType=tmp end if returnType="W" then -- single-dimensioned array of words do if \wordDirty? then return wordArray~copy res=.array~new end else -- two-dimensional array of position and length do if \posDirty? then return positionArray~copy res=.array~new(0,0) end maxLen=length(string) pos=1 endPos=1 do i=1 while endposwords then string="" else do tmpPos=arr[position,1] -- starting position (no leading spaces) endPos=arr[words,1]+arr[words,2] -- ending position (no trailing spaces) tmpLen=endPos-tmpPos -- calculate length string=string~substr(tmpPos,tmpLen) -- change string in place end return string end else if \datatype(length, "W") then raise syntax 93.905 array("'length'", arg(2)) -- must be a number if length=0 then -- string will be set to empty do string="" return string end if length<0 then -- move positioning position to left? do tmpPos=position+length+1 if tmpPos<1 then -- beyond start, delete all words up to and including position do length=position -- set length to position position=1 -- set start to 1 end else do length=position-tmpPos+1 -- number of words affected position=tmpPos -- starting position end end if position>words then string="" else do tmpPos=arr[position,1] -- starting position (no leading spaces) lastWord=min(position+length-1,words) -- calc last word to be included endPos=arr[lastWord,1]+arr[lastWord,2] -- ending position (no trailing spaces) tmpLen=endPos-tmpPos -- calculate length string=string~substr(tmpPos,tmpLen) -- change string in place end return string syntax: raise propagate ::method word -- extract and return word expose string signal on syntax use strict arg position if \datatype(position, "W") then raise syntax 93.905 array("'n' (n-th word in string)", arg(2)) -- must be a number arr=self~positionArray -- get positional array maxItems=arr~dimension(1) -- get # of entries if position<1 then do position=maxItems+position+1 -- calc position from right if position<1 then -- minimum start is 1 return "" end if maxItemsmaxItems then -- not enough words left, hence cannot match return 0 -- indicate phrase not found bFound=.true do k=1 to maxPhraseItems while bFound m=i+k-1 if bCaselessCompare then bFound=bFound & ((string~caselessMatch(arr[m,1], arrPhraseWord[k]))=1) else bFound=bFound & ((string~ match(arr[m,1], arrPhraseWord[k]))=1) end if bFound then -- found! return position return i end end return 0 -- not found syntax: raise propagate /* allow for negative positional and length infos, semantics need to be defined yet: > abbrev info, string [, n-length] > changeStr* needle, haystack, newNeedle [,n-count] NO:compare NO:countStr > delStr* string, n-start [, n-length] > delWord* string, n-wPos [, n-count] > lastPos* needle, haystack [,n-start] > left* string, n-length [,pad] > lower* string [,n-start] [,n-length] > overlay* new, target [,n-start] [,n-length] [,pad] > pos needle, haystack [,n-start] > right* string, n-length [,pad] > SUBCHAR2* string, n-pos -- creating new BIF, if n-pos greater string then "" is returned; it's a string method only > subStr* string, n-start [,n-length] [,pad] > subWord* string, n-wPos [,n-wLength] > upper* string [,n-start] [,n-length] > word* string, n-wPos NO:words > wordIndex* string, n-wPos > wordLength* string, n-wPos > wordPos* phrase, string [,n-wStart] ! caseless o.k. start -> if negative: start from the other side (left <-> right) length -> if negative: towards the other direction (left <-> right) count -> if negative: last "count" occurrences --- idea: WORD-related BIFs: - supply optional deli-string of chars, delimiting words; use verify to parse - create function that returns an array of parsed words without any deli-chars; optionally allow leading deli-chars (in order to re-assamble), last word also has trailing - create function that normalizes a string of words using a supplied deli-string (defaulting to single blank); optionally allow for deli-chars (that delimit a word) ---> implemented in .StringOfWord class */