ext.c (4910B)
1 /* 02dec06abu 2 * (c) Software Lab. Alexander Burger 3 */ 4 5 #include "../pico.h" 6 7 /*** Soundex Algorithm ***/ 8 static int SnxTab[] = { 9 '0', '1', '2', '3', '4', '5', '6', '7', // 48 10 '8', '9', 0, 0, 0, 0, 0, 0, 11 0, 0, 'F', 'S', 'T', 0, 'F', 'S', // 64 12 0, 0, 'S', 'S', 'L', 'N', 'N', 0, 13 'F', 'S', 'R', 'S', 'T', 0, 'F', 'F', 14 'S', 0, 'S', 0, 0, 0, 0, 0, 15 0, 0, 'F', 'S', 'T', 0, 'F', 'S', // 96 16 0, 0, 'S', 'S', 'L', 'N', 'N', 0, 17 'F', 'S', 'R', 'S', 'T', 0, 'F', 'F', 18 'S', 0, 'S', 0, 0, 0, 0, 0, 19 0, 0, 0, 0, 0, 0, 0, 0, // 128 20 0, 0, 0, 0, 0, 0, 0, 0, 21 0, 0, 0, 0, 0, 0, 0, 0, 22 0, 0, 0, 0, 0, 0, 0, 0, 23 0, 0, 0, 0, 0, 0, 0, 0, // 160 24 0, 0, 0, 0, 0, 0, 0, 0, 25 0, 0, 0, 0, 0, 0, 0, 0, 26 0, 0, 0, 0, 0, 0, 0, 0, 27 0, 0, 0, 0, 0, 0, 0, 'S', // 192 28 0, 0, 0, 0, 0, 0, 0, 0, 29 'T', 'N', 0, 0, 0, 0, 0, 'S', 30 0, 0, 0, 0, 0, 0, 0, 'S', 31 0, 0, 0, 0, 0, 0, 0, 'S', // 224 32 0, 0, 0, 0, 0, 0, 0, 0, 33 0, 'N' 34 // ... 35 }; 36 37 #define SNXBASE 48 38 #define SNXSIZE ((int)(sizeof(SnxTab) / sizeof(int))) 39 40 41 // (ext:Snx 'any ['cnt]) -> sym 42 any Snx(any ex) { 43 int n, c, i, last; 44 any x, nm; 45 cell c1, c2; 46 47 x = cdr(ex); 48 if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) 49 return Nil; 50 while (c < SNXBASE) 51 if (!(c = symChar(NULL))) 52 return Nil; 53 Push(c1, x); 54 n = isCell(x = cddr(ex))? evCnt(ex,x) : 24; 55 if (c >= 'a' && c <= 'z' || c == 128 || c >= 224 && c < 255) 56 c &= ~0x20; 57 Push(c2, boxChar(last = c, &i, &nm)); 58 while (c = symChar(NULL)) 59 if (c > ' ') { 60 if ((c -= SNXBASE) < 0 || c >= SNXSIZE || !(c = SnxTab[c])) 61 last = 0; 62 else if (c != last) { 63 if (!--n) 64 break; 65 charSym(last = c, &i, &nm); 66 } 67 } 68 drop(c1); 69 return consStr(data(c2)); 70 } 71 72 73 /*** Math ***/ 74 // (ext:Sin 'angle 'scale) -> num 75 any Sin(any ex) { 76 any x; 77 double a, n; 78 79 a = evDouble(ex, x = cdr(ex)); 80 n = evDouble(ex, cdr(x)); 81 return doubleToNum(n * sin(a / n)); 82 } 83 84 // (ext:Cos 'angle 'scale) -> num 85 any Cos(any ex) { 86 any x; 87 double a, n; 88 89 a = evDouble(ex, x = cdr(ex)); 90 n = evDouble(ex, cdr(x)); 91 return doubleToNum(n * cos(a / n)); 92 } 93 94 // (ext:Tan 'angle 'scale) -> num 95 any Tan(any ex) { 96 any x; 97 double a, n; 98 99 a = evDouble(ex, x = cdr(ex)); 100 n = evDouble(ex, cdr(x)); 101 return doubleToNum(n * tan(a / n)); 102 } 103 104 // (ext:Atan 'x 'y 'scale) -> num 105 any Atan(any ex) { 106 double x, y, n; 107 108 x = evDouble(ex, cdr(ex)); 109 y = evDouble(ex, cddr(ex)); 110 n = evDouble(ex, cdddr(ex)); 111 return doubleToNum(n * atan2(x / n, y / n)); 112 } 113 114 // (ext:Dist 'h 'v ['h1 'h2 ['h2 'v2]]) -> num 115 any Dist(any ex) { 116 any x; 117 double h, v, h1, v1, h2, v2, a, ca, sa; 118 119 h = evDouble(ex, x = cdr(ex)); 120 v = evDouble(ex, x = cdr(x)); 121 if (!isCell(x = cdr(x))) 122 return doubleToNum(sqrt(h*h + v*v)); 123 h1 = evDouble(ex, x); 124 v1 = evDouble(ex, x = cdr(x)); 125 if (!isCell(x = cdr(x))) { 126 h -= h1, v -= v1; 127 return doubleToNum(sqrt(h*h + v*v)); 128 } 129 h2 = evDouble(ex, x); 130 v2 = evDouble(ex, cdr(x)); 131 h -= h2, h1 -= h2; 132 v -= v2, v1 -= v2; 133 a = atan2(h1,v1), ca = cos(a), sa = sin(a); 134 a = h * ca - v * sa, v = v * ca + h * sa, h = a; 135 v1 = v1 * ca + h1 * sa; 136 if (v >= 0.0 && v <= v1) 137 return doubleToNum(fabs(h)); 138 if (v > 0.0) 139 v -= v1; 140 return doubleToNum(sqrt(h*h + v*v)); 141 } 142 143 144 /*** U-Law Encoding ***/ 145 #define BIAS 132 146 #define CLIP (32767-BIAS) 147 148 // (ext:Ulaw 'cnt) -> cnt # SEEEMMMM 149 any Ulaw(any ex) { 150 int val, sign, tmp, exp; 151 152 val = (int)evCnt(ex,cdr(ex)); 153 sign = 0; 154 if (val < 0) 155 val = -val, sign = 0x80; 156 if (val > CLIP) 157 val = CLIP; 158 tmp = (val += BIAS) << 1; 159 for (exp = 7; exp > 0 && !(tmp & 0x8000); --exp, tmp <<= 1); 160 return boxCnt(~(sign | exp<<4 | val >> exp+3 & 0x000F) & 0xFF); 161 } 162 163 164 /*** Base64 Encoding ***/ 165 static unsigned char Chr64[] = 166 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; 167 168 // (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg 169 any Base64(any x) { 170 int c, d; 171 any y; 172 173 x = cdr(x); 174 if (isNil(y = EVAL(car(x)))) 175 return Nil; 176 c = unDig(y) / 2; 177 Env.put(Chr64[c >> 2]); 178 x = cdr(x); 179 if (isNil(y = EVAL(car(x)))) { 180 Env.put(Chr64[(c & 3) << 4]), Env.put('='), Env.put('='); 181 return Nil; 182 } 183 d = unDig(y) / 2; 184 Env.put(Chr64[(c & 3) << 4 | d >> 4]); 185 x = cdr(x); 186 if (isNil(y = EVAL(car(x)))) { 187 Env.put(Chr64[(d & 15) << 2]), Env.put('='); 188 return Nil; 189 } 190 c = unDig(y) / 2; 191 Env.put(Chr64[(d & 15) << 2 | c >> 6]), Env.put(Chr64[c & 63]); 192 return T; 193 }