|
|
|
@ -1,15 +1,23 @@
|
|
|
|
#lang racket/base
|
|
|
|
#lang racket/base
|
|
|
|
(require (for-syntax racket/base) racket/list "define.rkt")
|
|
|
|
(require (for-syntax
|
|
|
|
|
|
|
|
racket/base)
|
|
|
|
(define (list-of-lists? xs) (and (list? xs) (andmap list? xs)))
|
|
|
|
racket/list
|
|
|
|
(define (index? x) (and (integer? x) (not (negative? x))))
|
|
|
|
racket/match
|
|
|
|
|
|
|
|
racket/function
|
|
|
|
(define increasing-nonnegative-list? (λ(x) (and (list? x) (or (empty? x)
|
|
|
|
"define.rkt")
|
|
|
|
(apply < -1 x)))))
|
|
|
|
|
|
|
|
|
|
|
|
(define (list-of-lists? x)
|
|
|
|
(define (integers? x) (and (list? x) (andmap integer? x)))
|
|
|
|
(match x
|
|
|
|
|
|
|
|
[(list (? list?) ...) #true]
|
|
|
|
(define (negate pred) (λ(x) (not (pred x))))
|
|
|
|
[_ #false]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (increasing-nonnegative-list? x)
|
|
|
|
|
|
|
|
(and (list? x) (or (empty? x) (apply < -1 x))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (integers? x)
|
|
|
|
|
|
|
|
(match x
|
|
|
|
|
|
|
|
[(list (? integer?) ...) #true]
|
|
|
|
|
|
|
|
[_ #false]))
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (trimf xs test-proc)
|
|
|
|
(define+provide+safe (trimf xs test-proc)
|
|
|
|
(list? procedure? . -> . list?)
|
|
|
|
(list? procedure? . -> . list?)
|
|
|
|
@ -17,7 +25,6 @@
|
|
|
|
(raise-argument-error 'trimf "list?" xs))
|
|
|
|
(raise-argument-error 'trimf "list?" xs))
|
|
|
|
(dropf-right (dropf xs test-proc) test-proc))
|
|
|
|
(dropf-right (dropf xs test-proc) test-proc))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (slicef-and-filter-split-helper xs pred [drop-negated? #f])
|
|
|
|
(define (slicef-and-filter-split-helper xs pred [drop-negated? #f])
|
|
|
|
(let loop ([xs xs][negating? #f][acc empty])
|
|
|
|
(let loop ([xs xs][negating? #f][acc empty])
|
|
|
|
(cond
|
|
|
|
(cond
|
|
|
|
@ -28,42 +35,37 @@
|
|
|
|
(define subxs (if (and negating? drop-negated?) empty loop-pred-xs))
|
|
|
|
(define subxs (if (and negating? drop-negated?) empty loop-pred-xs))
|
|
|
|
(loop other-xs (not negating?) (if (empty? subxs) acc (cons subxs acc)))])))
|
|
|
|
(loop other-xs (not negating?) (if (empty? subxs) acc (cons subxs acc)))])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (slicef xs pred)
|
|
|
|
(define+provide+safe (slicef xs pred)
|
|
|
|
(list? procedure? . -> . list-of-lists?)
|
|
|
|
(list? procedure? . -> . list-of-lists?)
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
(raise-argument-error 'slicef "list?" xs))
|
|
|
|
(raise-argument-error 'slicef "list?" xs))
|
|
|
|
(slicef-and-filter-split-helper xs pred))
|
|
|
|
(slicef-and-filter-split-helper xs pred))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (slicef-at xs pred [force? #f])
|
|
|
|
(define+provide+safe (slicef-at xs pred [force? #f])
|
|
|
|
((list? procedure?) (boolean?) . ->* . list-of-lists?)
|
|
|
|
((list? procedure?) (boolean?) . ->* . list-of-lists?)
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
(raise-argument-error 'slicef-at "list?" xs))
|
|
|
|
(raise-argument-error 'slicef-at "list?" xs))
|
|
|
|
(let loop ([xs xs][acc empty])
|
|
|
|
(let loop ([xs xs][acc empty])
|
|
|
|
(cond
|
|
|
|
(match xs
|
|
|
|
[(empty? xs) (reverse acc)]
|
|
|
|
[(== empty) (reverse acc)]
|
|
|
|
[(pred (car xs))
|
|
|
|
[(cons (? pred first) rest)
|
|
|
|
(define-values (not-pred-xs rest) (splitf-at (cdr xs) (negate pred)))
|
|
|
|
(define-values (not-pred-xs tail) (splitf-at rest (negate pred)))
|
|
|
|
(loop rest (cons (cons (car xs) not-pred-xs) acc))]
|
|
|
|
(loop tail (cons (cons first not-pred-xs) acc))]
|
|
|
|
[else
|
|
|
|
[rest
|
|
|
|
(define-values (not-pred-xs rest) (splitf-at xs (negate pred)))
|
|
|
|
(define-values (not-pred-xs tail) (splitf-at rest (negate pred)))
|
|
|
|
(loop rest (if force? acc (cons not-pred-xs acc)))])))
|
|
|
|
(loop tail (if force? acc (cons not-pred-xs acc)))])))
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (slicef-after xs pred)
|
|
|
|
(define+provide+safe (slicef-after xs pred)
|
|
|
|
(list? procedure? . -> . list-of-lists?)
|
|
|
|
(list? procedure? . -> . (listof list?))
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
(raise-argument-error 'slicef-after "list?" xs))
|
|
|
|
(raise-argument-error 'slicef-after "list?" xs))
|
|
|
|
(let loop ([xs xs][acc empty])
|
|
|
|
(let loop ([xs xs][acc empty])
|
|
|
|
(cond
|
|
|
|
(if (empty? xs)
|
|
|
|
[(empty? xs) (reverse acc)]
|
|
|
|
(reverse acc)
|
|
|
|
[else
|
|
|
|
(match/values (splitf-at xs (negate pred))
|
|
|
|
(define-values (not-pred-xs rest) (splitf-at xs (negate pred)))
|
|
|
|
[(not-pred-xs (cons first-pred-x other-pred-xs))
|
|
|
|
(if (pair? rest)
|
|
|
|
(loop other-pred-xs (cons (append not-pred-xs (list first-pred-x)) acc))]
|
|
|
|
(let ([must-be-pred-x (car rest)])
|
|
|
|
[(not-pred-xs _) not-pred-xs]))))
|
|
|
|
(loop (cdr rest) (cons (append not-pred-xs (list must-be-pred-x)) acc)))
|
|
|
|
|
|
|
|
not-pred-xs)])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (slice-at xs len [force? #f])
|
|
|
|
(define+provide+safe (slice-at xs len [force? #f])
|
|
|
|
((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)
|
|
|
|
((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)
|
|
|
|
@ -72,15 +74,12 @@
|
|
|
|
(unless (and (integer? len) (positive? len))
|
|
|
|
(unless (and (integer? len) (positive? len))
|
|
|
|
(raise-argument-error 'slice-at "positive integer for sublist length" len))
|
|
|
|
(raise-argument-error 'slice-at "positive integer for sublist length" len))
|
|
|
|
(let loop ([xs xs][slices empty])
|
|
|
|
(let loop ([xs xs][slices empty])
|
|
|
|
(cond
|
|
|
|
(if (< (length xs) len)
|
|
|
|
[(< (length xs) len) (reverse
|
|
|
|
(reverse (if (or force? (empty? xs))
|
|
|
|
(if (or force? (empty? xs))
|
|
|
|
|
|
|
|
slices
|
|
|
|
slices
|
|
|
|
(cons xs slices)))]
|
|
|
|
(cons xs slices)))
|
|
|
|
[else
|
|
|
|
(match/values (split-at xs len)
|
|
|
|
(define-values (subxs rest) (split-at xs len))
|
|
|
|
[(subxs rest) (loop rest (cons subxs slices))]))))
|
|
|
|
(loop rest (cons subxs slices))])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (filter-split xs pred)
|
|
|
|
(define+provide+safe (filter-split xs pred)
|
|
|
|
(list? predicate/c . -> . list-of-lists?)
|
|
|
|
(list? predicate/c . -> . list-of-lists?)
|
|
|
|
@ -89,7 +88,6 @@
|
|
|
|
;; same idea as slicef, but the negated items are dropped(-
|
|
|
|
;; same idea as slicef, but the negated items are dropped(-
|
|
|
|
(slicef-and-filter-split-helper xs (negate pred) 'drop-negated))
|
|
|
|
(slicef-and-filter-split-helper xs (negate pred) 'drop-negated))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (frequency-hash xs)
|
|
|
|
(define+provide+safe (frequency-hash xs)
|
|
|
|
(list? . -> . hash?)
|
|
|
|
(list? . -> . hash?)
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
@ -100,41 +98,36 @@
|
|
|
|
counter)
|
|
|
|
counter)
|
|
|
|
|
|
|
|
|
|
|
|
(define (->list x)
|
|
|
|
(define (->list x)
|
|
|
|
(cond
|
|
|
|
(match x
|
|
|
|
[(list? x) x]
|
|
|
|
[(? list? x) x]
|
|
|
|
[(vector? x) (vector->list x)]
|
|
|
|
[(? vector?) (vector->list x)]
|
|
|
|
[(string? x) (string->list x)]
|
|
|
|
[(? string?) (string->list x)]
|
|
|
|
[else (error '->list)]))
|
|
|
|
[else (raise-argument-error '->list "item that can be converted to list" x)]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (members-unique? x)
|
|
|
|
(define+provide+safe (members-unique? x)
|
|
|
|
((or/c list? vector? string?) . -> . boolean?)
|
|
|
|
((or/c list? vector? string?) . -> . boolean?)
|
|
|
|
(let ([x (->list x)])
|
|
|
|
(match (->list x)
|
|
|
|
(cond
|
|
|
|
[(? list? x) (= (length (remove-duplicates x)) (length x))]
|
|
|
|
[(list? x) (= (length (remove-duplicates x)) (length x))]
|
|
|
|
[_ (raise-argument-error 'members-unique? "list, vector, or string" x)]))
|
|
|
|
[else (error (format "members-unique? cannot be determined for ~a" x))])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (members-unique?/error x)
|
|
|
|
(define+provide+safe (members-unique?/error x)
|
|
|
|
((or/c list? vector? string?) . -> . boolean?)
|
|
|
|
((or/c list? vector? string?) . -> . boolean?)
|
|
|
|
(define result (members-unique? x))
|
|
|
|
(match (members-unique? x)
|
|
|
|
(if (not result)
|
|
|
|
[(== #false)
|
|
|
|
(let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x))
|
|
|
|
(define duplicate-keys (filter values (hash-map (frequency-hash (->list x))
|
|
|
|
(λ(element freq) (if (> freq 1) element '()))))])
|
|
|
|
(λ (element freq) (and (> freq 1) element)))))
|
|
|
|
(error (string-append "members-unique? failed because " (if (= (length duplicate-keys) 1)
|
|
|
|
(error (string-append "members-unique? failed because " (if (= (length duplicate-keys) 1)
|
|
|
|
"item isn't"
|
|
|
|
"item isn't"
|
|
|
|
"items aren't") " unique:") duplicate-keys))
|
|
|
|
"items aren't") " unique:") duplicate-keys)]
|
|
|
|
result))
|
|
|
|
[result result]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(provide+safe values->list)
|
|
|
|
(provide+safe values->list)
|
|
|
|
(define-syntax (values->list stx)
|
|
|
|
(define-syntax (values->list stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
(syntax-case stx ()
|
|
|
|
[(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
|
|
|
|
[(_ VALUES-EXPR) #'(call-with-values (λ () VALUES-EXPR) list)]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (sublist xs i j)
|
|
|
|
(define+provide+safe (sublist xs i j)
|
|
|
|
(list? index? index? . -> . list?)
|
|
|
|
(list? exact-nonnegative-integer? exact-nonnegative-integer? . -> . list?)
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
(raise-argument-error 'sublist "list?" xs))
|
|
|
|
(raise-argument-error 'sublist "list?" xs))
|
|
|
|
(cond
|
|
|
|
(cond
|
|
|
|
@ -142,28 +135,26 @@
|
|
|
|
[(>= j i) (for/list ([(x idx) (in-indexed xs)]
|
|
|
|
[(>= j i) (for/list ([(x idx) (in-indexed xs)]
|
|
|
|
#:when (<= i idx (sub1 j)))
|
|
|
|
#:when (<= i idx (sub1 j)))
|
|
|
|
x)]
|
|
|
|
x)]
|
|
|
|
[else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))]))
|
|
|
|
[else (raise-argument-error 'sublist (format "starting index larger than ending index" (list i j)))]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (break-at xs bps-in)
|
|
|
|
(define+provide+safe (break-at xs bps)
|
|
|
|
|
|
|
|
(list? any/c . -> . list-of-lists?)
|
|
|
|
(list? any/c . -> . list-of-lists?)
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
(raise-argument-error 'break-at "list?" xs))
|
|
|
|
(raise-argument-error 'break-at "list" xs))
|
|
|
|
(let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list
|
|
|
|
(define bps ((if (list? bps-in) values list) bps-in))
|
|
|
|
(when (ormap (λ (bp) (>= bp (length xs))) bps)
|
|
|
|
(when (ormap (λ (bp) (<= (length xs) bp)) bps)
|
|
|
|
(raise-argument-error 'break-at
|
|
|
|
(raise-argument-error 'break-at
|
|
|
|
(format "breakpoints not greater than or equal to input list length = ~a" (length xs)) bps))
|
|
|
|
(format "breakpoints not greater than or equal to input list length = ~a" (length xs)) bps))
|
|
|
|
(when (not (increasing-nonnegative-list? bps))
|
|
|
|
(unless (increasing-nonnegative-list? bps)
|
|
|
|
(raise-argument-error 'break-at "increasing-nonnegative-list?" bps))
|
|
|
|
(raise-argument-error 'break-at "increasing-nonnegative-list" bps))
|
|
|
|
;; easier to do back to front, because then the list index for each item won't change during the recursion
|
|
|
|
;; easier to do back to front, because then the list index for each item won't change during the recursion
|
|
|
|
;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition
|
|
|
|
;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition
|
|
|
|
;; because breaking at zero means we've reached the start of the list
|
|
|
|
;; because breaking at zero means we've reached the start of the list
|
|
|
|
(let loop ([xs xs][bps (reverse (cons 0 bps))][acc empty])
|
|
|
|
(let loop ([xs xs][bps (reverse (cons 0 bps))][acc empty])
|
|
|
|
(if (zero? (car bps))
|
|
|
|
(match bps
|
|
|
|
(cons xs acc) ; return whatever's left, because no more splits are possible
|
|
|
|
[(cons (? zero?) _) (cons xs acc)] ; return whatever's left, because no more splits are possible
|
|
|
|
(let-values ([(head tail) (split-at xs (car bps))])
|
|
|
|
[_ (match/values (split-at xs (car bps))
|
|
|
|
(loop head (cdr bps) (cons tail acc)))))))
|
|
|
|
[(head tail) (loop head (cdr bps) (cons tail acc))])])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (shift-base xs how-far fill-item cycle caller)
|
|
|
|
(define (shift-base xs how-far fill-item cycle caller)
|
|
|
|
(unless (list? xs)
|
|
|
|
(unless (list? xs)
|
|
|
|
@ -171,45 +162,35 @@
|
|
|
|
(define abs-how-far (if cycle
|
|
|
|
(define abs-how-far (if cycle
|
|
|
|
(modulo (abs how-far) (length xs))
|
|
|
|
(modulo (abs how-far) (length xs))
|
|
|
|
(abs how-far)))
|
|
|
|
(abs how-far)))
|
|
|
|
|
|
|
|
(define (make-fill thing) (if cycle thing (make-list abs-how-far fill-item)))
|
|
|
|
(cond
|
|
|
|
(cond
|
|
|
|
[(> abs-how-far (length xs))
|
|
|
|
[(> abs-how-far (length xs))
|
|
|
|
(raise-argument-error caller
|
|
|
|
(raise-argument-error caller
|
|
|
|
(format "index not larger than list length ~a" (length xs))
|
|
|
|
(format "index not larger than list length ~a" (length xs))
|
|
|
|
(* (if (eq? caller 'shift-left) -1 1) how-far))]
|
|
|
|
(* (if (eq? caller 'shift-left) -1 1) how-far))]
|
|
|
|
[(= how-far 0) xs]
|
|
|
|
[(zero? how-far) xs]
|
|
|
|
[(positive? how-far)
|
|
|
|
[(positive? how-far)
|
|
|
|
(define-values (head tail) (split-at-right xs abs-how-far))
|
|
|
|
(match/values (split-at-right xs abs-how-far)
|
|
|
|
(define filler (if cycle
|
|
|
|
[(head tail) (append (make-fill tail) head)])]
|
|
|
|
tail
|
|
|
|
|
|
|
|
(make-list abs-how-far fill-item)))
|
|
|
|
|
|
|
|
(append filler head)]
|
|
|
|
|
|
|
|
[else ; how-far is negative
|
|
|
|
[else ; how-far is negative
|
|
|
|
(define-values (head tail) (split-at xs abs-how-far))
|
|
|
|
(match/values (split-at xs abs-how-far)
|
|
|
|
(define filler (if cycle
|
|
|
|
[(head tail) (append tail (make-fill head))])]))
|
|
|
|
head
|
|
|
|
|
|
|
|
(make-list abs-how-far fill-item)))
|
|
|
|
|
|
|
|
(append tail filler)]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (shift xs how-far [fill-item #f] [cycle #f])
|
|
|
|
(define+provide+safe (shift xs how-far [fill-item #f] [cycle #f])
|
|
|
|
((list? integer?) (any/c boolean?) . ->* . list?)
|
|
|
|
((list? integer?) (any/c boolean?) . ->* . list?)
|
|
|
|
(shift-base xs how-far fill-item cycle 'shift))
|
|
|
|
(shift-base xs how-far fill-item cycle 'shift))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (shift-left xs how-far [fill-item #f] [cycle #f])
|
|
|
|
(define+provide+safe (shift-left xs how-far [fill-item #f] [cycle #f])
|
|
|
|
((list? integer?) (any/c boolean?) . ->* . list?)
|
|
|
|
((list? integer?) (any/c boolean?) . ->* . list?)
|
|
|
|
(shift-base xs (- how-far) fill-item cycle 'shift-left))
|
|
|
|
(shift-base xs (- how-far) fill-item cycle 'shift-left))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (shift-cycle xs how-far)
|
|
|
|
(define+provide+safe (shift-cycle xs how-far)
|
|
|
|
(list? integer? . -> . list?)
|
|
|
|
(list? integer? . -> . list?)
|
|
|
|
(shift-base xs how-far #f #t 'shift-cycle))
|
|
|
|
(shift-base xs how-far #false #true 'shift-cycle))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (shift-left-cycle xs how-far)
|
|
|
|
(define+provide+safe (shift-left-cycle xs how-far)
|
|
|
|
(list? integer? . -> . list?)
|
|
|
|
(list? integer? . -> . list?)
|
|
|
|
(shift-base xs (- how-far) #f #t 'shift-left-cycle))
|
|
|
|
(shift-base xs (- how-far) #false #true 'shift-left-cycle))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (shifts xs how-fars [fill-item #f] [cycle #f])
|
|
|
|
(define+provide+safe (shifts xs how-fars [fill-item #f] [cycle #f])
|
|
|
|
((list? integers?) (any/c boolean?) . ->* . (listof list?))
|
|
|
|
((list? integers?) (any/c boolean?) . ->* . (listof list?))
|
|
|
|
@ -217,7 +198,6 @@
|
|
|
|
(raise-argument-error 'shifts "list?" xs))
|
|
|
|
(raise-argument-error 'shifts "list?" xs))
|
|
|
|
(map (λ (how-far) (shift xs how-far fill-item cycle)) how-fars))
|
|
|
|
(map (λ (how-far) (shift xs how-far fill-item cycle)) how-fars))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide+safe (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f])
|
|
|
|
(define+provide+safe (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f])
|
|
|
|
((list? (or/c integers? integer?)) (any/c boolean?) . ->* . any)
|
|
|
|
((list? (or/c integers? integer?)) (any/c boolean?) . ->* . any)
|
|
|
|
(apply values ((if (list? shift-amount-or-amounts)
|
|
|
|
(apply values ((if (list? shift-amount-or-amounts)
|
|
|
|
|
