Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/BIPL.ZIP/PROCS.ZIP/LSCAN.ICN

Text File | 1992-09-28 | 14.3 KB | 547 lines

############################################################################
#
#    File:     lscan.icn
#
#    Subject:  Procedures for quasi scanning routines for lists
#
#    Author:   Richard L. Goerwitz
#
#    Date:     June 3, 1991
#
###########################################################################
#
#    Version:  1.20
#
###########################################################################
#
#  Purpose: String scanning is terrific, but often I am forced to
#  tokenize and work with lists.  So as to make operations on these
#  lists as close to corresponding string operations as possible, I've
#  implemented a series of list analogues to any(), bal(), find(),
#  many(), match(), move(), pos(), tab(), and upto().  Their names are
#  just like corresponding string functions, except with a prepended
#  "l_" (e.g. l_any()).  Functionally, the list routines parallel the
#  string ones closely, except that in place of strings, l_find and
#  l_match accept lists as their first argument.  L_any(), l_many(),
#  and l_upto() all take either sets of lists or lists of lists (e.g.
#  l_tab(l_upto([["a"],["b"],["j","u","n","k"]])).  Note that l_bal(),
#  unlike the builtin bal(), has no defaults for the first four
#  arguments.  This just seemed appropriate, given that no precise
#  list analogue to &cset, etc. occurs.
#
#  The default subject for list scans (analogous to &subject) is
#  l_SUBJ.  The equivalent of &pos is l_POS.  Naturally, these
#  variables are both global.  They are used pretty much like &subject
#  and &pos, except that they are null until a list scanning
#  expression has been encountered containing a call to l_Bscan() (on
#  which, see below).
#
#  Note that environments cannot be maintained quite as elegantly as
#  they can be for the builtin string-scanning functions.  One must
#  use instead a set of nested procedure calls, as explained in the
#  _Icon Analyst_ 1:6 (June, 1991), p. 1-2.  In particular, one cannot
#  suspend, return, or otherwise break out of the nested procedure
#  calls.  They can only be exited via failure.  The names of these
#  procedures, at least in this implementation, are l_Escan and
#  l_Bscan.  Here is one example of how they might be invoked:
#
#      suspend l_Escan(l_Bscan(some_list_or_other), {
#          l_tab(10 to *l_SUBJ) & {
#              if l_any(l1) | l_match(l2) then
#                  old_l_POS + (l_POS-1)
#          }
#      })
#
#  Note that you cannot do this:
#
#      l_Escan(l_Bscan(some_list_or_other), {
#          l_tab(10 to *l_SUBJ) & {
#              if l_any(l1) | l_match(l2) then
#                  suspend old_l_POS + (l_POS-1)
#          }
#      })
#
#  Remember, it's no fair to use suspend within the list scanning
#  expression.  l_Escan must do all the suspending.  It is perfectly OK,
#  though, to nest well-behaved list scanning expressions.  And they can
#  be reliably used to generate a series of results as well.
#
############################################################################
#
#  Here's another simple example of how one might invoke the l_scan
#  routines:
#
#  procedure main()
#
#      l := ["h","e","l","l","o"," ","t","t","t","h","e","r","e"]
#
#      l_Escan(l_Bscan(l), {
#          hello_list := l_tab(l_match(["h","e","l","l","o"]))
#          every writes(!hello_list)
#          write()
#
#          # Note the nested list-scanning expressions.
#       l_Escan(l_Bscan(l_tab(0)), {
#           l_tab(l_many([[" "],["t"]]) - 1)
#              every writes(!l_tab(0))
#           write()
#          })
#      })
#
#  end
#
#  The above program simply writes "hello" and "there" on successive
#  lines to the standard output.
#
############################################################################
#
#  PITFALLS: In general, note that we are comparing lists here instead
#  of strings, so l_find("h", l), for instance, will yield an error
#  message (use l_find(["h"], l) instead).  The point at which I
#  expect this nuance will be most confusing will be in cases where
#  one is looking for lists within lists.  Suppose we have a list,
#
#      l1 := ["junk",[["hello"]," ",["there"]],"!","m","o","r","e","junk"]
#
#  and suppose, moreover, that we wish to find the position in l1 at
#  which the list
#
#      [["hello"]," ",["there"]]
#
#  occurs.  If, say, we assign [["hello"]," ",["there"]] to the
#  variable l2, then our l_find() expression will need to look like
#
#      l_find([l2],l1)
#
############################################################################
#
#  Extending scanning to lists is really very difficult.  What I think
#  (at least tonight) is that scanning should never have been
#  restricted to strings.  It should have been designed to operate on
#  all homogenous one-dimensional arrays (vectors, for you LISPers).
#  You should be able, in other words, to scan vectors of ints, longs,
#  characters - any data type that seems useful.  The only question in
#  my mind is how to represent vectors as literals.  Extending strings
#  to lists goes beyond the bounds of scanning per-se.  This library is
#  therefore something of a stab in the dark.
#
############################################################################


