From af352874ecdce6731154d6780069b9ff5f3ddb69 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Mon, 7 Jun 2004 23:50:27 +0000 Subject: [PATCH] Added my-with-standard-io-syntax, to get around the lack of w-s-io-s in gcl. Also, improved random-partition. --- ansi-tests/ansi-aux.lsp | 58 +++++++++++++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 14 deletions(-) diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 1bec31b5..1e4d0b21 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -1638,17 +1638,9 @@ the condition to go uncaught if it cannot be classified." (* significand (expt radix limit) sign)) (t (rational x)))))) -(defun random-partition (n p) - "Partition n into p numbers, each >= 1. Return list of numbers." +(defun random-partition* (n p) + "Partition n into p numbers, each >= 0. Return list of numbers." (assert (<= 1 p)) - #| - (cond - ((= p 1) (list n)) - ((< n p) (make-list p :initial-element 1)) - (t - (let ((n1 (1+ (random (floor n p))))) - (cons n1 (random-partition (- n n1) (1- p))))))) - |# (cond ((= p 1) (list n)) ((= n 0) (make-list p :initial-element 0)) @@ -1656,15 +1648,22 @@ the condition to go uncaught if it cannot be classified." (n1 (random (1+ n)))) (cond ((= r 0) - (cons n1 (random-partition (- n n1) (1- p)))) + (cons n1 (random-partition* (- n n1) (1- p)))) ((= r (1- p)) - (append (random-partition (- n n1) (1- p)) (list n1))) + (append (random-partition* (- n n1) (1- p)) (list n1))) (t (let* ((n2 (random (1+ (- n n1)))) (n3 (- n n1 n2))) - (append (random-partition n2 r) + (append (random-partition* n2 r) (list n1) - (random-partition n3 (- p 1 r)))))))))) + (random-partition* n3 (- p 1 r)))))))))) + +(defun random-partition (n p) + "Partition n into p numbers, each >= 1 (if possible.)" + (cond + ((<= n p) + (make-list p :initial-element 1)) + (t (mapcar #'1+ (random-partition* (- n p) p))))) (declaim (special *similarity-list*)) @@ -1760,3 +1759,34 @@ the condition to go uncaught if it cannot be classified." (defmethod is-similar* ((x t) (y t)) (and (eql x y) t)) + +(defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) + *print-pprint-dispatch* + nil)) + +(defmacro my-with-standard-io-syntax (&body body) + `(let ((*package* (find-package "COMMON-LISP-USER")) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pprint-dispatch* *initial-print-pprint-dispatch*) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable nil))) + ,@body)) + + + \ No newline at end of file -- GitLab