source: project/release/4/mathh/tags/3.2.4/fx-utils.scm @ 34821

Last change on this file since 34821 was 34821, checked in by Kon Lovett, 3 years ago

rel 3.2.4

File size: 4.1 KB
Line 
1;;;; fx-utils.scm
2;;;; Kon Lovett, May '17
3
4;;;; Issues
5;;;;
6
7(module fx-utils
8
9(;export
10  ;
11  ;check-inexact
12  ;
13  fxrandom
14  ;
15  fxzero? fxpositive? fxcardinal? fxnegative? fxnon-positive?
16  ;
17  fxclosed-right? fxclosed? fxclosed-left? fxclosedr? fxclosedl?
18  ;
19  fxabs
20  ;
21  fxadd1 fxsub1
22  ;
23  fxsqr fxcub
24  fxlog2
25  fxpow2log2
26  ;
27  fxdistance fxdistance*
28  ;
29  fxmax-and-min)
30
31(import scheme)
32
33(import chicken foreign)
34
35(declare
36  (bound-to-procedure
37    ##sys#flonum-fraction
38    ##sys#check-inexact) )
39
40;;;
41
42;;
43
44#>
45/* Integer log2 - high bit set */
46static C_uword
47C_uword_log2( C_uword n )
48{
49static const C_uword
50  LogTable256[] = { /* 16 x 16 */
51# define LT( n )  n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
52    -1, 0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3,
53    LT( 4 ),
54    LT( 5 ), LT( 5 ),
55    LT( 6 ), LT( 6 ), LT( 6 ), LT( 6 ),
56    LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 )
57# undef LT
58  };
59
60# define rem( i, c )  ((i) >> (c))
61# define log( i ) (LogTable256[ (i) & 0xff ])
62
63  C_uword r;
64
65  C_uword tt, t;
66# ifdef C_SIXTY_FOUR
67  C_uword ttt;
68  if( (ttt = rem( n, 32 )) ) {
69    if( (tt = rem( ttt, 16 )) ) {
70      r = (t = rem( tt, 8 )) ? 56 + log( t ) : 48 + log( tt );
71    } else {
72      r = (t = rem( n, 8 )) ? 40 + log( t ) : 32 + log( n );
73    }
74  } else /*cont to 32-bit */
75# endif
76  if( (tt = rem( n, 16 )) ) {
77    r = (t = rem( tt, 8 )) ? 24 + log( t ) : 16 + log( tt );
78  } else {
79    r = (t = rem( n, 8 )) ? 8 + log( t ) : log( n );
80  }
81
82  C_return( r );
83
84# undef log
85# undef rem
86}
87<#
88
89(define C_uword_log2
90  (foreign-lambda long C_uword_log2 unsigned-long))
91
92;;
93
94(: *fxrandom (fixnum --> fixnum))
95(define (*fxrandom x)
96  (##core#inline "C_random_fixnum" x) )
97
98(: *fxadd1 (fixnum --> fixnum))
99(define (*fxadd1 fx)
100  (##core#inline "C_fixnum_increase" fx) )
101
102(: *fxsub1 (fixnum --> fixnum))
103(define (*fxsub1 fx)
104  (##core#inline "C_fixnum_decrease" fx) )
105
106#|
107(: *pow2log2 (fixnum --> fixnum))
108(define *pow2log2
109  (foreign-lambda* unsigned-long ((long n))
110   "return( 2 << C_uword_log2( (C_uword) n ) );"))
111|#
112
113;;;
114
115;;
116
117(: fxrandom (#!optional fixnum -> fixnum))
118(define (fxrandom #!optional (x most-positive-fixnum))
119  (*fxrandom x) )
120
121;;
122
123(: fxzero? (fixnum --> boolean))
124(define (fxzero? n)
125  (fx= 0 n) )
126
127(: fxpositive? (fixnum --> boolean))
128(define (fxpositive? n)
129  (fx< 0 n) )
130
131(: fxcardinal? (fixnum --> boolean))
132(define (fxcardinal? n)
133  (fx<= 0 n) )
134
135(: fxnegative? (fixnum --> boolean))
136(define (fxnegative? n)
137  (fx> 0 n) )
138
139(: fxnon-positive? (fixnum --> boolean))
140(define (fxnon-positive? n)
141  (fx>= 0 n) )
142
143;;
144
145(: fxclosed-right? (fixnum fixnum fixnum --> boolean))
146(define (fxclosed-right? l x h)
147  (and (fx< l x) (fx<= x h)) )
148
149(: fxclosed? (fixnum fixnum fixnum --> boolean))
150(define (fxclosed? l x h)
151  (and (fx<= l x) (fx<= x h)) )
152
153(: fxclosed-left? (fixnum fixnum fixnum --> boolean))
154(define (fxclosed-left? l x h)
155  (and (fx<= l x) (fx< x h)) )
156
157(define fxclosedr? fxclosed-right?)
158(define fxclosedl? fxclosed-left?)
159
160;;;
161
162;;
163
164(: fxabs (fixnum --> fixnum))
165(define (fxabs n)
166  (if (fxnegative? n) (fxneg n) n) )
167
168;;
169
170(: fxadd1 (fixnum --> fixnum))
171(define (fxadd1 n)
172  (*fxadd1 n) )
173
174(: fxsub1 (fixnum --> fixnum))
175(define (fxsub1 n)
176  (*fxsub1 n) )
177
178;;
179
180(: fxlog2 (fixnum --> fixnum))
181(define (fxlog2 n)
182  (C_uword_log2 n) )
183
184(: fxpow2log2 (fixnum --> fixnum))
185(define (fxpow2log2 n)
186  (cond
187    ((fxzero? n)
188      -1 )
189    ((fx= 1 n)
190      2 )
191    (else
192      (fxshl 2 (fxlog2 (fxsub1 n))) ) ) )
193
194(: fxsqr (fixnum --> fixnum))
195(define (fxsqr n)
196  (fx* n n) )
197
198(: fxcub (fixnum --> fixnum))
199(define (fxcub n)
200  (fx* n (fx* n n)) )
201
202;;
203
204(: fxdistance (fixnum fixnum fixnum fixnum --> fixnum))
205(define (fxdistance x1 y1 x2 y2)
206  (fx/ (fxdistance* x1 y1 x2 y2) 2) )
207
208(: fxdistance* (fixnum fixnum fixnum fixnum --> fixnum))
209(define (fxdistance* x1 y1 x2 y2)
210  (fx+ (fxsqr (fx- x1 x2)) (fxsqr (fx- y1 y2))) )
211
212;;
213
214(: fxmax-and-min (fixnum #!rest fixnum --> fixnum fixnum))
215(define (fxmax-and-min fx . fxs)
216  (let loop ((fxs fxs) (mx fx) (mn fx))
217    (if (null? fxs)
218      (values mx mn)
219      (let ((cur (car fxs)))
220        (loop (cdr fxs) (fxmax mx cur) (fxmin mn cur)) ) ) ) )
221
222) ;fx-utils
Note: See TracBrowser for help on using the repository browser.