global l_POS
global l_SUBJ
record l_ScanEnvir(subject,pos)

procedure l_Bscan(e1)

    #
    # Prototype list scan initializer.  Based on code published in
    # the _Icon Analyst_ 1:6 (June, 1991), p. 1-2.
    #
    local l_OuterEnvir
    initial {
    l_SUBJ := []
    l_POS := 1
    }

    #
    # Save outer scanning environment.
    #
    l_OuterEnvir := l_ScanEnvir(l_SUBJ, l_POS)

    #
    # Set current scanning environment to subject e1 (arg 1).  Pos
    # defaults to 1.  Suspend the saved environment.  Later on, the
    # l_Escan procedure will need this in case the scanning expres-
    # sion as a whole sends a result back to the outer environment,
    # and the outer environment changes l_SUBJ and l_POS.
    #
    l_SUBJ := e1
    l_POS  := 1
    suspend l_OuterEnvir

    #
    # Restore the saved environment (plus any changes that might have
    # been made to it as noted in the previous run of comments).
    #
    l_SUBJ := l_OuterEnvir.subject
    l_POS := l_OuterEnvir.pos

    #
    # Signal failure of the scanning expression (we're done producing
    # results if we get to here).
    #
    fail

end



procedure l_Escan(l_OuterEnvir, e2)

    local l_InnerEnvir

    #
    # Set the inner scanning environment to the values assigned to it
    # by l_Bscan.  Remember that l_SUBJ and l_POS are global.  They
    # don't need to be passed as parameters from l_Bscan.  What
    # l_Bscan() needs to pass on is the l_OuterEnvir record,
    # containing the values of l_SUBJ and l_POS before l_Bscan() was
    # called.  l_Escan receives this "outer environment" as its first
    # argument, l_OuterEnvir.
    #
    l_InnerEnvir := l_ScanEnvir(l_SUBJ, l_POS)

    #
    # Whatever expression produced e2 has passed us a result.  Now we
    # restore l_SUBJ and l_POS, and send that result back to the outer
    # environment.
    #
    l_SUBJ := l_OuterEnvir.subject
    l_POS := l_OuterEnvir.pos
    suspend e2

    #
    # Okay, we've resumed to (attempt to) produce another result.  Re-
    # store the inner scanning environment (the one we're using in the
    # current scanning expression).  Remember?  It was saved in l_Inner-
    # Envir just above.
    #
    l_SUBJ := l_InnerEnvir.subject
    l_POS := l_InnerEnvir.pos

    #
    # Fail so that the second argument (the one that produced e2) gets
    # resumed.  If it fails to produce another result, then the first
    # argument is resumed, which is l_Bscan().  If l_Bscan is resumed, it
    # will restore the outer environment and fail, causing the entire
    # scanning expression to fail.
    #
    fail

end



procedure l_move(i)

    /i & stop("l_move:  Null argument.")
    if /l_POS | /l_SUBJ then
    stop("l_move:  Call l_Bscan() first.")

    #
    # Sets l_POS to l_POS+i; suspends that portion of l_SUBJ extending
    # from the old l_POS to the new one.  Resets l_POS if resumed,
    # just the way matching procedures are supposed to.  Fails if l_POS
    # plus i is larger than l_SUBJ+1 or if l_POS+i is less than 1.
    #
    suspend l_SUBJ[.l_POS:l_POS <- (0 < (*l_SUBJ+1 >= l_POS+i))]

end



procedure l_tab(i)

    /i & stop("l_tab:  Null argument.")
    if /l_POS | /l_SUBJ then
    stop("l_tab:  Call l_Bscan() first.")

    if i <= 0
    then suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i)]
    else suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= i)]

end



