From a1f19076063b33050cc5ec0983060e4385619c3f Mon Sep 17 00:00:00 2001 From: Alex Knauth Date: Tue, 19 Jul 2016 23:22:37 -0400 Subject: [PATCH] add append*-lens (#272) --- lens/private/list/append.rkt | 133 +++++++++++++++++++++++++++++++++ lens/private/list/append.scrbl | 21 ++++++ unstable/lens/append.rkt | 2 + unstable/lens/main.rkt | 1 + unstable/lens/main.scrbl | 1 + 5 files changed, 158 insertions(+) create mode 100644 lens/private/list/append.rkt create mode 100644 lens/private/list/append.scrbl create mode 100644 unstable/lens/append.rkt diff --git a/lens/private/list/append.rkt b/lens/private/list/append.rkt new file mode 100644 index 0000000..3ffbdde --- /dev/null +++ b/lens/private/list/append.rkt @@ -0,0 +1,133 @@ +#lang racket/base + +(provide append*-lens append*n-lens) + +(require lens racket/match racket/list) + +(module+ test + (require rackunit syntax/parse lens/private/test-util/test-lens)) + +;; restore-structure : (Listof (Listof A)) (Listof B) -> (Listof (Listof B)) +;; Takes a list of lists and a list and un-flattens the flattened +;; argument according to the structure of the structure arguement. +;; The length of the flattened list must be the same as the length +;; of (append* structure). +(define (restore-structure structure flattened) + (match structure + [(list) + (unless (empty? flattened) + (error 'append*-lens "flattened list is too long to match the structure")) + structure] + [(cons s-lst s-rst) + (define-values [f-lst f-rst] + (split-at flattened (length s-lst))) + (cons f-lst (restore-structure s-rst f-rst))])) + +;; append*-lens : (Lens (Listof (Listof Any)) (Listof Any)) +;; where the only valid views are lists with the same length as the +;; result of applying append* to the target. +(define append*-lens + (make-lens + append* + restore-structure)) + +(define (append*n-lens n) + (apply lens-thrush (make-list n append*-lens))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module+ test + (test-case "append*-lens" + (check-equal? (lens-view append*-lens (list (list 1) (list 2 3) (list))) + (list 1 2 3)) + (check-equal? (lens-set append*-lens + (list (list 1) (list 2 3) (list)) + (list 'a 'b 'c)) + (list (list 'a) (list 'b 'c) (list))) + + (check-equal? (lens-transform append*-lens + (list (list 1) (list 2 3) (list)) + (lambda (lst) + ;; a length-preserving computation + (let loop ([acc (list)] [sum 0] [lst lst]) + (match lst + [(list) (reverse acc)] + [(cons fst rst) + (loop (cons (+ sum fst) acc) + (+ sum fst) + rst)])))) + (list (list 1) (list 3 6) (list))) + + (check-equal? (lens-transform append*-lens + (list (list #'(+ a)) (list #'(- a b) #'(* c d)) (list)) + (lambda (lst) + ;; a length-preserving computation + (syntax-parse + (expand #`(#%expression (λ (a b c d) (#%app list #,@lst)))) + #:literals (#%plain-lambda #%plain-app list) + [(#%expression (#%plain-lambda (x ...) (#%plain-app list e ...))) + (syntax->datum #'[e ...])]))) + (list (list '(#%app + a)) + (list '(#%app - a b) '(#%app * c d)) + (list))) + + (test-lens-laws append*-lens + (list (list 1) (list 2 3) (list)) + (list 'a 'b 'c) + (list "a" "b" "c")) + ) + + (test-case "append*n-lens" + (define append**-lens (append*n-lens 2)) + (define append***-lens (append*n-lens 3)) + + (check-equal? (lens-view append**-lens + (list (list (list) (list 1)) + (list (list 2 3)) + (list) + (list (list 4) (list) (list 5 6)))) + (list 1 2 3 4 5 6)) + (check-equal? (lens-set append**-lens + (list (list (list) (list 1)) + (list (list 2 3)) + (list) + (list (list 4) (list) (list 5 6))) + (list 'a 'b 'c 'd 'e 'f)) + (list (list (list) (list 'a)) + (list (list 'b 'c)) + (list) + (list (list 'd) (list) (list 'e 'f)))) + + (test-lens-laws append**-lens + (list (list (list) (list 1)) + (list (list 2 3)) + (list) + (list (list 4) (list) (list 5 6))) + (list 'a 'b 'c 'd 'e 'f) + (list "a" "b" "c" "d" "e" "f")) + + (check-equal? (lens-view append***-lens + (list (list (list) (list (list 1))) + (list (list (list) (list 2 3))) + (list) + (list (list (list 4) (list)) (list) (list (list 5 6))))) + (list 1 2 3 4 5 6)) + (check-equal? (lens-set append***-lens + (list (list (list) (list (list 1))) + (list (list (list) (list 2 3))) + (list) + (list (list (list 4) (list)) (list) (list (list 5 6)))) + (list 'a 'b 'c 'd 'e 'f)) + (list (list (list) (list (list 'a))) + (list (list (list) (list 'b 'c))) + (list) + (list (list (list 'd) (list)) (list) (list (list 'e 'f))))) + + (test-lens-laws append***-lens + (list (list (list) (list (list 1))) + (list (list (list) (list 2 3))) + (list) + (list (list (list 4) (list)) (list) (list (list 5 6)))) + (list 'a 'b 'c 'd 'e 'f) + (list "a" "b" "c" "d" "e" "f")) + )) diff --git a/lens/private/list/append.scrbl b/lens/private/list/append.scrbl new file mode 100644 index 0000000..06f1885 --- /dev/null +++ b/lens/private/list/append.scrbl @@ -0,0 +1,21 @@ +#lang scribble/manual + +@(require "../doc-util/main.rkt") + +@title{Flattening and unflattening lists} + +@defthing[append*-lens lens?]{ +A lens that flattens a list one-level down when viewing, and restores +the original structure when setting. +@lens-unstable-examples[ + (lens-view append*-lens '((a) (b c) () (d e f))) + (lens-set append*-lens '((a) (b c) () (d e f)) '(1 2 3 4 5 6)) +]} + +@defproc[(append*n-lens [n exact-nonnegative-integer?]) lens?]{ +Creates a lens that flattens a list @racket[n] levels down when +viewing, and restores the original structure when setting. +@lens-unstable-examples[ + (lens-view (append*n-lens 2) '(((a) ()) (() (b) (c)) () ((d e) () (f)))) + (lens-set (append*n-lens 2) '(((a) ()) (() (b) (c)) () ((d e) () (f))) '(1 2 3 4 5 6)) +]} diff --git a/unstable/lens/append.rkt b/unstable/lens/append.rkt new file mode 100644 index 0000000..7761da2 --- /dev/null +++ b/unstable/lens/append.rkt @@ -0,0 +1,2 @@ +#lang reprovide +lens/private/list/append diff --git a/unstable/lens/main.rkt b/unstable/lens/main.rkt index 1d96d85..45b932d 100644 --- a/unstable/lens/main.rkt +++ b/unstable/lens/main.rkt @@ -1,4 +1,5 @@ #lang reprovide +"append.rkt" "arrow.rkt" "define-nested.rkt" "dict-nested.rkt" diff --git a/unstable/lens/main.scrbl b/unstable/lens/main.scrbl index 034496d..001da69 100644 --- a/unstable/lens/main.scrbl +++ b/unstable/lens/main.scrbl @@ -12,6 +12,7 @@ may change in future releases. Do not depend on this library being backwards-compatible. @(include-sections + (lib "lens/private/list/append.scrbl") "arrow.scrbl" "define-nested.scrbl" "dict-nested.scrbl"