home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / tile-forth / rationals.f83 < prev    next >
Encoding:
Text File  |  1996-10-12  |  3.5 KB  |  173 lines
  1. \
  2. \  RATIONAL NUMBER MANAGEMENT
  3. \
  4. \  Copyright (C) 1990 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: 25 May 1990
  15. \
  16. \  Last updated on: 17 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, structures
  20. \
  21. \  Description:
  22. \       Management of a rational number system. Allows recognition of
  23. \       rational literals, calculation with rational numbers, and output.
  24. \       The rational number system includes representation of undefined,
  25. \       infinity and normalization of rational numbers towards zero.
  26. \
  27. \  Copying:
  28. \       This program is free software; you can redistribute it and\or modify
  29. \       it under the terms of the GNU General Public License as published by
  30. \       the Free Software Foundation; either version 1, or (at your option)
  31. \       any later version.
  32. \
  33. \       This program is distributed in the hope that it will be useful,
  34. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  35. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36. \       GNU General Public License for more details.
  37. \
  38. \       You should have received a copy of the GNU General Public License
  39. \       along with this program; see the file COPYING.  If not, write to
  40. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  41.  
  42. .( Loading Rational number definitions...) cr
  43.  
  44. #include structures.f83
  45.  
  46. vocabulary rationals ( -- )
  47.  
  48. structures rationals definitions
  49.  
  50. struct.type RATIONAL ( -- )
  51.   long +denom ( rational -- addr) private
  52.   long +num ( rational -- addr) private
  53. struct.end
  54.   
  55. : rational ( num denom -- )
  56.   create , ,
  57. does> ( rational -- num denom)
  58.   2@
  59. ;
  60.  
  61.  0 0 rational  undefined ( -- num denom)
  62.  0 1 rational  zero ( -- num denom)
  63.  1 0 rational  infinity ( -- num denom)
  64. -1 0 rational -infinity ( -- num denom)
  65.  
  66. : rnormalize ( num1 denom1 -- num2 denom2)
  67.   ?dup
  68.   if over 0=
  69.     if 2drop zero exit then
  70.     2dup
  71.     begin
  72.       ?dup
  73.     while
  74.       tuck mod
  75.     repeat
  76.     tuck / -rot / swap
  77.     dup 0<
  78.     if negate swap negate swap then
  79.   else
  80.     ?dup
  81.     if 0>
  82.       if infinity else -infinity then
  83.     else
  84.       undefined
  85.     then
  86.   then
  87. ;
  88.  
  89. : rnegate ( num1 denom1 -- num2 denom2)
  90.   swap negate swap
  91. ;
  92.  
  93. : r+ ( num1 denom1 num2 denom2 -- num3 denom3)
  94.   >r over r@ =
  95.   if nip + r>
  96.   else
  97.     over * rot r@ * + swap r> *
  98.   then
  99.   rnormalize
  100. ;
  101.  
  102. : r- ( num1 denom1 num2 denom2 -- num3 denom3)
  103.   rnegate r+ 
  104. ;
  105.  
  106. : r* ( num1 denom1 num2 denom2 -- num3 denom3)
  107.   >r rot * swap r> * rnormalize
  108. ;
  109.  
  110. : 1/r ( num1 denom1 -- num2 denom2)
  111.   swap rnormalize
  112. ;
  113.  
  114. : r/ ( num1 denom1 num2 denom2 -- num3 denom3)
  115.   swap r*
  116. ;
  117.  
  118. : r. ( num denom -- )
  119.   ?dup
  120.   if over 0=
  121.     if 2drop ." zero"
  122.     else
  123.       swap 0 .r ." /" 0 .r
  124.     then
  125.   else
  126.     ?dup
  127.     if 0>
  128.       if ." infinity" else ." -infinity" then
  129.     else
  130.       ." undefined"
  131.     then
  132.   then
  133.   space
  134. ;
  135.  
  136. : ?r= ( num1 denom1 num2 denom2 -- bool)
  137.   rot = -rot = and
  138. ;
  139.  
  140. : ?r> ( num1 denom1 num2 denom2 -- bool)
  141.   r- drop 0>
  142. ;
  143.  
  144. : ?r< ( num1 denom1 num2 denom2 -- bool)
  145.   r- drop 0<
  146. ;
  147.  
  148. : i>r ( x -- num denom)
  149.   1
  150. ;
  151.  
  152. : r>i ( num denom -- x)
  153.   /
  154. ;
  155.  
  156. : ?rational ( str -- [num denom true] or [str false])
  157.   >r 0 r@ dup c@ ascii - =
  158.   if 1+ convert swap negate swap
  159.   else convert then
  160.   dup c@ ascii / =
  161.   if 0 swap 1+ convert c@ 0=
  162.     if r> drop rnormalize compiling
  163.       if swap [compile] literal then
  164.       true exit
  165.     then
  166.   then
  167.   2drop r> false
  168. ; recognizer
  169.  
  170.  
  171. forth only
  172.  
  173.