home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
rtsi.com
/
2014.01.www.rtsi.com.tar
/
www.rtsi.com
/
OS9
/
OSK
/
EFFO
/
pd6.lzh
/
LIB
/
TILE
/
ranges.f83
< prev
next >
Wrap
Text File
|
1989-12-21
|
4KB
|
109 lines
\
\ RANGE DEFINITIONS
\
\ Copyright (c) 1989 by Mikael R.K. Patel
\
\ Computer Aided Design Laboratory (CADLAB)
\ Department of Computer and Information Science
\ Linkoping University
\ S-581 83 LINKOPING
\ SWEDEN
\
\ Email: mip@ida.liu.se
\
\ Started on: 30 June 1988
\
\ Last updated on: 17 December 1989
\
\ Dependencies:
\ (forth) structures, blocks
\
\ Description:
\ Allows definition of intervals and basic functions from these.
\
\ Copying:
\ This program is free software; you can redistribute it and\or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 1, or (at your option)
\ any later version.
\
\ This program 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 the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with this program; see the file COPYING. If not, write to
\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
.( Loading Range definitions...) cr
#include structures.f83
#include blocks.f83
vocabulary ranges
blocks structures ranges definitions
struct.type RANGE ( from to -- )
long +from private ( From value of range)
long +to private ( To value of range)
struct.init ( from to range -- )
swap over +to ! +from ! ( Initiate range; to and from values)
struct.end
: ?empty ( range -- flag)
dup +from @ swap +to @ = ; ( Check the to- and from-value)
: ?member ( value range -- boolean)
dup +from @ swap +to @ ?within ; ( Check if the value is within range)
: ?intersection ( x y -- flag)
over +to @ over +from @ < >r ( Check the relationship between)
+to @ swap +from @ < r> or not ; ( the to- and from-values)
: length ( range -- length)
dup ?empty ( Check if empty)
if drop 0 ( Then return zero)
else
dup +to @ swap +from @ - 1+ ( Else calculate size of range)
then ;
: union ( x y -- from to)
over +to @ over +to @ max >r ( Take max of the to-values)
+from @ swap +from @ min r> ; ( And min of the from-values)
: intersection ( x y -- from to)
over over ?intersection ( Check if there exists an intersection)
if over +to @ over +to @ min >r ( Then take min of the to-values)
+from @ swap +from @ max r> ( And max of the from-values)
else
drop drop 0 0 ( Else return an empty range)
then ;
: map ( range block[index -- ] -- )
swap dup +to @ 1+ swap +from @ ( Access range intervals; to and from)
do ( Loop and call the block)
i swap dup >r call r> ( on each value in the interval)
loop
drop ; ( Drop function)
: ?map ( range block[index -- flag] -- )
swap dup +to @ 1+ swap +from @ ( Access range intervals; to and from)
do ( Loop and call the block)
i swap dup >r call r> swap ( on each value in the interval)
if leave then ( Leave the iteration if return is true)
loop
drop ; ( Drop function)
: print ( range -- )
block[ . ]; map ; ( Print each index in range)
: .range ( range -- )
." range#" dup . ( Print address of range structure )
." from: " dup +from @ . ( Print range intervals )
." to: " +to @ . ;
forth only