ext.c (5484B)
1 /* 13may13abu 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:Pow 'x 'y 'scale) -> num 75 any Pow(any ex) { 76 double x, y, n; 77 78 x = evDouble(ex, cdr(ex)); 79 y = evDouble(ex, cddr(ex)); 80 n = evDouble(ex, cdddr(ex)); 81 return doubleToNum(n * pow(x / n, y / n)); 82 } 83 84 // (ext:Exp 'x 'scale) -> num 85 any Exp(any ex) { 86 double x, n; 87 88 x = evDouble(ex, cdr(ex)); 89 n = evDouble(ex, cddr(ex)); 90 return doubleToNum(n * exp(x / n)); 91 } 92 93 // (ext:Log 'x 'scale) -> num 94 any Log(any ex) { 95 double x, n; 96 97 x = evDouble(ex, cdr(ex)); 98 n = evDouble(ex, cddr(ex)); 99 return doubleToNum(n * log(x / n)); 100 } 101 102 // (ext:Sin 'angle 'scale) -> num 103 any Sin(any ex) { 104 double a, n; 105 106 a = evDouble(ex, cdr(ex)); 107 n = evDouble(ex, cddr(ex)); 108 return doubleToNum(n * sin(a / n)); 109 } 110 111 // (ext:Cos 'angle 'scale) -> num 112 any Cos(any ex) { 113 double a, n; 114 115 a = evDouble(ex, cdr(ex)); 116 n = evDouble(ex, cddr(ex)); 117 return doubleToNum(n * cos(a / n)); 118 } 119 120 // (ext:Tan 'angle 'scale) -> num 121 any Tan(any ex) { 122 double a, n; 123 124 a = evDouble(ex, cdr(ex)); 125 n = evDouble(ex, cddr(ex)); 126 return doubleToNum(n * tan(a / n)); 127 } 128 129 // (ext:Asin 'angle 'scale) -> num 130 any Asin(any ex) { 131 double a, n; 132 133 a = evDouble(ex, cdr(ex)); 134 n = evDouble(ex, cddr(ex)); 135 return doubleToNum(n * asin(a / n)); 136 } 137 138 // (ext:Acos 'angle 'scale) -> num 139 any Acos(any ex) { 140 double a, n; 141 142 a = evDouble(ex, cdr(ex)); 143 n = evDouble(ex, cddr(ex)); 144 return doubleToNum(n * acos(a / n)); 145 } 146 147 // (ext:Atan 'angle 'scale) -> num 148 any Atan(any ex) { 149 double a, n; 150 151 a = evDouble(ex, cdr(ex)); 152 n = evDouble(ex, cddr(ex)); 153 return doubleToNum(n * atan(a / n)); 154 } 155 156 // (ext:Atan2 'x 'y 'scale) -> num 157 any Atan2(any ex) { 158 double x, y, n; 159 160 x = evDouble(ex, cdr(ex)); 161 y = evDouble(ex, cddr(ex)); 162 n = evDouble(ex, cdddr(ex)); 163 return doubleToNum(n * atan2(x / n, y / n)); 164 } 165 166 167 /*** U-Law Encoding ***/ 168 #define BIAS 132 169 #define CLIP (32767-BIAS) 170 171 // (ext:Ulaw 'cnt) -> cnt # SEEEMMMM 172 any Ulaw(any ex) { 173 int val, sign, tmp, exp; 174 175 val = (int)evCnt(ex,cdr(ex)); 176 sign = 0; 177 if (val < 0) 178 val = -val, sign = 0x80; 179 if (val > CLIP) 180 val = CLIP; 181 tmp = (val += BIAS) << 1; 182 for (exp = 7; exp > 0 && !(tmp & 0x8000); --exp, tmp <<= 1); 183 return boxCnt(~(sign | exp<<4 | val >> exp+3 & 0x000F) & 0xFF); 184 } 185 186 187 /*** Base64 Encoding ***/ 188 static unsigned char Chr64[] = 189 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; 190 191 // (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg 192 any Base64(any x) { 193 int c, d; 194 any y; 195 196 x = cdr(x); 197 if (isNil(y = EVAL(car(x)))) 198 return Nil; 199 c = unDig(y) / 2; 200 Env.put(Chr64[c >> 2]); 201 x = cdr(x); 202 if (isNil(y = EVAL(car(x)))) { 203 Env.put(Chr64[(c & 3) << 4]), Env.put('='), Env.put('='); 204 return Nil; 205 } 206 d = unDig(y) / 2; 207 Env.put(Chr64[(c & 3) << 4 | d >> 4]); 208 x = cdr(x); 209 if (isNil(y = EVAL(car(x)))) { 210 Env.put(Chr64[(d & 15) << 2]), Env.put('='); 211 return Nil; 212 } 213 c = unDig(y) / 2; 214 Env.put(Chr64[(d & 15) << 2 | c >> 6]), Env.put(Chr64[c & 63]); 215 return T; 216 } 217 218 /*** Password hashing ***/ 219 // (Ext:Crypt 'key 'salt) -> str 220 any Crypt(any x) { 221 any y; 222 223 y = evSym(x = cdr(x)); 224 { 225 char key[bufSize(y)]; 226 227 bufString(y, key); 228 y = evSym(cdr(x)); 229 { 230 char salt[bufSize(y)]; 231 232 bufString(y, salt); 233 return mkStr(crypt(key, salt)); 234 } 235 } 236 }