procedure l_any(l1,l2,i,j)

    #
    # Like any(c,s2,i,j) except that the string & cset arguments are
    # replaced by list arguments.  l1 must be a list of one-element
    # lists, while l2 can be any list (l_SUBJ by default).
    #

    local sub_l, x

    /l1 & stop("l_any:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)

    /l2 := l_SUBJ
    if \i then {
    if i < 1 then
        i := *l2 + (i+1)
    }
    else i := \l_POS | 1
    if \j then {
    if j < 1 then
        j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    (i+1) > j & i :=: j
    every sub_l := !l1 do {
    if not (type(sub_l) == "list", *sub_l = 1) then
        stop("l_any:  Elements of l1 must be lists of length 1.")
    # Let l_match check to see if i+1 is out of range.
    if x := l_match(sub_l,l2,i,i+1) then
        return x
    }

end



procedure l_match(l1,l2,i,j)

    #
    # Analogous to match(s1,s2,i,j), except that s1 and s2 are lists,
    # and l_match returns the next position in l2 after that portion
    # (if any) which is structurally identical to l1.  If a match is not
    # found, l_match fails.
    #

    if /l1
    then stop("l_match:  Null first argument!")
    if type(l1) ~== "list"
    then stop("l_match:  Call me with a list as the first arg.")

    /l2 := l_SUBJ
    if \i then {
    if i < 1 then
        i := *l2 + (i+1)
    }
    else i := \l_POS | 1

    if \j then {
    if j < 1 then
        j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    i + *l1 > j & i :=: j
    i + *l1 > j & fail
    if l_comp(l1,l2[i+:*l1]) then
    return i + *l1

end



procedure l_comp(l1,l2)

    #
    # List comparison routine basically taken from Griswold & Griswold
    # (1st ed.), p. 174.
    #

    local i

    /l1 | /l2 & stop("l_comp:  Null argument!")
    l1 === l2 & (return l2)

    if type(l1) == type(l2) == "list" then {
    *l1 ~= *l2 & fail
    every i := 1 to *l1
    do l_comp(l1[i],l2[i]) | fail
    return l2
    }

end



procedure l_find(l1,l2,i,j)

    #
    # Like the builtin find(s1,s2,i,j), but for lists.
    #

    local x, old_l_POS

    /l1 & stop("l_find:  Null first argument!")

    /l2 := l_SUBJ
    if \i then {
    if i < 1 then
        i := *l2 + (i+1)
    }
    else i := \l_POS | 1
    if \j then {
    if j < 1 then
        j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    #
    # See l_upto() below for a discussion of why things have to be done
    # in this manner.
    #
    old_l_POS := l_POS

    suspend l_Escan(l_Bscan(l2[i:j]), {
    l_tab(1 to *l_SUBJ) & {
        if l_match(l1) then
        old_l_POS + (l_POS-1)
    }
    })

end



procedure l_upto(l1,l2,i,j)

    #
    # See l_any() above.  This procedure just moves through l2, calling
    # l_any() for each member of l2[i:j].
    #

    local old_l_POS

    /l1 & stop("l_upto:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)

    /l2 := l_SUBJ
    if \i then {
    if i < 1 then
        i := *l2 + (i+1)
    }
    else i := \l_POS | 1
    if \j then {
    if j < 1 then
        j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    #
    # Save the old pos, then try arb()ing through the list to see if we
    # can do an l_any(l1) at any position.
    #
    old_l_POS := l_POS

    suspend l_Escan(l_Bscan(l2[i:j]), {
    l_tab(1 to *l_SUBJ) & {
        if l_any(l1) then
        old_l_POS + (l_POS-1)
    }
    })

    #
    # Note that it WILL NOT WORK if you say:
    #
    # l_Escan(l_Bscan(l2[i:j]), {
    #     l_tab(1 to *l_SUBJ) & {
    #         if l_any(l1) then
    #             suspend old_l_POS + (l_POS-1)
    #     }
    # })
    #
    # If we are to suspend a result, l_Escan must suspend that result.
    # Otherwise scanning environments are not saved and/or restored
    # properly.
    #

end



procedure l_many(l1,l2,i,j)

    local x, old_l_POS

    /l1 & stop("l_many:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)

    /l2 := l_SUBJ
    if \i then {
    if i < 1 then
        i := *l2 + (i+1)
    }
    else i := \l_POS | 1
    if \j then {
    if j < 1 then
        j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    #
    # L_many(), like many(), is not a generator.  We can therefore
    # save one final result in x, and then later return (rather than
    # suspend) that result.
    #
    old_l_POS := l_POS
    l_Escan(l_Bscan(l2[i:j]), {
    while l_tab(l_any(l1))
    x := old_l_POS + (l_POS-1)
    })

    #
    # Fails if there was no positional change (i.e. l_any() did not
    # succeed even once).
    #
    return old_l_POS ~= x

end



procedure l_pos(i)

    local x

    if /l_POS | /l_SUBJ
    then stop("l_move:  Call l_Bscan() first.")

    if i <= 0
    then x := 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i) | fail
    else x := 0 < (*l_SUBJ+1 >= i) | fail

    if x = l_POS
    then return x
    else fail

end



procedure l_bal(l1,l2,l3,l,i,j)

    local l2_count, l3_count, x, position

    /l1 & stop("l_bal:  Null first argument!")
    if type(l1) == "set" then l1 := sort(l1)  # convert to a list
    if type(l2) == "set" then l1 := sort(l2)
    if type(l3) == "set" then l1 := sort(l3)

    /l2 := l_SUBJ
    if \i then {
    if i < 1 then
        i := *l2 + (i+1)
    }
    else i := \l_POS | 1
    if \j then {
    if j < 1 then
        j := *l2 + (j+1)
    }
    else j := *l_SUBJ+1

    l2_count := l3_count := 0

    every x := i to j-1 do {

    if l_any(l2, l, x, x+1) then {
        l2_count +:= 1
    }
    if l_any(l3, l, x, x+1) then {
        l3_count +:= 1
    }
    if l2_count = l3_count then {
        if l_any(l1,l,x,x+1)
        then suspend x
    }
    }

end