swap.scm

;
; swap (JScheme)
;

(use-module "elf/iterate.scm")

(define (%drf-h ptr)
  (values (lambda () (car ptr)) (lambda (val) (set-car! ptr val))))
(define (%drf-t ptr)
  (values (lambda () (cdr ptr)) (lambda (val) (set-cdr! ptr val))))
(define %table (Hashtable.))
(for-each (lambda (item-core)
            (.put %table (string->symbol {ca[item-core]r})
                  `(,%drf-h ,(eval (string->symbol {c[item-core]r}))))
            (.put %table (string->symbol {cd[item-core]r})
                  `(,%drf-t ,(eval (string->symbol {c[item-core]r})))))
          (let* ((ones '(a d))
                 (twos (foldL ones (lambda (o ts) `((a . ,o) (d . ,o) . ,ts))
                              ones)))
            (foldL twos (lambda (t ts) `((a . ,t) (d . ,t) . ,ts)) twos)))
(.put %table 'second (.get %table 'cadr  ))
(.put %table 'third  (.get %table 'caddr ))
(.put %table 'fourth (.get %table 'cadddr))

(define-method (accessor+modifier (col Pair) key)
  (case key ((car first) (%drf-h col)) ((cdr rest) (%drf-t col))
    (else
     (let ((it (.get %table key)))
       (if (!isNull it) ((car it) ((cadr it) col))
         (%drf-h (list-tail col (case key
                                  ((fifth ) 4) ((sixth) 5) ((seventh) 6)
                                  ((eighth) 7) ((ninth) 8) ((tenth  ) 9)
                                  (else key)))))))))

(define-method (accessor+modifier (col Object[]) key)
  (values (lambda () (vector-ref col key))
          (lambda (val) (vector-set! col key val))))

(define-method (accessor+modifier (col Procedure) key) (col key))

(define-method (accessor+modifier (col List) key)
  (values (lambda () (.get col key)) (lambda (val) (.set col key val))))

(define-method (accessor+modifier (col Map) key)
  (values (lambda () (.get col key)) (lambda (val) (.put col key val))))

(define-method (accessor+modifier (col ListIterator) key)
  (values (case key
            ((previous) (lambda () (.previous col) (.next col)))
            ((next    ) (lambda () (.next col) (.previous col)))
            (else (E.error {(ListIterator)Invalid key: [key]\n})))
          (lambda (val) (.set col val))))

(define-method (accessor+modifier (col Object) key)
  (if (.isArray (.getClass col))
    (values (lambda () (java.lang.reflect.Array.get col key))
            (lambda (val) (java.lang.reflect.Array.set col key val)))
    (E.error {(java.lang.reflect.Array)Invalid type: [(.getClass col)]\n})))

; 簡易版 let*-values
(define-macro (let*-values bindings expr . exprs)
  (car (foldL (reverse bindings)
              (lambda (binding result)
                `((call-with-values (lambda () ,(second binding))
                                    (lambda ,(first binding) . ,result))))
              `(,expr . ,exprs))))

(define (%raw-swap! col1 key1 col2 key2)
  (let*-values (((access1 modify1!) (accessor+modifier col1 key1))
                ((access2 modify2!) (accessor+modifier col2 key2))
                ((temp) (access1)))
    (modify1! (access2)) (modify2! temp)))

(define-method (collection-swap! col1 key1 col2 key2)
  (%raw-swap! col1 key1 col2 key2))

(define-method (collection-swap! (col1 Pair) (key1 Integer)
                                 (col2 Pair) (key2 Integer))
  (if (eq? col1 col2)
    (let*-values (((col key) (if (< key1 key2)
                               (values (list-tail col1 key1) (- key2 key1))
                               (values (list-tail col2 key2) (- key1 key2)))))
      (%raw-swap! col 'car col key))
    (%raw-swap! col1 key1 col2 key2)))

(define-macro (swap! x y)
  (define temp    (string->symbol {[x][y]>}))
  (define access  (string->symbol {<[x][y]}))
  (define modify! (string->symbol {<[x][y]>}))

  (if (pair? x)
    (if (pair? y) `(collection-swap! ,@x . ,y)
      `(let*-values (((,temp) ,y) ((,access ,modify!) (accessor+modifier . ,x)))
         (set! ,y (,access)) (,modify! ,temp)))
    (if (pair? y) `(swap! ,y ,x)
      `(let ((,temp ,x)) (set! ,x ,y) (set! ,y ,temp)))))

; (begin
;   (define error E.error) ; assert のメッセージを表示するため
; 
;   (define 辞書
;     '((うさぎ . hare) (いぬ . bear) (ねこ . squirrel) (りす . rabbit)))
;   (define うさぎs '#(bunny mouse cat))
;   (define くま 'lapin) (define ねずみ 'dog)
; 
;   (swap! くま (うさぎs 1)) (swap! (辞書 'cdadr) ねずみ) (swap! くま ねずみ)
;   (assert (and (eq? くま 'bear) (eq? ねずみ 'mouse)))
; 
;   (define (編集 見出し) (accessor+modifier (assq 見出し 辞書) 'cdr))
; 
;   (swap! (うさぎs 2) (編集 'りす)) (swap! (編集 'ねこ) (編集 'りす))
;   (swap! (辞書 0) (辞書 'second))
;   (assert
;     (equal? 辞書
;             '((いぬ . dog) (うさぎ . hare) (ねこ . cat) (りす . squirrel))))
;   (assert (equal? うさぎs '#(bunny lapin rabbit))))