Skip to content
Snippets Groups Projects
Commit c9519850 authored by pfdietz's avatar pfdietz
Browse files

More tweaks of reduce and associated pruning rules.

parent 00325685
No related branches found
No related tags found
No related merge requests found
...@@ -603,24 +603,46 @@ ...@@ -603,24 +603,46 @@
`(progv ',vars (list ,@var-forms) ,body-form)))))) `(progv ',vars (list ,@var-forms) ,body-form))))))
(defun make-random-integer-mapping-form (size) (defun make-random-integer-mapping-form (size)
(rcase ;; reduce
(1 ;; reduce (let ((keyargs nil)
(let ((sizes (random-partition (1- size) (1+ (random (min 10 (max 1 size)))))) (nargs (1+ (random (min 10 (max 1 size)))))
(op (random-from-seq #(+ - * logand logxor logior max min)))) (sequence-op (random-from-seq '(vector list))))
`(reduce (function ,op) (list ,@(mapcar #'make-random-integer-form sizes))))) (when (coin 2) (setq keyargs '(:from-end t)))
(1 ;; reduce with lambda form (cond
(destructuring-bind (size1 size2) (random-partition (1- size) 2) ((coin 2)
(let* ((vars '(lv1 lv2 lv3 lv4 lv5 lv6)) (let ((start (random nargs)))
(var1 (random-from-seq vars)) (setq keyargs `(:start ,start ,@keyargs))
(var2 (random-from-seq (remove var1 vars))) (when (coin 2)
(form (let ((*vars* (list* (let ((end (+ start 1 (random (- nargs start)))))
(make-var-desc :name var1 :type '(integer * *)) (setq keyargs `(:end ,end ,@keyargs))))))
(make-var-desc :name var2 :type '(integer * *)) (t
*vars*))) (when (coin 2)
(make-random-integer-form size1))) (let ((end (1+ (random nargs))))
(sizes (random-partition size2 (1+ (random (min 10 (max 1 size2)))))) (setq keyargs `(:end ,end ,@keyargs))))))
(args (mapcar #'make-random-integer-form sizes))) (rcase
`(reduce (function (lambda (,var1 ,var2) ,form)) (list ,@args))))))) (1
(let ((sizes (random-partition (1- size) nargs))
(op (random-from-seq #(+ - * logand logxor logior max min))))
`(reduce ,(rcase (1 `(function ,op))
(1 `(quote ,op)))
(,sequence-op
,@(mapcar #'make-random-integer-form sizes))
,@keyargs)))
(1
(destructuring-bind (size1 size2) (random-partition (1- size) 2)
(let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))
(var1 (random-from-seq vars))
(var2 (random-from-seq (remove var1 vars)))
(form (let ((*vars* (list*
(make-var-desc :name var1 :type '(integer * *))
(make-var-desc :name var2 :type '(integer * *))
*vars*)))
(make-random-integer-form size1)))
(sizes (random-partition size2 nargs))
(args (mapcar #'make-random-integer-form sizes)))
`(reduce (function (lambda (,var1 ,var2) ,form))
(,sequence-op ,@args)
,@keyargs)))))))
(defun make-random-integer-setq-form (size) (defun make-random-integer-setq-form (size)
(if *vars* (if *vars*
...@@ -634,11 +656,13 @@ ...@@ -634,11 +656,13 @@
(setq var (list var)))) (setq var (list var))))
(cond (cond
((equal type '(integer * *)) ((equal type '(integer * *))
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
`(,op ,var ,(make-random-integer-form (1- size)))) `(,op ,var ,(make-random-integer-form (1- size))))
((and (consp type) ((and (consp type)
(eq (car type) 'integer) (eq (car type) 'integer)
(integerp (second type)) (integerp (second type))
(integerp (third type))) (integerp (third type)))
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
`(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
;; Abort -- can't assign ;; Abort -- can't assign
(t (make-random-integer-form size)))) (t (make-random-integer-form size))))
...@@ -1505,7 +1529,7 @@ ...@@ -1505,7 +1529,7 @@
(let ((arg1 (car args)) (let ((arg1 (car args))
(arg2 (cadr args)) (arg2 (cadr args))
(rest (cddr args))) (rest (cddr args)))
(when (and (null (cddr args)) (when (and ;; (null (cddr args))
(consp arg1) (consp arg1)
(eql (car arg1) 'function)) (eql (car arg1) 'function))
(let ((arg1.2 (cadr arg1))) (let ((arg1.2 (cadr arg1)))
...@@ -1520,13 +1544,14 @@ ...@@ -1520,13 +1544,14 @@
,arg2 ,@rest))))))))) ,arg2 ,@rest)))))))))
(when (consp arg2) (when (consp arg2)
(case (car arg2) (case (car arg2)
((list) ((list vector)
(let ((arg2.rest (cdr arg2))) (let ((arg2.rest (cdr arg2)))
(mapc try-fn arg2.rest)
(prune-list arg2.rest (prune-list arg2.rest
#'prune #'prune
#'(lambda (args) #'(lambda (args)
(try `(reduce ,arg1 (try `(reduce ,arg1
(list ,@args) (,(car arg2) ,@args)
,@rest)))))))))) ,@rest))))))))))
((apply) ((apply)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment