demo_laws.sire (8145B)
1 ; Copyright 2023 The Plunder Authors 2 ; Use of this source code is governed by a BSD-style license that can be 3 ; found in the LICENSE file. 4 5 #### demo_laws <- demo_http_hello 6 7 ;;;; This is just a big pile of stuff that hasn't been moved into other 8 ;;;; modules yet. 9 10 :| sire 11 :| w32 12 :| w48 13 :| blake3 14 :| mutrec 15 :| stew 16 17 18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 20 (gulf f t)=(gen (sub inc-t f) add-f) 21 22 = (mkInput y) 23 | map (x & mod x 256) 24 | gulf 0 dec-y 25 26 hexAlphabet=(natBar {0123456789abcdef}) 27 28 (hexChar n)=(barGet hexAlphabet n) 29 30 (showByte n)=(barWeld b#0x byteToHex-n) 31 32 = (showHash v) 33 | strWeld {0x} 34 | barCat 35 | map byteToHex v 36 37 = (hexCharToNat v) 38 | if (lte v %9) (sub v %0) 39 | add 10 (sub (min v %f) %a) 40 41 = (barFromHex nat) 42 @ dig | map hexCharToNat explode-nat 43 @ pad | if (even len-dig) [] [0] 44 @ buf | listFromRow cat-[pad dig [0 1]] 45 ^ _ 0 buf 1 46 ? (loop acc lis pos) 47 | seq acc 48 : a as < listCase lis (0 1 1 acc) 49 : b bs < listCase as (die %impossible) 50 @ acc (| add acc | add mul-pos-b | mul-pos | mul 16 a) 51 | loop acc bs (mul 256 pos) 52 53 !! eql (add 1 0 ) | lawBody | barFromHex } 54 !! eql (add 1 bex-8 ) | lawBody | barFromHex } 1 55 !! eql (add 16 bex-8 ) | lawBody | barFromHex } 10 56 !! eql (add 1 bex-16) | lawBody | barFromHex } 100 57 !! eql (add 16 bex-16) | lawBody | barFromHex } 1000 58 !! eql 0xfe | barNat | barFromHex } fe 59 !! eql 0xfe00 | barNat | barFromHex } 00fe 60 !! eql 0xfe00 | barNat | barFromHex } 00fe 61 !! eql 0xfe0011 | barNat | barFromHex } 1100fe 62 63 !! eql | barCat 64 ++ x#7470ea5654831e01ffc04ee0e43a32fb 65 ++ x#90227162dc0faaa14f9627d8f5c718f7 66 | blake3 b#fdsafdsa 67 68 ; All pins referenced by a val. 69 = (refs top) 70 | listToRowRev 71 @ ini (if isPin-top pinItem-top top) 72 ^ _ NIL ini 73 ? (go set non) 74 | if isPin-non 75 | if (listHas non set) set 76 | CONS non set 77 | if isApp-non 78 @ set go-set-(car non) 79 @ set go-set-(cdr non) 80 | set 81 | if isLaw-non 82 | go-set-(lawBody non) 83 | set 84 85 ; All the pins reference in the body of a pin. 86 = (pinRefs top) 87 | listToRowRev 88 ^ _ NIL (pinItem top) 89 ? (go set non) 90 | if isPin-non 91 | if (listHas non set) set 92 | CONS non set 93 | if isApp-non 94 @ set go-set-(car non) 95 @ set go-set-(cdr non) 96 | set 97 | if isLaw-non 98 | go-set-(lawBody non) 99 | set 100 101 ; Lookup into a map encoded as a list 102 ; of [k v] pairs. 103 = (listLookup key l) 104 : x xs < listCase l NONE 105 @ [k v] x 106 | if (eql k key) (SOME v) 107 | listLookup key xs 108 109 = (dropHighBit x) 110 | sub x 111 | bex | dec met-x 112 113 = (mat nat) 114 | ifNot nat p#1 115 @ aSz met-nat 116 @ sSz met-aSz 117 @ wid (add aSz dec-(add sSz sSz)) 118 @ bod | dropHighBit 119 | mix 120 * mod aSz (bex | dec sSz) 121 * lsh nat (dec sSz) 122 | add (bex wid) 123 | add (bex sSz) 124 | lsh bod (inc sSz) 125 126 =?= (mat 0) | p#1 127 =?= (mat 1) | p#01 128 =?= (mat 2) | p#00100 129 =?= (mat 3) | add (bex 5) 20 130 =?= (mat 4) | add (bex 6) 12 131 =?= (mat 5) | add (bex 6) 28 132 =?= (mat 6) | add (bex 6) 44 133 =?= (mat 7) | add (bex 6) 60 134 =?= (mat 8) | add (bex 9) 8 135 =?= (mat 9) | add (bex 9) 72 136 137 138 ;;; Some Monadic Operations on `Maybe` ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 140 > Row (Maybe a) 141 > Maybe (Row a) 142 = (maybeRowSequence results) 143 ^ _ NIL listFromRow-results 144 ? (loop acc rest) 145 : mX more < listCase rest SOME-(listToRowRev acc) 146 : x < maybeCase mX NONE 147 | loop (CONS x acc) more 148 149 (maybeRowTraverse f xs)=(maybeRowSequence map-f-xs) 150 151 !! | eql NONE 152 | maybeRowSequence [SOME-3 SOME-4 NONE] 153 154 !! | eql SOME-[3 4 5] 155 | maybeRowSequence [SOME-3 SOME-4 SOME-5] 156 157 158 ;;; Parsing Nat Literals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 160 > Char > Maybe Nat 161 = (readDigit char) 162 | tabSwitch char NONE 163 ## ={0} SOME 0 164 ## ={1} SOME 1 165 ## ={2} SOME 2 166 ## ={3} SOME 3 167 ## ={4} SOME 4 168 ## ={5} SOME 5 169 ## ={6} SOME 6 170 ## ={7} SOME 7 171 ## ={8} SOME 8 172 ## ={9} SOME 9 173 174 > Nat > Maybe Nat 175 = (readNat n) 176 @ mDigits (maybeRowTraverse readDigit explode-n) 177 : nums < maybeCase mDigits NONE 178 @ f 179 & (elem rest) 180 @ [pos acc] rest 181 (mul 10 pos, add acc mul-pos-elem) 182 | ifNot len-nums NONE 183 | SOME (idx 1)(foldr f [1 0] nums) 184 185 !! eql SOME-1 readNat-{1} 186 !! eql SOME-12 readNat-{12} 187 !! eql SOME-123 readNat-{123} 188 !! eql NONE readNat-{} 189 !! eql NONE readNat-{a} 190 191 192 ;;; Printing Rex Expressions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 193 194 = ({>=} ss rex err ok) 195 @ heir | rexHeir rex 196 @ sons | rexSons rex 197 @ [x y] | sons 198 | if (neq 0 heir) | err rex {unexpected heir} 199 | if (neq 2 len-sons) | err rex {Expected two sons} 200 | ok ss 201 | appE (cnsE gte, x, y) 202 203 =?= 0 (3 >= 4) 204 =?= 1 (4 >= 4) 205 =?= 1 (4 >= 3) 206 207 208 ;;; Scratch Pad: Pronouncing Numbers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 209 210 = (natWords n) 211 # switch n 212 * 0 %Zero 213 ^ _ n 214 ? (loop n) 215 # switch n 216 * 0 {} 217 * 1 %One 218 * 2 %Two 219 * 3 %Three 220 * 4 %Four 221 * 5 %Five 222 * 6 %Six 223 * 7 %Seven 224 * 8 %Eight 225 * 9 %Nine 226 | strCat 227 ++ loop (div n 10) 228 ++ natWords (mod n 10) 229 230 =?= %ThreeFourFive natWords-345 231 =?= %Zero natWords-0 232 =?= %OneZero natWords-10 233 234 235 ;;; Serialization ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 236 237 = (jam external top) 238 @ pos | len external 239 @ tab | tabFromPairs (gen len-external i&(idx i external, i)) 240 # mutrec %loop 241 @ [_ _ buf] (**go pos tab top) 242 | padFlat buf 243 * (nat p t atm) 244 | (p, t, [p#11 (mat atm)]) 245 * (backref p t ref) 246 | (p, t, [p#10 (mat ref)]) 247 * (cel p t hed tel) 248 @ [p t hBits] (**go (inc p) t hed) 249 @ [p t tBits] (**go (inc p) t tel) 250 | (p, t, [p#0 hBits tBits]) 251 * (go p t noun) 252 : ref 253 < maybeCase (tabLookup noun t) 254 @ t (tabIns noun p t) 255 | if isNat-noun (**nat p t noun) 256 | if isApp-noun (**cel p t car-noun cdr-noun) 257 @ hed (0 lawName-noun lawArgs-noun) 258 @ tel (lawBody noun) 259 | **cel p t hed tel 260 | if | and isNat-noun 261 | lte met-noun met-ref 262 (**nat p t noun) 263 (**backref p t ref) 264 265 = (jarMemo cache pin) 266 | maybeCase (tabLookup pin cache) 267 @ depz | pinRefs pin 268 : cache head 269 < ^ rowTraverseState cache _ depz 270 & (cache item pure) 271 @ [cache res] | jarMemo cache item 272 @ [hash _ _] | res 273 @ cache | tabIns item res cache 274 | pure cache hash 275 @ pack | jam depz pinItem-pin 276 @ byts | natBar pack 277 @ sepr | barRep 32 0 278 @ cHed | barCat head 279 @ comb | barCat (cHed, sepr, byts) 280 @ hash | blake3 comb 281 | [cache [hash depz byts]] 282 & entry 283 | [cache entry] 284 285 = (jar val) 286 | idx 1 287 | jarMemo #[] 288 | if isPin-val val PIN-val 289 290 = (niceJar val) 291 @ [hash deps byts] jar-val 292 ## =hash hash 293 ## =deps deps 294 ## =bits byts 295 296 (pinHash val)=(| idx 0 | jar val) 297 (pinBytz val)=(| idx 2 | jar val) 298 299 =?= pinBytz-0 | x#0f 300 =?= pinBytz-1 | x#1b 301 =?= pinBytz-2 | x#93 302 =?= pinBytz-3 | x#d3 303 =?= pinBytz-(0 0) | x#fe 304 =?= pinBytz-(2 0 3) | x#4c3e0d 305 =?= pinBytz-toNat | x#f8c0f745f5e614462f67f2e906 306 307 =?= x{d117f9cd69c91e50b44f517a1c71219c8c6924f695b5a6375fd5921bd637b408} 308 | pinHash add 309 310 =?= x{0812f87c0613ea2c72f73e2f25fcd9af79a512015007b495caaea19aee21b87e} 311 | pinHash mul 312 313 =?= x{39deac7b88921ca453f4a2eedbb179c49071d8a6d63f8b05e7433b697106ed4c} 314 | pinHash cmp 315 316 = (refsTable pin) 317 | tabFromPairs 318 : r < foreach (refs pin) 319 | ++ lawName pinItem-r 320 ++ pinHash r 321 322 323 ;;; Macro: Value Recursion (Knots) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 324 325 = (readBindPairs rex err ok) 326 ^ _ NIL rex 327 ? (loop acc rex) 328 | ifz rex 329 | ok | listToRowRev acc 330 | if (neq {=} (rexRune rex)) 331 | err rex {Knot patterns must be = nodes} 332 : sym rhs 333 < rexParseKids (rexSetHeir 0 rex) [readSymbol readRex] err 334 @ acc (CONS [sym rhs] acc) 335 | loop acc (rexHeir rex) 336 337 338 =?= [[%hi 'there] [%bye 'here]] 339 ^ readBindPairs _ v2 id 340 ' ((hi=there)(bye=here)) 341 342 ;;; 343 ;;; TODO Broken macro. Unit test the SHIT out of all of this macro code. 344 ;;; 345 ;;; = ({#knot} env nex xs mK) 346 ;;; . env nex xs mK 347 ;;; | gensymMacro {#knot} [readBindPairs RIGHT] 348 ;;; & (nex bindPairs body) 349 ;;; @ knotRef | gensymE nex 350 ;;; @ bindSymz | map idx-0 bindPairs 351 ;;; @ bindVals | map idx-1 bindPairs 352 ;;; | RIGHT 353 ;;; , 1 354 ;;; | letE knotRef 355 ;;; | opnE bindSymz knotRef vecE-bindVals 356 ;;; | opnE bindSymz knotRef body 357 ;;; 358 ;;; !! | listTake 3 359 ;;; # knot = x (CONS 3 y) 360 ;;; = y (CONS 4 x) 361 ;;; | x 362 ;;;