aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Initial data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 72d218235f
commit f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

133
Task/Zeckendorf-arithmetic/PicoLisp/zeckendorf-arithmetic.l Normal file
View file

@ -0,0 +1,133 @@
(seed (in "/dev/urandom" (rd 8)))
(de unpad (Lst)
(while (=0 (car Lst))
(pop 'Lst) )
Lst )
(de numz (N)
(let Fibs (1 1)
(while (>= N (+ (car Fibs) (cadr Fibs)))
(push 'Fibs (+ (car Fibs) (cadr Fibs))) )
(make
(for I (uniq Fibs)
(if (> I N)
(link 0)
(link 1)
(dec 'N I) ) ) ) ) )
(de znum (Lst)
(let Fibs (1 1)
(do (dec (length Lst))
(push 'Fibs (+ (car Fibs) (cadr Fibs))) )
(sum
'((X Y) (unless (=0 X) Y))
Lst
(uniq Fibs) ) ) )
(de incz (Lst)
(addz Lst (1)) )
(de decz (Lst)
(subz Lst (1)) )
(de addz (Lst1 Lst2)
(let Max (max (length Lst1) (length Lst2))
(reorg
(mapcar + (need Max Lst1 0) (need Max Lst2 0)) ) ) )
(de subz (Lst1 Lst2)
(use (@A @B)
(let
(Max (max (length Lst1) (length Lst2))
Lst (mapcar - (need Max Lst1 0) (need Max Lst2 0)) )
(loop
(while (match '(@A 1 0 0 @B) Lst)
(setq Lst (append @A (0 1 1) @B)) )
(while (match '(@A 1 -1 0 @B) Lst)
(setq Lst (append @A (0 0 1) @B)) )
(while (match '(@A 1 -1 1 @B) Lst)
(setq Lst (append @A (0 0 2) @B)) )
(while (match '(@A 1 0 -1 @B) Lst)
(setq Lst (append @A (0 1 0) @B)) )
(while (match '(@A 2 0 0 @B) Lst)
(setq Lst (append @A (1 1 1) @B)) )
(while (match '(@A 2 -1 0 @B) Lst)
(setq Lst (append @A (1 0 1) @B)) )
(while (match '(@A 2 -1 1 @B) Lst)
(setq Lst (append @A (1 0 2) @B)) )
(while (match '(@A 2 0 -1 @B) Lst)
(setq Lst (append @A (1 1 0) @B)) )
(while (match '(@A 1 -1) Lst)
(setq Lst (append @A (0 1))) )
(while (match '(@A 2 -1) Lst)
(setq Lst (append @A (1 1))) )
(NIL (match '(@A -1 @B) Lst)) )
(reorg (unpad Lst)) ) ) )
(de mulz (Lst1 Lst2)
(let (Sums (list Lst1) Mulz (0))
(mapc
'((X)
(when (= 1 (car X))
(setq Mulz (addz (cdr X) Mulz)) )
Mulz )
(mapcar
'((X)
(cons
X
(push 'Sums (addz (car Sums) (cadr Sums))) ) )
(reverse Lst2) ) ) ) )
(de divz (Lst1 Lst2)
(let Q 0
(while (lez Lst2 Lst1)
(setq Lst1 (subz Lst1 Lst2))
(setq Q (incz Q)) )
(list Q (or Lst1 (0))) ) )
(de reorg (Lst)
(use (@A @B)
(let Lst (reverse Lst)
(loop
(while (match '(@A 1 1 @B) Lst)
(if @B
(inc (nth @B 1))
(setq @B (1)) )
(setq Lst (append @A (0 0) @B) ) )
(while (match '(@A 2 @B) Lst)
(inc
(if (cdr @A)
(tail 2 @A)
@A ) )
(if @B
(inc (nth @B 1))
(setq @B (1)) )
(setq Lst (append @A (0) @B)) )
(NIL
(or
(match '(@A 1 1 @B) Lst)
(match '(@A 2 @B) Lst) ) ) )
(reverse Lst) ) ) )
(de lez (Lst1 Lst2)
(let Max (max (length Lst1) (length Lst2))
(<= (need Max Lst1 0) (need Max Lst2 0)) ) )
(let (X 0 Y 0)
(do 1024
(setq X (rand 1 1024))
(setq Y (rand 1 1024))
(test (numz (+ X Y)) (addz (numz X) (numz Y)))
(test (numz (* X Y)) (mulz (numz X) (numz Y)))
(test (numz (+ X 1)) (incz (numz X))) )
(do 1024
(setq X (rand 129 1024))
(setq Y (rand 1 128))
(test (numz (- X Y)) (subz (numz X) (numz Y)))
(test (numz (/ X Y)) (car (divz (numz X) (numz Y))))
(test (numz (% X Y)) (cadr (divz (numz X) (numz Y))))
(test (numz (- X 1)) (decz (numz X))) ) )
(bye)