ordering.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
-------------------------> GNU Sather - sourcefile <-------------------------
-- Copyright (C) 2000 by K Hopper, University of Waikato, New Zealand --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute and/or modify it under the terms of the GNU Library General --
-- Public License (LGPL) as published by the Free Software Foundation; --
-- either version 2 of the license, or (at your option) any later version. --
-- This library is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details. --
-- The license text is also available from: Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --
--------------> Please email comments to <bug-sather@gnu.org> <--------------
class ORDER_WEIGHT < $ORDERED{ORDER_WEIGHT}, $BINARY, $STR
class ORDER_WEIGHT < $ORDERED{ORDER_WEIGHT}, $BINARY, $STR is
-- This immutable class is provided to implement the weight ordering
-- for string sorting purposes according to the standards ISO/IEC 14651/2.
-- Version 1.1 Jul 98. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 11 Jul 97 kh Original
-- 11 Jul 98 kh Added multiple weights, pre/post conds.
private include AREF{CARD} aget -> aget ;
-- Make modification routines private.
include COMPARABLE ;
include BINARY ;
create(num : CARD) : SAME is
--This creation routine is only used in the iters in this class and in
-- the WEIGHT_RANGE class to create a single element weight.
me : SAME := new(1) ;
me[0] := num ;
return me
end ;
nil : SAME is
--This creation routine is only used in the iters in this class and in
-- the WEIGHT_RANGE class to create a single element weight.
me : SAME := new(1) ;
me[0] := CARD::nil ;
return me
end ;
build(cursor : BIN_CURSOR) : SAME
pre ~void(cursor) and (cursor.remaining >= ((cursor.item.card * 2) + 1))
post result.asize = initial(cursor.item.card)
is
--This routine creates an order weight from the binary string which
-- is attached to the cursor!
loc_size : CARD := cursor.get_item.card ; -- No of individual weights
me : SAME := new(loc_size) ;
loop
loc_size.times! ;
loc_val : BINSTR := cursor.get_sized ;
loc_wt : CARD := loc_val.cursor.card ;
me.aset!(loc_wt)
end ;
return me
end ;
IGNORE : SAME is
--Just a null object.
return void
end ;
lowest : SAME is
--This routine initialises a weight as the lowest possible value in the ordering sequence.
return create(1)
end ;
highest : SAME is
--This routine initialises a weight as the highest possible value in
-- the ordering sequence for the given encoding. This value will be greater
-- than the highest code value due to the definition of collating elements
-- in ISO/IEC 14652.
return create(CARD::maxval)
end ;
offset(by : CARD) : SAME
pre ~void(self) and (asize > 0)
post (result.size = self.size)
is
--This 'addition' routine is needed when establishing various groups of
-- weights relative to an offset for each group.
if void(self) then
return void
end ;
res : SAME := new(asize) ;
loop
res.aset!(aelt! + by)
end ;
return res
end ;
next_one : SAME
pre ~void(self)
post result.size = self.size
is
--This returns the weight next in sequence of ordered weights .
return offset(1)
end ;
binstr : BINSTR
pre ~void(self)
post (result.size = (size * NUM_BITS::Octets_per_Card))
is
--This routine returns self as its binary string representation which
-- includes size and element size octets.
if void(self) then
return void
end ;
res : FBINSTR := FBINSTR::create + OCTET::create(size) ;
loop
loc_str : BINSTR := aelt!.binstr ; -- MS octet first
loc_size : CARD := 0 ;
loop -- find first non-zero
if loc_str.elt! /= OCTET::null then
break!
else
loc_size := loc_size + 1
end
end ;
if loc_size = loc_str.size then -- All nulls!
loc_size := 1
else
loc_size := loc_str.size - loc_size
end ;
res := res + OCTET::create(loc_size) + loc_str.tail(loc_size)
end ;
return res.binstr
end ;
is_eq(other : SAME) : BOOL
is
--This predicate returns true if and only if self and other are the same, otherwise false.
if other.size = size then
loop
if other.aelt! /= aelt! then
return false
end
end ;
return true
else
return false
end
end ;
is_lt(other : SAME) : BOOL is
--This predicate returns true if and only if self is less than other, otherwise false.
if other.size = size then
loop
if ~(aelt! < other.aelt!) then
return false
end
end ;
return true
else
return other.size < size
end
end ;
is_nil : BOOL is
--This predicate returns true if and only if self is the nil weight.
return [0] = CARD::nil
end ;
plus(other : SAME) : SAME
pre true
post (result.size = (size + other.size))
is
--This routine may be used to add further elements to the weight
-- as may be needed during weight manipulation. This has immutable semantics.
res : SAME ;
if void(self) then
if void(other) then
return void
end ;
res := new(other.asize) ;
loop
res.aset!(other.aelt!)
end ;
return res
elsif void(other) then
res := new(size) ;
loop
res.aset!(aelt!)
end ;
return res
end ;
res := new(other.size + size) ;
loop
res.aset!(aelt!)
end ;
loop
outdex : CARD := asize.upto!(res.asize - 1) ;
res[outdex] := other.aelt!
end ;
return res
end ;
minus(other : SAME) : SAME
pre ~void(self)
post (void(other)
and (result = self))
or (~void(other)
and (result.size = size))
or void(result)
is
--This routine may be used to reduce the value of elements by the
-- weight offset indicated by the weight values of other, provided that both
-- are the same size (or other is void) and no reduction would produce
-- a weight less than lowest. This has immutable semantics.
res : SAME ;
if void(other) then
res := new(size) ;
loop
res.aset!(aelt!)
end ;
return res
end ;
if asize = other.asize then
res := new(size) ;
loop
diff : INT := aelt!.int - other.aelt!.int ;
if diff < 0.int then
return void
end ;
res.aset!(diff.card)
end ;
return res
else
return void
end
end ;
card : CARD
pre ~void(self)
post ((asize = 1)
and (result = [0]))
or (result = 0)
is
--This routine returns the cardinality of weights represented by self
-- provided that asize is one, otherwise zero.
if asize = 1 then
return [0]
else
return 0
end
end ;
size : CARD
post result = asize
is
-- This routine returns the number of elements in the order weight.
return asize
end;
elt! : SAME
pre ~void(self)
post true -- should be result = aelt!
is
--This iter yields successive individual weights of self --
-- which may, of course, only be 1!
loop
yield create(aelt!)
end
end ;
next! : SAME
pre ~void(self)
post true -- should be result = create(aelt! + 1)
is
--This routine returns the value of the weight next greater than
-- successive elements of self. This is required when establishing weights.
loop
yield create(aelt! + 1)
end
end ;
str(lib : LIBCHARS) : STR
pre ~void(self) and ~void(lib)
post (result.size >= 2)
is
--This routine returns the string form of self using the given encoding
-- and repertoire.
res : STR := STR::create(lib) + lib.Left_Bracket.char.str ;
loc_sep : STR := STR::create(lib) + lib.Comma.char + lib.Space.char ;
loop
loc_elem : CARD := aelt! ;
res := res + loc_sep.separate!(loc_elem.hex_str(lib))
end ;
return res + lib.Right_Bracket.char
end ;
str : STR
pre ~void(self)
post (result.size >= 2)
is
--This routine returns the string form of self using the default
-- encoding and repertoire.
return str(LIBCHARS::default)
end ;
end ; -- ORDER_WEIGHT
immutable class WEIGHT_RANGE < $RANGE{ORDER_WEIGHT}
immutable class WEIGHT_RANGE < $RANGE{ORDER_WEIGHT} is
-- This immutable class is provided to implement the ranges of single
-- weights which are specified in this implementation of ISO/IEC 14651/2.
-- Note that this is an immutable class with 'weight' values of single length
-- weights!
-- Version 1.0 Apr 98. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 21 Apr 98 kh Original
include RANGE{ORDER_WEIGHT} ;
is_lt(other : SAME) : BOOL is
-- This predicate returns true if and only if the high value of self is
-- strictly less than the low value of other -- taking into account the fact
-- that the stored 'high' is one greater than the actual end of the range.
return (self.high <= other.low)
end ;
in_range(val : ORDER_WEIGHT) : BOOL
pre val.size = 1
post (val.card >= low)and (val.card < high)
is
--This predicate returns true iff val lies in the range. Note the
-- assymetric test since high is always one greater than the high defined
-- when created, etc.
if val.size = 1 then
return (val.card >= low)
and (val.card < high)
else
return false
end
end ;
offset(range_val : ORDER_WEIGHT) : ORDER_WEIGHT
pre (size = 1)
and in_range(range_val)
and (range_val[0] > low)
post (result[0] = range_val[0] - low)
and (result.size = 1)
is
--This routine returns the value of range_val as an offset from zero,
-- taking into account the range low limit.
return ORDER_WEIGHT::create(range_val[0] - low)
end ;
first : ORDER_WEIGHT
pre ~is_empty
post (result[0] = low)and (result.size = 1)
is
--This routine returns the lowest value in the range provided that
-- the range is not empty.
return ORDER_WEIGHT::create(low)
end ;
last : ORDER_WEIGHT
pre ~is_empty
post (result[0] = (high - 1))and (result.size = 1)
is
--This routine returns the highest value in the range provided that
-- the range is not empty.
return ORDER_WEIGHT::create(high - 1)
end ;
reverse_elt! : ORDER_WEIGHT
pre ~is_empty
post (result.size = 1)and ((result[0] + elt![0]) = (high - 1 + low))
is
--This iter yields all of the values of self from high - 1 down to and
-- including low in turn.
val : CARD := high ;
loop
until!(val = low) ;
val := val - 1 ;
yield ORDER_WEIGHT::create(val)
end
end ;
end ; -- WEIGHT_RANGE
immutable class ORDER_RULE < $IS_EQ, $IS_LT{ORDER_RULE}, $BINARY, $STR
immutable class ORDER_RULE < $IS_EQ, $IS_LT{ORDER_RULE}, $BINARY, $STR is
-- This immutable class is provided to implement an individual rule
-- as used in text string sorting purposes according to the standards
-- ISO/IEC 14651/2.
-- Version 1.0 Jul 97. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 11 Jul 97 kh Original
include BINARY ;
include COMPARABLE ;
readonly attr left_to_right : BOOL ;
readonly attr positional : BOOL ;
create(fwd : BOOL,posn : BOOL) : SAME is
--This is the only special creation routine for an ordering rule.
return left_to_right(fwd).positional(posn)
end ;
build(index : BIN_CURSOR) : SAME
pre ~void(index) and (index.remaining >= 2)
is
-- This routine builds an order rule from the next two elements in the
-- given binary representation.
return left_to_right(BOOL::build(index)).positional(BOOL::build(index))
end ;
is_eq(other : SAME) : BOOL is
--This predicate returns true iof and only if self and other are the
-- same rule.
return (left_to_right = other.left_to_right)
and (positional = other.positional)
end ;
is_lt(other : SAME) : BOOL is
--This predicate is provided solely for array manipulation purposes.
-- It is identically false.
return false
end ;
binstr : BINSTR
pre true
post create(result) = self
is
--This routine returns a binary string representation of self.
return left_to_right.binstr + positional.binstr
end ;
forward : BOOL is
--This routine returns true if and only if left_to_right is true,
-- otherwise false.
return left_to_right
end ;
backward : BOOL is
--This routine returns true if and only if left_to_right is false,
-- otherwise false.
return ~left_to_right
end ;
private do_str(lib : LIBCHARS) : CODE_STR
pre ~void(lib)
post (result.size >= 5)
is
--This routine returns a text string representation of self.
return CODE_STR::create(lib) + lib.Left_Angle +
CODE_STR::create(left_to_right.str(lib)) + lib.Comma +
CODE_STR::create(positional.str(lib)) + lib.Right_Angle
end ;
str(lib : LIBCHARS) : STR
pre true
post (result.size >= 5)
is
--This routine returns a text string representation of self.
return do_str(LIBCHARS::default).tgt_str
end ;
str : STR
pre true
post (result.size >= 5)
is
--This routine returns a text string representation of self.
return do_str(LIBCHARS::default).tgt_str
end ;
end ; -- ORDER_RULE
class RANGE_ORDERING
class RANGE_ORDERING is
-- This class models an ordering rule which applies to all of
-- the members of a range of tokens.
-- Version 1.2 Apr 98. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 12 Mar 97 kh Original
-- 11 Jul 97 kh Modified to rectify misunderstanding
-- 21 Apr 98 kh Converted to use ORDER_WEIGHT
readonly attr domain : RANGE ;
readonly attr base_weight : ORDER_WEIGHT ;
readonly attr rules : ARRAY{ORDER_RULE} ;
private attr weights : ARRAY{ORDER_WEIGHT} ;
-- This array is 'parameterised' in that any weight which is of the
-- value ORDER_WEIGHT::maxval is deemed to be of the weight of the token
-- in the range.
create(dom : RANGE,base : ORDER_WEIGHT,dirns : ARRAY{ORDER_RULE},wts : ARRAY{ORDER_WEIGHT}) : SAME
pre ~dom.is_empty
and ~void(base)
and (dirns.size = wts.size)
and (dirns.size > 0)
post (result.domain = dom)
and (result.base_weight = base)
and (result.rules.size = dirns.size)
and (result.weights.size = wts.size)
is
--This is just a simple creation routine from the components read from
-- the repertoire map file.
me : SAME := new ;
me.domain := dom ;
me.base_weight := base ;
me.rules := dirns ;
me.weights := wts ;
return me
end ;
contains(code : TOKEN) : BOOL
pre ~void(self)and ~(code.card = 0)
post result = domain.contains(code.card)
is
--This routine returns true if and only if the given token is in
-- the domain of this ordering, otherwise false.
return domain.contains(code.card)
end ;
weights(code : TOKEN) : ARRAY{ORDER_WEIGHT}
pre ~void(self)
post (result.size = self.weights.size)
is
--This routine returns a new array of weights corresponding to the
-- given token tok.
res : ARRAY{ORDER_WEIGHT} := weights.copy ;
loop
index : CARD := 0.upto!(weights.asize - 1) ;
if res[index] = ORDER_WEIGHT::highest then
res[index] := ORDER_WEIGHT::create(base_weight.card + (code.card - domain.low))
end
end ;
return res
end ;
end ; -- RANGE_ORDERING
class ORDERING
class ORDERING is
-- This class implements an order weighting look-up 'table' for a single
-- script (as specified in ISO/IEC 14652) needed when attempting to order
-- a text string according to the rules given in ISO/IEC 14651.
-- Version 1.1 Jul 97. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 11 Jul 97 kh Original
-- 15 Jul 97 kh Incorporated range orders in the script.
readonly attr rule : ARRAY{ORDER_RULE} ;
private attr table : FMAP{TOKEN,ARRAY{ORDER_WEIGHT}} ;
private attr range_list : FLIST{RANGE_ORDERING} ;
create : SAME
pre true
post (result.rule[0] = ORDER_RULE::create(true,false))
is
--This routine creates an empty ordering object with a default single
-- rule of forward into which entries may be inserted.
me : SAME := new ;
me.rule := ARRAY{ORDER_RULE}::create(1) ;
me.rule[0] := ORDER_RULE::create(true,false) ;
me.table := FMAP{TOKEN,ARRAY{ORDER_WEIGHT}}::create ;
me.range_list := FLIST{RANGE_ORDERING}::create ;
return me
end ;
create(rules : ARRAY{ORDER_RULE}) : SAME
pre ~void(rules)
post ~void(result)
is
--This routine creates an empty ordering object with the given ordering
-- rule into which entries may later be inserted.
me : SAME := new ;
me.rule := ARRAY{ORDER_RULE}::create(rules.asize) ;
loop
index : CARD := 0.upto!(rules.asize - 1) ;
me.rule[index] := rules.elt!
end ;
me.table := FMAP{TOKEN,ARRAY{ORDER_WEIGHT}}::create ;
me.range_list := FLIST{RANGE_ORDERING}::create ;
return me
end ;
size : CARD
pre true
post result = table.size
is
--This routine returns the number of entries in the map.
return table.size
end ;
insert(tok : TOKEN,wts : ARRAY{ORDER_WEIGHT}) : BOOL
pre ~(tok.card = 0)and ~void(wts)
post (result = table.test(tok)) or ~result
is
--This routine returns true only if it has been determined that tok
-- is not already in the table and that (except for the first entry) all
-- weight arrays are of the same length.
if table.size = 0 then
table := table.insert(tok,wts) ;
return true
elsif table.test(tok) then
return false
else
loc_wts : ARRAY{ORDER_WEIGHT} ;
loop -- just need one array for testing
loc_wts := table.elt! ;
break!
end ;
if loc_wts.asize /= wts.asize then -- must be same number!
return false
end ;
table := table.insert(tok,wts) ;
return true
end
end ;
insert(order : RANGE_ORDERING) : BOOL
pre ~void(order)
post (initial(void(range_list))
and (result = (range_list.size = 1)))
or (initial(range_list.size) + 1 = range_list.size)
is
--This routine permits the insertion of a range order specified as
-- part of the script ordering specification. True is always returned
-- for consistency with the insertion routine above.
if void(range_list) then
range_list := FLIST{RANGE_ORDERING}::create
end ;
range_list := range_list.push(order) ;
return true
end ;
private from_range(tok : TOKEN) : ARRAY{ORDER_WEIGHT}
pre ~void(self)and ~(tok.card = 0)
post true
is
--This routine checks the ranges associated with this script. If the
-- token is in one of them then the corresponding weights are returned,
-- otherwise void!
loop
order : RANGE_ORDERING := range_list.elt! ;
if order.contains(tok) then
return order.weights(tok)
end
end ;
return void
end ;
contains(tok_list : FLIST{TOKEN}) : BOOL
pre ~void(self)and ~void(tok_list)
post true
is
--This routine returns true if and only if any ONE token in the list is
-- in the map of this group, otherwise false.
tok : TOKEN ;
loop
tok := tok_list.elt! ;
if (table.test(tok)
or ~void(from_range(tok))) then
return true
end
end ;
return false
end ;
weights(tok_list : FLIST{TOKEN}) : ARRAY{ORDER_WEIGHT}
pre contains(tok_list)
post ~void(result)
is
--This is the routine which returns a new copy of the list of weights
-- for the most recently pushed token in the list (which is really a set of
-- homonymous tokens) which has a set of weights.
loc_list : FLIST{TOKEN} := tok_list.copy ;
loop
loc_list.size.times! ;
tok : TOKEN := loc_list.pop ;
if table.test(tok) then
return table.get(tok).copy
end
end ;
loc_list := tok_list.copy ;
loop -- check for range orders
loc_list.size.times! ;
tok : TOKEN := loc_list.pop ;
loc_res : ARRAY{ORDER_WEIGHT} := from_range(tok) ;
if ~void(loc_res) then
return loc_res.copy
end
end ;
return void
end ;
end ; -- ORDERING