Changeset 36572 in project


Ignore:
Timestamp:
09/09/18 20:03:22 (13 days ago)
Author:
kon
Message:

fix dir, split

Location:
release/5/fx-utils/trunk
Files:
3 edited
1 moved

Legend:

Unmodified
Added
Removed
  • release/5/fx-utils/trunk/fx-utils.scm

    r35994 r36572  
    1 ;;;; fx-utils.scm
     1;;;; fx-utils.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23;;;; 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 chicken foreign)
    32 (use
    33   (only extras random))
    34 
    35 ;;;
    36 
    37 ;;
    384
    395#>
     
    439{
    4410static const C_uword
     11# define LT( n )  n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
    4512  LogTable256[] = { /* 16 x 16 */
    46 # define LT( n )  n, n, n, n, n, n, n, n, n, n, n, n, n, n, n, n
    4713    -1, 0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3,
    4814    LT( 4 ),
     
    5016    LT( 6 ), LT( 6 ), LT( 6 ), LT( 6 ),
    5117    LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 ), LT( 7 )
     18  };
    5219# undef LT
    53   };
    5420
    5521# define rem( i, c )  ((i) >> (c))
    56 # define log( i ) (LogTable256[ (i) & 0xff ])
     22# define log( i )     (LogTable256[ (i) & 0xff ])
    5723
    5824  C_uword r;
     
    8248<#
    8349
    84 (define C_uword_log2
    85   (foreign-lambda long C_uword_log2 unsigned-long))
     50(module fx-utils
     51
     52(;export
     53  ;
     54  fxrandom
     55  fxlog2
     56  fxpow2log2
     57  ;
     58  fxdistance fxdistance*
     59  ;
     60  fxquo-and-mod
     61  fxmax-and-min)
     62
     63(import scheme
     64  (chicken base)
     65  (chicken fixnum)
     66  (chicken foreign)
     67  (chicken type))
     68
     69;;;
     70
     71(include "fx-inlines")  ;(chicken base) 7 not scheme?
     72
     73;;;
     74
     75(: C_uword_log2 (number --> number))
     76;
     77(define C_uword_log2 (foreign-lambda long C_uword_log2 unsigned-long))
    8678
    8779;;
    8880
    89 (: *fxrandom (fixnum --> fixnum))
     81(: *fxrandom (fixnum -> fixnum))
    9082;
    91 (define (*fxrandom x)
    92   (random x)
    93   #;
    94   (##core#inline "C_random_fixnum" x) )
    95 
    96 (: *fxadd1 (fixnum --> fixnum))
    97 ;
    98 (define (*fxadd1 x)
    99   (fx+ x 1)
    100   #;
    101   (##core#inline "C_fixnum_increase" x) )
    102 
    103 (: *fxsub1 (fixnum --> fixnum))
    104 ;
    105 (define (*fxsub1 x)
    106   (fx- x 1)
    107   #;
    108   (##core#inline "C_fixnum_decrease" x) )
     83(define-inline (*fxrandom x) (##core#inline "C_random_fixnum" x))
    10984
    11085#|
    111 (: *pow2log2 (fixnum --> fixnum))
     86(: C_pow2log2 (number --> number))
    11287;
    113 (define *pow2log2
     88(define C_pow2log2
    11489  (foreign-lambda* unsigned-long ((long n))
    115    "return( 2 << C_uword_log2( (C_uword) n ) );"))
     90   "if( 0 == n ) return( -1 );
     91   if( 1 == n ) return( 2 );
     92   return( 2 << C_uword_log2( (C_uword) (n - 1) ) );"))
    11693|#
    117 
    118 ;;;
    11994
    12095;;
    12196
    122 (: fxrandom (#!optional fixnum -> fixnum))
     97(: fxrandom (#!optional fixnum fixnum -> fixnum))
    12398;
    124 (define (fxrandom #!optional lim (low 0))
    125   (let* (
    126     (lim (if (not lim) most-positive-fixnum lim))
    127     (dif (fx- lim low))
    128     (rnd (*fxrandom dif))
    129     (rnd (fx+ low rnd)) )
    130     rnd ) )
    131 
    132 ;;
    133 
    134 (: fxzero? (fixnum --> boolean))
    135 ;
    136 (define (fxzero? n)
    137   (fx= 0 n) )
    138 
    139 (: fxpositive? (fixnum --> boolean))
    140 ;
    141 (define (fxpositive? n)
    142   (fx< 0 n) )
    143 
    144 (: fxcardinal? (fixnum --> boolean))
    145 ;
    146 (define (fxcardinal? n)
    147   (fx<= 0 n) )
    148 
    149 (: fxnegative? (fixnum --> boolean))
    150 ;
    151 (define (fxnegative? n)
    152   (fx> 0 n) )
    153 
    154 (: fxnon-positive? (fixnum --> boolean))
    155 ;
    156 (define (fxnon-positive? n)
    157   (fx>= 0 n) )
    158 
    159 ;;
    160 
    161 (: fxclosed-right? (fixnum fixnum fixnum --> boolean))
    162 ;
    163 (define (fxclosed-right? l x h)
    164   (and (fx< l x) (fx<= x h)) )
    165 
    166 (: fxclosed? (fixnum fixnum fixnum --> boolean))
    167 ;
    168 (define (fxclosed? l x h)
    169   (and (fx<= l x) (fx<= x h)) )
    170 
    171 (: fxclosed-left? (fixnum fixnum fixnum --> boolean))
    172 ;
    173 (define (fxclosed-left? l x h)
    174   (and (fx<= l x) (fx< x h)) )
    175 
    176 (define fxclosedr? fxclosed-right?)
    177 (define fxclosedl? fxclosed-left?)
    178 
    179 ;;;
    180 
    181 ;;
    182 
    183 (: fxabs (fixnum --> fixnum))
    184 ;
    185 (define (fxabs n)
    186   (if (fxnegative? n) (fxneg n) n) )
    187 
    188 ;;
    189 
    190 (: fxadd1 (fixnum --> fixnum))
    191 ;
    192 (define (fxadd1 n)
    193   (*fxadd1 n) )
    194 
    195 (: fxsub1 (fixnum --> fixnum))
    196 ;
    197 (define (fxsub1 n)
    198   (*fxsub1 n) )
     99(define (fxrandom #!optional (lim most-positive-fixnum) (low 0))
     100  (fx+ low (*fxrandom (fx- lim low))) )
    199101
    200102;;
     
    202104(: fxlog2 (fixnum --> fixnum))
    203105;
    204 (define (fxlog2 n)
    205   (C_uword_log2 n) )
     106(define (fxlog2 n) (C_uword_log2 n))
    206107
    207108(: fxpow2log2 (fixnum --> fixnum))
     
    209110(define (fxpow2log2 n)
    210111  (cond
    211     ((fxzero? n)
    212       -1 )
    213     ((fx= 1 n)
    214       2 )
    215     (else
    216       (fxshl 2 (fxlog2 (fxsub1 n))) ) ) )
    217 
    218 (: fxsqr (fixnum --> fixnum))
    219 ;
    220 (define (fxsqr n)
    221   (fx* n n) )
    222 
    223 (: fxcub (fixnum --> fixnum))
    224 ;
    225 (define (fxcub n)
    226   (fx* n (fx* n n)) )
     112    ((fxzero? n)  -1)
     113    ((fx= 1 n)    2)
     114    (else         (fxshl 2 (fxlog2 (fxsub1 n)))) ) )
    227115
    228116;;
    229117
     118(: fxdistance* (fixnum fixnum fixnum fixnum --> fixnum))
     119;
     120(define (fxdistance* x1 y1 x2 y2) (fx+ (fxsqr (fx- x1 x2)) (fxsqr (fx- y1 y2))))
     121
    230122(: fxdistance (fixnum fixnum fixnum fixnum --> fixnum))
    231123;
    232 (define (fxdistance x1 y1 x2 y2)
    233   (fx/ (fxdistance* x1 y1 x2 y2) 2) )
     124(define (fxdistance x1 y1 x2 y2) (fx/ (fxdistance* x1 y1 x2 y2) 2))
    234125
    235 (: fxdistance* (fixnum fixnum fixnum fixnum --> fixnum))
     126;;
     127
     128(: fxquo-and-mod (fixnum fixnum --> fixnum fixnum))
    236129;
    237 (define (fxdistance* x1 y1 x2 y2)
    238   (fx+ (fxsqr (fx- x1 x2)) (fxsqr (fx- y1 y2))) )
     130(define (fxquo-and-mod fxn fxd) (values (fx/ fxn fxd) (fxmod fxn fxd)))
    239131
    240132;;
  • release/5/fx-utils/trunk/test/fx-utils-test.scm

    r35994 r36572  
    1 ;;;; mathh-test
    2 ;;;; Kon Lovett, May '17
     1;;;; fx-utils-test  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    33
    4 ;;;; Issues
    5 ;;;;
     4(import test)
    65
    7 (require-extension test)
     6(test-begin "Fx Utils")
    87
    98;;;
    109
    11 ;;;
     10(import (chicken base) (chicken fixnum))
    1211
    13 (require-extension fx-utils)
     12(include "fx-inlines")
    1413
    15 (test-group "FX Utils"
     14(test-group "Fx Inlines"
    1615
    1716  (test-assert (fxzero? 0))
     
    2423  (test-assert (fxpositive? most-positive-fixnum))
    2524
    26   (test-assert (fxcardinal? 0))
    27   (test-assert (not (fxcardinal? most-negative-fixnum)))
    28   (test-assert (fxcardinal? most-positive-fixnum))
     25  (test-assert (fxnatural? 0))
     26  (test-assert (not (fxnatural? most-negative-fixnum)))
     27  (test-assert (fxnatural? most-positive-fixnum))
    2928
    3029  (test-assert (not (fxnegative? 0)))
     
    3231  (test-assert (not (fxnegative? most-positive-fixnum)))
    3332
    34         (test-assert (fixnum? (fxrandom)))
    35         (test-assert (fixnum? (fxrandom 2456)))
    36 
    3733        (test 4 (fxadd1 3))
    3834        (test 2 (fxsub1 3))
    3935
    4036        (test 27 (fxcub 3))
     37)
     38
     39(import fx-utils)
     40
     41(test-group "Fx Utils"
     42
     43        (test-assert (fixnum? (fxrandom)))
     44        (test-assert (fixnum? (fxrandom 2456)))
    4145
    4246        (test -1 (fxlog2 0))
     
    5862          (test "fxmax-and-min max" 16 mx)
    5963          (test "fxmax-and-min min" -16 mn) )
     64
     65        (receive (q m) (fxquo-and-mod 1 2)
     66          (test "fxquo-and-mod q" 0 q)
     67          (test "fxquo-and-mod m" 1 m) )
    6068)
    6169
    6270;;;
    6371
    64 (test-end "mathh")
    65 
    66 ;;;
     72(test-end "Fx Utils")
    6773
    6874(test-exit)
  • release/5/fx-utils/trunk/test/run.scm

    r35994 r36572  
    11
    2 (define EGG-NAME "mathh")
     2(define EGG-NAME "fx-utils")
    33
    44;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    55
    6 (use files)
     6(import
     7  (only (chicken pathname) make-pathname)
     8  (only (chicken process) system)
     9  (only (chicken process-context) argv)
     10  (only (chicken format) format))
     11
     12(define *args* (argv))
    713
    814;no -disable-interrupts
    9 (define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    10 
    11 (define *args* (argv))
     15(define *csc-options* "-inline-global \
     16  -specialize -optimize-leaf-routines -clustering -lfa2 \
     17  -local -inline \
     18  -no-trace -no-lambda-info \
     19  -unsafe")
    1220
    1321(define (test-name #!optional (eggnam EGG-NAME))
     
    2937(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    3038  (let ((tstnam (test-name eggnam)))
    31     (print "*** csi ***")
     39    (format #t "*** csi ***~%")
    3240    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
    3341    (newline)
    34     (print "*** csc (" cscopts ") ***")
     42    (format #t "*** csc ~s ***~%" cscopts)
    3543    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
    3644    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
Note: See TracChangeset for help on using the changeset viewer.