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 >
Text File  |  1989-12-21  |  4KB  |  109 lines
  1. \
  2. \  RANGE DEFINITIONS
  3. \
  4. \  Copyright (c) 1989 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 17 December 1989
  17. \
  18. \  Dependencies:
  19. \       (forth) structures, blocks
  20. \
  21. \  Description:
  22. \       Allows definition of intervals and basic functions from these.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. .( Loading Range definitions...) cr
  40.  
  41. #include structures.f83
  42. #include blocks.f83
  43.  
  44. vocabulary ranges
  45.  
  46. blocks structures ranges definitions
  47.  
  48. struct.type RANGE ( from to -- )
  49.   long +from private                   ( From value of range)
  50.   long +to private                     ( To value of range)
  51. struct.init ( from to range -- )
  52.   swap over +to ! +from !              ( Initiate range; to and from values)
  53. struct.end
  54.  
  55. : ?empty ( range -- flag)
  56.   dup +from @ swap +to @ = ;           ( Check the to- and from-value)
  57.  
  58. : ?member ( value range -- boolean)
  59.   dup +from @ swap +to @ ?within ;     ( Check if the value is within range)
  60.  
  61. : ?intersection ( x y -- flag)
  62.   over +to @ over +from @ < >r         ( Check the relationship between)
  63.   +to @ swap +from @ < r> or not ;     ( the to- and from-values)
  64.  
  65. : length ( range -- length)
  66.   dup ?empty                           ( Check if empty)
  67.   if drop 0                            ( Then return zero)
  68.   else
  69.     dup +to @ swap +from @ - 1+                ( Else calculate size of range)
  70.   then ;
  71.  
  72. : union ( x y -- from to)
  73.   over +to @ over +to @ max >r         ( Take max of the to-values)
  74.   +from @ swap +from @ min r> ;                ( And min of the from-values)
  75.  
  76. : intersection ( x y -- from to)
  77.   over over ?intersection              ( Check if there exists an intersection)
  78.   if over +to @ over +to @ min >r      ( Then take min of the to-values)
  79.     +from @ swap +from @ max r>                ( And max of the from-values)
  80.   else
  81.     drop drop 0 0                      ( Else return an empty range)
  82.   then ;
  83.  
  84. : map ( range block[index -- ] -- )
  85.   swap dup +to @ 1+ swap +from @       ( Access range intervals; to and from)
  86.   do                                   ( Loop and call the block)
  87.     i swap dup >r call r>              ( on each value in the interval)
  88.   loop
  89.   drop ;                               ( Drop function)
  90.  
  91. : ?map ( range block[index -- flag] -- )
  92.   swap dup +to @ 1+ swap +from @       ( Access range intervals; to and from)
  93.   do                                   ( Loop and call the block)
  94.     i swap dup >r call r> swap         ( on each value in the interval)
  95.     if leave then                      ( Leave the iteration if return is true)
  96.   loop
  97.   drop ;                               ( Drop function)
  98.  
  99. : print ( range -- )
  100.   block[ . ]; map ;                    ( Print each index in range)
  101.  
  102. : .range ( range -- )
  103.   ." range#" dup .                     ( Print address of range structure )
  104.   ." from: " dup +from @ .             ( Print range intervals )
  105.   ." to: " +to @ . ;
  106.  
  107. forth only
  108.  
  109.