Groups | Search | Server Info | Login | Register

Groups > comp.lang.scheme > #6571

Re: map-plist

Cross-posted to 2 groups.

Show all headers | View raw

B. Pym wrote:

> Pascal Bourguignon wrote:
> 
> >  (defun map-plist (fun plist)
> >    (loop :for (key value) on plist by #'cddr
> >              :collect (funcall fun key value))
> > 
> ...
> > 
> > Then you can write:
> > 
> > (map-plist (lambda (k v) (cons k (1+ v))) '(one 1 two 2 three 3))
> 
> Gauche Scheme
> 
> (use util.match)   ;; match-lambda
> (use gauche.lazy)  ;; lslices
> 
> (map
>   (match-lambda [(k v) (cons k (+ 1 v))])
>   (lslices '(one 1 two 2 three 3) 2))
> 
>   ===>
> ((one . 2) (two . 3) (three . 4))

Gauche Scheme

(define (map-plist fun plist)
  (let1 r '()
    (do-plist ((k v) plist) (push! r (fun k v)))
    (reverse r)))

(map-plist (^(k v) (cons k (+ 1 v))) '(c 3  d 8))
  ===>
((c . 4) (d . 9))

Another way:

;; "!" is similar to "do".
(define (map-plist fun plist)
  (! (r cons (fun k v)
      (k v) :on plist :by cddr)))

Given:

(define (!-flatten it)
  (if (null? it) '()
    (if (pair? it)
      (append (flatten (car it)) (flatten (cdr it)))
      (list it))))

(define-syntax !-aux
  (syntax-rules (<> @ @@  + -  :  cons append :meld
                 cdr  :in :across :along
                 :on :by :pop-or-nothing
                 :if :if-else  !  :also? :also :to :repeat
                 :till  :always
                 ->lets :let := )
    [(_ specs seen lets @)
     (!-aux specs seen lets #f @) ]
    [(_ (->lets ((id val) ...)  z ...) seen (lets ...) stuff ...)
     (!-aux (z ...) seen (lets ... (id val) ...) stuff ...) ]
    [(_ (:let id val  z ...)  stuff ...)
     (!-aux (->lets ((id val))  z ...)  stuff ...) ]
    [(_ (:= id val  z ...)  stuff ...)
     (!-aux (:let id #f  dummy #f (set! id val)  z ...)  stuff ...) ]
    ;;
    [(_ (:also? bool op x  z ...) (seen ... (v i update)) stuff ...)
     (!-aux (z ...)
       (seen ...  (v i (if bool (op x update) update)))
       stuff ...) ]
    [(_ (:also op x  z ...)  stuff ...)
     (!-aux (:also? #t op x  z ...)  stuff ...) ]
    ;;
    [(_ ((:pop-or-nothing x xs nil)  z ...)  stuff ...)
     (!-aux (x (if (pair? xs)(pop! xs) nil) <>    z ...)  stuff ...) ]
    ;;
    ;;
    [(_ (:always expr   z ...) seen lets bool)
     (!-aux (ok #t expr
             :till (not ok)
             z ...)
            seen lets bool ok
         ) ]
    [(_ (:always expr   z ...) stuff ...)
     (!-aux " * * * Bad usage of :always in !") ]
    [(_ (:till expr   z ...) seen lets #f stuff ...)
     (!-aux (z ...) seen lets expr  stuff ...) ]
    [(_ (:till expr   z ...) seen lets bool stuff ...)
     (!-aux (z ...) seen lets (or expr bool) stuff ...) ]
    ;;
    [(_ (:if bool  z ...) (seen ... (v i u)) stuff ...)
     (!-aux (z ...)
       (seen ... (v i (if bool u v))) stuff ...) ]
    ;;
    [(_ (:if-else bool  z ...) (seen ... (a b c)(d e f)) stuff ...)
     (!-aux (:let yes #f  z ...)
       (seen ... (a b (begin (set! yes bool) (if yes c a)))
                 (d e (if (not yes) f d)))  stuff ...) ]
    ;;
    [(_ ((a b ...) :on lst :by kdr  z ...) stuff ...)
     (!-aux (:let xs lst
             :let ys #f
             exhausted (null? xs) <>
             dummy (begin (set! ys xs) 
                     (when (pair? xs) (set! xs (kdr xs)))) <>
             (:pop-or-nothing a ys #f)
             (:pop-or-nothing b ys #f) ...
             :till exhausted
             z ...)   stuff ...) ]
    [(_ ((a b ...) :on lst   z ...) stuff ...)
     (!-aux ((a b ...) :on lst :by cdr   z ...) stuff ...) ]
    ;;
    [(_ ((c d ...) :in lst  z ...) stuff ...)
     (!-aux (->lets ((xs lst) (c #f) (d #f) ...)
             dummy (if (pair? xs)
                     (set!-values (c d ...)(apply values (!-flatten(pop! xs))))
                     (set! c !-aux))  <>
             :till (eq? c !-aux)
             z ...)  stuff ...) ]
    [(_ (x :in lst  z ...) stuff ...)
     (!-aux (:let xs lst
             x (if (pair? xs)(pop! xs) !-aux) <>
             :till (eq? x !-aux)
             z ...)   stuff ...) ]
    ;;
    [(_ (x :across vec  z ...)  stuff ...)
     (!-aux (:let v vec  :let i 0
             x (if (< i (vector-length v))
                     (begin0 (vector-ref v i) (inc! i))
                     !-aux) <>
             :till (eq? x !-aux)
             z ...)  stuff ...) ]
    [(_ (ch :along str  z ...) stuff ...)
     (!-aux (:let s str  :let i 0
             ch (and (< i (string-length s))
                    (begin0 (string-ref s i) (inc! i))) <>
             :till (not ch)
             z ...)
        stuff ...) ]
    [(_ (a b <>  z ...)  stuff ...)
     (!-aux (a b b  z ...)  stuff ...) ]
    ;;
    [(_ (a b +  z ...) stuff ...)
     (!-aux (a b (+ 1 a) z ...)  stuff ...) ]
    [(_ (a + n  z ...)  stuff ...)
     (!-aux (a 0 (+ n a) z ...)  stuff ...) ]
    [(_ (a b -  z ...)  stuff ...)
     (!-aux (a b (- a 1) z ...)  stuff ...) ]
    [(_ (n lo inc :to hi   z ...) stuff ...)
     (!-aux (:let step inc  :let high hi
             n lo (+ n step)
             :till (> n high)
             z ...) stuff ...) ]
    [(_ (n lo :to hi   z ...) stuff ...)
     (!-aux (n lo 1 :to hi   z ...) stuff ...) ]
    [(_ (:repeat n   z ...) stuff ...)
     (!-aux (m 1 :to n   z ...) stuff ...) ]
    ;;
    [(_ (v init : kons u   z ...) stuff ...)
     (!-aux (v init (kons u v) z ...) stuff ...) ]
    ;;
    [(_ (a cons b   z ...) stuff ...)
     (!-aux (a '() : cons b  z ...) stuff ...) ]
    [(_ (a append b   z ...) stuff ...)
     (!-aux (a '() : append (reverse b)  z ...) stuff ...) ]
    [(_ (a :meld b   z ...) stuff ...)
     (!-aux (a '()
         (if (pair? b) (append (reverse b) a)
                       (cons b a))
         z ...) stuff ...) ]
    ;;
    [(_ (a b cdr   z ...)  stuff ...)
     (!-aux (a b (cdr a) z ...)  stuff ...) ]
    [(_ (a b c  z ...) (seen ...) stuff ...)
     (!-aux (z ...) (seen ... (a b c)) stuff ...) ]
    [(_ (a b) (seen ...) stuff ...)
     (!-aux () (seen ... (a b)) stuff ...) ]
    [(_ (a) (seen ...) stuff ...)
     (!-aux () (seen ... (a '())) stuff ...) ]
    ;;  Default action is print first variable.
    [(_ () ((a b c) z ...) lets bool !)
     (!-aux () ((a b c) z ...) lets bool ! print a) ]
     ;; (!-aux () ((a b c) z ...) lets bool ! begin (print a)(sys-sleep 1)) ]
    [(_ () seen lets bool ! action ...)
     (!-aux () seen lets bool #t (action ...)) ]
    ;;  If result not specified, pick one.
    [(_ () ((a b c) z ...) lets bool)
     (!-aux () ((a b c) z ...) lets bool
       (if (pair? a) (reverse a) a)) ]
    [(_ () ((a b c) z ...) lets bool @)
     (!-aux () ((a b c) z ...) lets bool (reverse a)) ]
    [(_ () seen lets bool @ result stuff ...)
     (!-aux () seen lets bool (reverse result) stuff ...) ]
    ;;
    [(_ () seen lets bool @@ (what x ...) stuff ...)
     (!-aux () seen lets bool (what (reverse x) ...) stuff ...) ]
    [(_ () seen lets bool (what @ x z ...) stuff ...)
     (!-aux () seen lets bool (what (reverse x) z ...) stuff ...) ]
    [(_ () seen lets bool (what x @ y z ...) stuff ...)
     (!-aux () seen lets bool (what x (reverse y) z ...) stuff ...) ]
    ;;
    [(_ () ((a b c) z ...) lets 0 stuff ...)
     (!-aux () ((a b c) z ...) lets (= 0 a) stuff ...) ]
    [(_ () seen lets bool result stuff ...)
     (let lets (do seen (bool result) stuff ...)) ]
  ))
(define-syntax !
  (syntax-rules ()
    [(_ specs bool stuff ...)
     (!-aux specs () () bool stuff ...) ]
    [(_ specs) (! specs #f) ]
  ))

Back to comp.lang.scheme | Previous | Next — Previous in thread | Find similar

Thread

map-plist "B. Pym" <Nobody447095@here-nor-there.org> - 2025-07-02 03:35 +0000
  Re: map-plist "B. Pym" <Nobody447095@here-nor-there.org> - 2025-08-30 22:39 +0000

csiph-web