couples-2.lisp (3323B)
1 (defun gauss-formula (n) 2 (/ (* n (+ n 1)) 2)) 3 4 (defun get-n (code) 5 (isqrt (* code 2))) 6 7 (defun get-axis (code) 8 (gauss-formula (isqrt (* code 2)))) 9 10 (defun get-axis-from-n (n) 11 (gauss-formula n)) 12 13 (defun axis-code-compare (code) 14 (format t "~d ~d~%" code (get-axis code))) 15 16 (defun axis-code-compare-n (startcode n) 17 (let ((i 0)) 18 (loop 19 (when (> i n) (return)) 20 (axis-code-compare (+ startcode i)) 21 (incf i)))) 22 23 (defun ord-pr-to-code (x y) 24 (let ((sumxy (+ x y))) 25 (if (evenp sumxy) 26 (+ (gauss-formula sumxy) x) 27 (+ (gauss-formula sumxy) y)))) 28 29 (defun code-to-ord-pr (code) 30 (let ((n (get-n code)) 31 (axis (get-axis code)) 32 (diff 0)) 33 (progn 34 (when (> (get-axis code) code) 35 (progn 36 (setf n (- n 1)) 37 (setf axis (get-axis-from-n n)))) 38 (setf diff (- code axis)) 39 (if (evenp n) 40 (cons diff (cons (- n diff) ())) 41 (cons (- n diff) (cons diff ())))))) 42 43 (defun ord-mult-to-code (L) 44 (if (= (list-length L) 1) 45 (car L) 46 (ord-mult-to-code (append (butlast (butlast L)) 47 (cons (ord-pr-to-code (car (last (butlast L))) (car (last L))) ()))))) 48 49 (defun code-to-ord-mult (L-or-code size) 50 (if (atom L-or-code) 51 (code-to-ord-mult (code-to-ord-pr L-or-code) (- size 1)) 52 (if (not (= size 1)) 53 (code-to-ord-mult (append (butlast L-or-code) (code-to-ord-pr (car (last L-or-code)))) 54 (- size 1)) 55 L-or-code))) 56 57 #| Les codes générés par cette fonction ne correspondent pas au code généré par le 58 diagramme du rapport ni des fonctions ord-mult-to-code et code-to-ord-mult. 59 Toutefois, la fonction ci-dessous a été créées ici car son écriture et beaucoup plus idiomatique 60 en LISP (d'où le nom 'ord-mult-to-code-lisp'). En effet, si on avait à coder les nombres naturels en LISP, on ajouterait 61 (resp. supprimerait) des éléments de la liste en partant du début de la liste afin de créer 62 une paire ou un n-uplet (resp. pour trouver le code correspondant à une paire ou un n-uplet 63 |# 64 (defun ord-mult-to-code-lisp (L) 65 (if (= (list-length L) 1) 66 (car L) 67 (ord-mult-to-code-lisp (cons (ord-pr-to-code (first L) (second L)) (cddr L))))) 68 69 #| voir le commentaire précédent concernant la fonction ord-mult-to-code-lisp |# 70 (defun code-to-ord-mult-lisp (L-or-code size) 71 (if (atom L-or-code) 72 (code-to-ord-mult-lisp (code-to-ord-pr L-or-code) (- size 1)) 73 (if (not (= size 1)) 74 (code-to-ord-mult-lisp (append (code-to-ord-pr (car L-or-code)) (cdr L-or-code)) (- size 1)) 75 L-or-code))) 76 77 #| 78 (defun code-to-ord-pr (code) 79 (;let* ((code*2 (* code 2)) 80 (n (isqrt code*2)) 81 (axis (gauss-formula n)) 82 (diff 0)) 83 (cond 84 ((> axis code) 85 (loop while (> axis code) 86 ((setf n (- n 1)) 87 (setf axis (gauss-formula n)))) 88 (< axis code) 89 ((loop while (< axis code) 90 ((setf n (- n 1)) 91 (setf axis (gauss-formula n)))) 92 (when (> axis code) 93 ((setf n (- n 1)) 94 (setf axis (gauss-formula n)))))) 95 (t 5)))) 96 |# 97 98 99 (defun loop-test (n) 100 (let ((n 0)) 101 (loop 102 (when (> n 10) (return)) 103 (format t "~d ~d ~d~%" n (isqrt n) (gauss-formula n)) 104 ;(print n) (write (* n n)) (write n) 105 (incf n)))) 106