diff --git a/csp/csp.rkt b/csp/csp.rkt index 28cad5d7..32e7162c 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -234,20 +234,21 @@ (define csp-with-assignment (apply-unary-constraint csp ($constraint (list name) (delay (list val))))) (validate-assignments csp-with-assignment)) -(define (reduce-arity proc args) - (unless (= (length args) (procedure-arity proc)) - (raise-argument-error 'reduce-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) args)) +(define (reduce-arity proc pattern) + (unless (= (length pattern) (procedure-arity proc)) + (raise-argument-error 'reduce-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) pattern)) (define reduced-arity-name (string->symbol (format "reduced-arity-~a" (object-name proc)))) - (define new-arity (length (filter symbol? args))) + (define-values (id-names vals) (partition symbol? pattern)) + (define new-arity (length id-names)) (procedure-rename (λ xs (unless (= (length xs) new-arity) (apply raise-arity-error reduced-arity-name new-arity xs)) (apply proc (for/fold ([acc empty] [xs xs] - [vals (filter-not symbol? args)] + [vals vals] #:result (reverse acc)) - ([arg (in-list args)]) + ([arg (in-list pattern)]) (if (symbol? arg) (values (cons (car xs) acc) (cdr xs) vals) (values (cons (car vals) acc) xs (cdr vals))))))