diff --git a/lens/list/list-ref-take-drop.rkt b/lens/list/list-ref-take-drop.rkt index 1a81b0a..b01500e 100644 --- a/lens/list/list-ref-take-drop.rkt +++ b/lens/list/list-ref-take-drop.rkt @@ -2,22 +2,29 @@ (provide (contract-out - [list-ref-lens (-> exact-nonnegative-integer? lens?)] - [take-lens (-> exact-nonnegative-integer? lens?)] - [drop-lens (-> exact-nonnegative-integer? lens?)] - [first-lens lens?] - [second-lens lens?] - [third-lens lens?] - [fourth-lens lens?] - [fifth-lens lens?] - [sixth-lens lens?] - [seventh-lens lens?] - [eighth-lens lens?] - [ninth-lens lens?] - [tenth-lens lens?])) + [list-ref-lens + (->i ([i exact-nonnegative-integer?]) + [lens (i) (lens/c (list*-length-at-least/c (add1 i)) any/c)])] + [take-lens + (->i ([i exact-nonnegative-integer?]) + [lens (i) (lens/c (list*-length-at-least/c (add1 i)) any/c)])] + [drop-lens + (->i ([i exact-nonnegative-integer?]) + [lens (i) (lens/c (list*-length-at-least/c (add1 i)) any/c)])] + [first-lens (lens/c (list*-length-at-least/c 1) any/c)] + [second-lens (lens/c (list*-length-at-least/c 2) any/c)] + [third-lens (lens/c (list*-length-at-least/c 3) any/c)] + [fourth-lens (lens/c (list*-length-at-least/c 4) any/c)] + [fifth-lens (lens/c (list*-length-at-least/c 5) any/c)] + [sixth-lens (lens/c (list*-length-at-least/c 6) any/c)] + [seventh-lens (lens/c (list*-length-at-least/c 7) any/c)] + [eighth-lens (lens/c (list*-length-at-least/c 8) any/c)] + [ninth-lens (lens/c (list*-length-at-least/c 9) any/c)] + [tenth-lens (lens/c (list*-length-at-least/c 10) any/c)])) (require racket/list fancy-app + "../util/improper-list-length.rkt" "../base/main.rkt" "car-cdr.rkt") diff --git a/lens/util/improper-list-length.rkt b/lens/util/improper-list-length.rkt new file mode 100644 index 0000000..7122120 --- /dev/null +++ b/lens/util/improper-list-length.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(provide list*-length + list*-length-at-least/c + ) + +(require racket/contract/base) +(module+ test + (require rackunit)) + +(define (list*-length lst) + (let loop ([len 0] [lst lst]) + (cond [(pair? lst) + (loop (add1 len) (cdr lst))] + [else len]))) + +(define (list*-length-at-least/c i) + (define (pred lst) + (let loop ([i i] [lst lst]) + (cond [(<= i 0) #t] + [(pair? lst) (loop (sub1 i) (cdr lst))] + [else #f]))) + (flat-named-contract + `(list*-length-at-least/c ,i) + pred)) + +(module+ test + (check-equal? (list*-length '()) 0) + (check-equal? (list*-length '(a)) 1) + (check-equal? (list*-length '(a b)) 2) + (check-equal? (list*-length '(a b c)) 3) + (check-equal? (list*-length "whatever") 0) + (check-equal? (list*-length 'a) 0) + (check-equal? (list*-length '(a . b)) 1) + (check-equal? (list*-length '(a b . c)) 2) + (check-equal? (list*-length '(a b c . d)) 3) + (check-true ((list*-length-at-least/c 0) 'a)) + (check-false ((list*-length-at-least/c 1) 'a)) + (check-true ((list*-length-at-least/c 1) '(a . b))) + (check-false ((list*-length-at-least/c 2) '(a . b))) + (check-true ((list*-length-at-least/c 2) '(a b . c))) + (check-false ((list*-length-at-least/c 3) '(a b . c))) + (check-true ((list*-length-at-least/c 3) '(a b c . d))) + (check-false ((list*-length-at-least/c 4) '(a b c . d))) + )