;;;
  BOF
;;;

;; Lazy Segment Tree
;; Reference:
;; - -library/document_ja/lazysegtree.html

(defpackage lazy-segment-tree
  (:use #:cl)
  (:nicknames #:lseg)
  (:export #:make-lazy-segment-tree
           #:fold
           #:ref
           #:update!
           #:compile-fold
           #:compile-ref
           #:compile-update!))

(in-package #:lseg)

(defstruct ops
  (op nil :type function)
  (op-id nil :type function)
  (mapping nil :type function)
  (map-id nil :type function)
  (composition nil :type function))

(defmacro _f (op place &rest args)
  (multiple-value-bind (vars varvs res setter accessor)
      (get-setf-expansion place)
    `(let* (,@(mapcar #'list vars varvs)
            (,(car res) (,op ,accessor ,@args)))
       ,setter)))

(defmacro ashf (place count)
  `(_f ash ,place ,count))

(defstruct (lazy-segment-tree (:conc-name lseg-)
                              (:constructor %%make-lseg))
  (data nil :type (simple-array fixnum 1))
  (lazy nil :type (simple-array fixnum 1))
  (base-length nil :type fixnum)
  (size nil :type fixnum)
  (ops nil :type ops))

(defmacro with-aliases (&body body)
  `(symbol-macrolet ((data (lseg-data lseg))
                     (lazy (lseg-lazy lseg))
                     (base-length (lseg-base-length lseg))
                     (size (lseg-size lseg))
                     (ops (lseg-ops lseg))
                     (op-id (ops-op-id ops))
                     (op (ops-op ops))
                     (mapping (ops-mapping ops))
                     (map-id (ops-map-id ops))
                     (composition (ops-composition ops)))
     ,@body))

(defun get-base-length (size)
  (let ((res 1))
    (loop :until (>= res size)
          :do (ashf res 1))
    res))

(defun %get-routes-for-accumulate (base-length l r)
  (declare (fixnum l r base-length))
  (incf l base-length)
  (incf r base-length)
  (let ((routes nil)
        (range 1))
    (declare (list routes)
             (fixnum range))
    (loop :while (< l r)
          :do (when (logbitp 0 l)
                (push (list l range :l)
                      routes)
                (incf l))
              (when (logbitp 0 r)
                (decf r)
                (push (list r range :r)
                      routes))
              (ashf l -1)
              (ashf r -1)
              (ashf range 1))
    (nreverse routes)))

(defun %get-routes-for-propagate (base-length l r)
  (declare (fixnum base-length l r))
  (let ((res nil)
        (l-range 1)
        (r-range 1))
    (declare (list res)
             (fixnum l-range r-range))
    (incf l base-length)
    (incf r base-length)
    (loop :until (logbitp 0 l)
          :do (ashf l -1)
              (ashf l-range 1))
    (loop :until (logbitp 0 r)
          :do (ashf r -1)
              (ashf r-range 1))
    (ashf l -1)
    (ashf l-range 1)
    (ashf r -1)
    (ashf r-range 1)
    (loop :while (> l 1)
          :do (push (list l l-range)
                    res)
              (ashf l -1)
              (ashf l-range 1))
    (loop :while (>= r 1)
          :do (push (list r r-range)
                    res)
              (ashf r -1)
              (ashf r-range 1))
    res))

(defun make-lazy-segment-tree (size &key init op op-id mapping map-id composition)
  (let* ((base-length (get-base-length size))
         (data-size (1+ (ash base-length 1)))
         (ops (make-ops :op op
                        :op-id op-id
                        :mapping mapping
                        :map-id map-id
                        :composition composition))
         (res (%%make-lseg :data (make-array data-size :element-type 'fixnum
                                                       :initial-element (funcall init))
                           :lazy (make-array data-size :element-type 'fixnum
                                                       :initial-element (funcall map-id))
                           :ops ops
                           :base-length base-length
                           :size size)))
    res))

(defun %compile-propagate! (lseg)
  (with-aliases
    (eval
     `(lambda (lseg index range)
        (symbol-macrolet ((data (lseg-data lseg))
                          (lazy (lseg-lazy lseg)))
          (symbol-macrolet ((acc (aref data index))
                            (lz (aref lazy index))
                            (l (aref lazy (ash index 1)))
                            (r (aref lazy (logior 1 (ash index 1)))))
            (unless (= lz (funcall ,map-id))
              ;; propagate lazy value to children
              (setf l
                    (funcall ,composition
                             (or l (funcall ,map-id))
                             lz))
              (setf r
                    (funcall ,composition
                             (or r (funcall ,map-id))
                             lz))
              (setf acc
                    (funcall ,mapping
                             acc
                             lz
                             range))
              ;; reset lazy value
              (setf lz (funcall ,map-id)))))))))

(declaim (inline %propagate!))
(defun %propagate! (lseg index range)
  (with-aliases
    (symbol-macrolet ((acc (aref data index))
                      (lz (aref lazy index))
                      (l (aref lazy (ash index 1)))
                      (r (aref lazy (logior 1 (ash index 1)))))
      (unless (= lz (funcall map-id))
        ;; propagate lazy value to children
        (setf l
              (funcall composition
                       (or l (funcall map-id))
                       lz))
        (setf r
              (funcall composition
                       (or r (funcall map-id))
                       lz))
        (setf acc
              (funcall mapping
                       acc
                       lz
                       range))
        ;; reset lazy value
        (setf lz (funcall map-id))))))

(defun compile-fold (lseg)
  (let ((propagate! (%compile-propagate! lseg)))
    (with-aliases
      (eval
       `(lambda (lseg l r)
          (with-aliases
            (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
                  (routes-for-accumulate (%get-routes-for-accumulate base-length l r))
                  (res (funcall ,op-id)))
              (declare (list routes-for-propagate routes-for-accumulate)
                       (fixnum res))
              ;; propagate lazy (top -> bottom)
              (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
                    :do (funcall ,propagate! lseg index range))
  accumulate acc and calculate answer ( direction does not matter )
              (loop :for (index range side) :of-type (fixnum fixnum (member :l :r)) :in routes-for-accumulate
                    :for acc :of-type fixnum := (aref data index)
                    :for lz :of-type fixnum := (aref lazy index)
                    :for calc-value :of-type fixnum := (funcall ,mapping acc lz range)
                    :for new-res :of-type fixnum := (ecase side
                                                      (:l (funcall ,op calc-value res))
                                                      (:r (funcall ,op res calc-value)))
                    :do (setf res new-res))
              res)))))))

(defun fold (lseg l r)
  (declare (fixnum l r))
  (with-aliases
    (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
          (routes-for-accumulate (%get-routes-for-accumulate base-length l r))
          (res (funcall op-id)))
      (declare (list routes-for-propagate routes-for-accumulate)
               (fixnum res))
      ;; propagate lazy (top -> bottom)
      (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
            :do (%propagate! lseg index range))
  accumulate acc and calculate answer ( direction does not matter )
      (loop :for (index range side) :of-type (fixnum fixnum (member :l :r)) :in routes-for-accumulate
            :for acc :of-type fixnum := (aref data index)
            :for lz :of-type fixnum := (aref lazy index)
            :for calc-value :of-type fixnum := (funcall mapping acc lz range)
            :for new-res :of-type fixnum := (ecase side
                                              (:l (funcall op calc-value res))
                                              (:r (funcall op res calc-value)))
            :do (setf res new-res))
      res)))

(declaim (inline ref))
(defun ref (lseg index)
  (fold lseg index (1+ index)))

(defun compile-ref (lseg)
  (let ((%fold (compile-fold lseg)))
    (eval
     `(lambda (lseg index)
        (funcall ,%fold lseg index (1+ index))))))

(declaim (inline %accumulate))
(defun %accumulate (lseg index range)
  (with-aliases
    (funcall mapping
             (aref data index)
             (aref lazy index)
             range)))

(defun %compile-accumulate (lseg)
  (with-aliases
    (eval
     `(lambda (lseg index range)
        (with-aliases
          (funcall ,mapping
                   (aref data index)
                   (aref lazy index)
                   range))))))

(declaim (notinline update!))
(defun update! (lseg l r value)
  (declare (fixnum l r value))
  (with-aliases
    (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
          (routes-for-accumulate (%get-routes-for-accumulate base-length l r)))
      (declare (list routes-for-propagate routes-for-accumulate))
      ;; propagate lazy (top -> bottom)
      (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
            :do (%propagate! lseg index range))
      ;; apply value to lazy (bottom -> top)
      (loop :for (index range _) :of-type (fixnum fixnum nil) :in routes-for-accumulate
            :do (setf (aref lazy index)
                      (funcall composition (aref lazy index) value)))
  update acc ( bottom - > top )
      (loop :for (index range) :of-type (fixnum fixnum) :in (nreverse routes-for-propagate)
            :for acc :of-type fixnum := (aref data index)
            :for l :of-type fixnum := (%accumulate lseg
                                                   (ash index 1)
                                                   (ash range -1))
            :for r :of-type fixnum := (%accumulate lseg
                                                   (logior 1 (ash index 1))
                                                   (ash range -1))
            :do (setf (aref data index)
                      (funcall op l r))))))

(defun compile-update! (lseg)
  (let ((%propagate! (%compile-propagate! lseg))
        (%accumulate (%compile-accumulate lseg)))
    (with-aliases
      (eval
       `(lambda (lseg l r value)
          (declare (fixnum l r value))
          (with-aliases
            (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
                  (routes-for-accumulate (%get-routes-for-accumulate base-length l r)))
              (declare (list routes-for-propagate routes-for-accumulate))
              ;; propagate lazy (top -> bottom)
              (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
                    :do (funcall ,%propagate! lseg index range))
              ;; apply value to lazy (bottom -> top)
              (loop :for (index range _) :of-type (fixnum fixnum nil) :in routes-for-accumulate
                    :do (setf (aref lazy index)
                              (funcall ,composition (aref lazy index) value)))
  update acc ( bottom - > top )
              (loop :for (index range) :of-type (fixnum fixnum) :in (nreverse routes-for-propagate)
                    :for acc :of-type fixnum := (aref data index)
                    :for l :of-type fixnum := (funcall ,%accumulate
                                                       lseg
                                                       (ash index 1)
                                                       (ash range -1))
                    :for r :of-type fixnum := (funcall ,%accumulate lseg
                                                       (logior 1 (ash index 1))
                                                       (ash range -1))
                    :do (setf (aref data index)
                              (funcall ,op l r))))))))))

#+swank
(defun bench-update ()
  (let ((lseg (make-lazy-segment-tree 10000 :init (constantly 0)
                                            :op (lambda (x y) (max x y))
                                            :op-id (constantly 0)
                                            :mapping (lambda (now lazy range)
                                                       (declare (ignore now range))
                                                       lazy)
                                            :map-id (constantly 0)
                                            :composition (lambda (x y)
                                                           (declare (ignore x))
                                                           y)))
        (rs (loop :repeat 100000
                  :for l := (random 10000)
                  :for r := (+ l (random (- 10000 l)))
                  :for v := (random 10000)
                  :collect (list l r v))))
    (time
     (loop :for (l r v) :in rs
            :do (update! lseg l r v)))))

;;;
  EOF
;;;



 Lazy Segment Tree
 Reference:
 - -library/document_ja/lazysegtree.html
 propagate lazy value to children
 reset lazy value
 propagate lazy value to children
 reset lazy value
 propagate lazy (top -> bottom)
 propagate lazy (top -> bottom)
 propagate lazy (top -> bottom)
 apply value to lazy (bottom -> top)
 propagate lazy (top -> bottom)
 apply value to lazy (bottom -> top)


  BOF


(defpackage lazy-segment-tree
  (:use #:cl)
  (:nicknames #:lseg)
  (:export #:make-lazy-segment-tree
           #:fold
           #:ref
           #:update!
           #:compile-fold
           #:compile-ref
           #:compile-update!))

(in-package #:lseg)

(defstruct ops
  (op nil :type function)
  (op-id nil :type function)
  (mapping nil :type function)
  (map-id nil :type function)
  (composition nil :type function))

(defmacro _f (op place &rest args)
  (multiple-value-bind (vars varvs res setter accessor)
      (get-setf-expansion place)
    `(let* (,@(mapcar #'list vars varvs)
            (,(car res) (,op ,accessor ,@args)))
       ,setter)))

(defmacro ashf (place count)
  `(_f ash ,place ,count))

(defstruct (lazy-segment-tree (:conc-name lseg-)
                              (:constructor %%make-lseg))
  (data nil :type (simple-array fixnum 1))
  (lazy nil :type (simple-array fixnum 1))
  (base-length nil :type fixnum)
  (size nil :type fixnum)
  (ops nil :type ops))

(defmacro with-aliases (&body body)
  `(symbol-macrolet ((data (lseg-data lseg))
                     (lazy (lseg-lazy lseg))
                     (base-length (lseg-base-length lseg))
                     (size (lseg-size lseg))
                     (ops (lseg-ops lseg))
                     (op-id (ops-op-id ops))
                     (op (ops-op ops))
                     (mapping (ops-mapping ops))
                     (map-id (ops-map-id ops))
                     (composition (ops-composition ops)))
     ,@body))

(defun get-base-length (size)
  (let ((res 1))
    (loop :until (>= res size)
          :do (ashf res 1))
    res))

(defun %get-routes-for-accumulate (base-length l r)
  (declare (fixnum l r base-length))
  (incf l base-length)
  (incf r base-length)
  (let ((routes nil)
        (range 1))
    (declare (list routes)
             (fixnum range))
    (loop :while (< l r)
          :do (when (logbitp 0 l)
                (push (list l range :l)
                      routes)
                (incf l))
              (when (logbitp 0 r)
                (decf r)
                (push (list r range :r)
                      routes))
              (ashf l -1)
              (ashf r -1)
              (ashf range 1))
    (nreverse routes)))

(defun %get-routes-for-propagate (base-length l r)
  (declare (fixnum base-length l r))
  (let ((res nil)
        (l-range 1)
        (r-range 1))
    (declare (list res)
             (fixnum l-range r-range))
    (incf l base-length)
    (incf r base-length)
    (loop :until (logbitp 0 l)
          :do (ashf l -1)
              (ashf l-range 1))
    (loop :until (logbitp 0 r)
          :do (ashf r -1)
              (ashf r-range 1))
    (ashf l -1)
    (ashf l-range 1)
    (ashf r -1)
    (ashf r-range 1)
    (loop :while (> l 1)
          :do (push (list l l-range)
                    res)
              (ashf l -1)
              (ashf l-range 1))
    (loop :while (>= r 1)
          :do (push (list r r-range)
                    res)
              (ashf r -1)
              (ashf r-range 1))
    res))

(defun make-lazy-segment-tree (size &key init op op-id mapping map-id composition)
  (let* ((base-length (get-base-length size))
         (data-size (1+ (ash base-length 1)))
         (ops (make-ops :op op
                        :op-id op-id
                        :mapping mapping
                        :map-id map-id
                        :composition composition))
         (res (%%make-lseg :data (make-array data-size :element-type 'fixnum
                                                       :initial-element (funcall init))
                           :lazy (make-array data-size :element-type 'fixnum
                                                       :initial-element (funcall map-id))
                           :ops ops
                           :base-length base-length
                           :size size)))
    res))

(defun %compile-propagate! (lseg)
  (with-aliases
    (eval
     `(lambda (lseg index range)
        (symbol-macrolet ((data (lseg-data lseg))
                          (lazy (lseg-lazy lseg)))
          (symbol-macrolet ((acc (aref data index))
                            (lz (aref lazy index))
                            (l (aref lazy (ash index 1)))
                            (r (aref lazy (logior 1 (ash index 1)))))
            (unless (= lz (funcall ,map-id))
              (setf l
                    (funcall ,composition
                             (or l (funcall ,map-id))
                             lz))
              (setf r
                    (funcall ,composition
                             (or r (funcall ,map-id))
                             lz))
              (setf acc
                    (funcall ,mapping
                             acc
                             lz
                             range))
              (setf lz (funcall ,map-id)))))))))

(declaim (inline %propagate!))
(defun %propagate! (lseg index range)
  (with-aliases
    (symbol-macrolet ((acc (aref data index))
                      (lz (aref lazy index))
                      (l (aref lazy (ash index 1)))
                      (r (aref lazy (logior 1 (ash index 1)))))
      (unless (= lz (funcall map-id))
        (setf l
              (funcall composition
                       (or l (funcall map-id))
                       lz))
        (setf r
              (funcall composition
                       (or r (funcall map-id))
                       lz))
        (setf acc
              (funcall mapping
                       acc
                       lz
                       range))
        (setf lz (funcall map-id))))))

(defun compile-fold (lseg)
  (let ((propagate! (%compile-propagate! lseg)))
    (with-aliases
      (eval
       `(lambda (lseg l r)
          (with-aliases
            (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
                  (routes-for-accumulate (%get-routes-for-accumulate base-length l r))
                  (res (funcall ,op-id)))
              (declare (list routes-for-propagate routes-for-accumulate)
                       (fixnum res))
              (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
                    :do (funcall ,propagate! lseg index range))
  accumulate acc and calculate answer ( direction does not matter )
              (loop :for (index range side) :of-type (fixnum fixnum (member :l :r)) :in routes-for-accumulate
                    :for acc :of-type fixnum := (aref data index)
                    :for lz :of-type fixnum := (aref lazy index)
                    :for calc-value :of-type fixnum := (funcall ,mapping acc lz range)
                    :for new-res :of-type fixnum := (ecase side
                                                      (:l (funcall ,op calc-value res))
                                                      (:r (funcall ,op res calc-value)))
                    :do (setf res new-res))
              res)))))))

(defun fold (lseg l r)
  (declare (fixnum l r))
  (with-aliases
    (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
          (routes-for-accumulate (%get-routes-for-accumulate base-length l r))
          (res (funcall op-id)))
      (declare (list routes-for-propagate routes-for-accumulate)
               (fixnum res))
      (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
            :do (%propagate! lseg index range))
  accumulate acc and calculate answer ( direction does not matter )
      (loop :for (index range side) :of-type (fixnum fixnum (member :l :r)) :in routes-for-accumulate
            :for acc :of-type fixnum := (aref data index)
            :for lz :of-type fixnum := (aref lazy index)
            :for calc-value :of-type fixnum := (funcall mapping acc lz range)
            :for new-res :of-type fixnum := (ecase side
                                              (:l (funcall op calc-value res))
                                              (:r (funcall op res calc-value)))
            :do (setf res new-res))
      res)))

(declaim (inline ref))
(defun ref (lseg index)
  (fold lseg index (1+ index)))

(defun compile-ref (lseg)
  (let ((%fold (compile-fold lseg)))
    (eval
     `(lambda (lseg index)
        (funcall ,%fold lseg index (1+ index))))))

(declaim (inline %accumulate))
(defun %accumulate (lseg index range)
  (with-aliases
    (funcall mapping
             (aref data index)
             (aref lazy index)
             range)))

(defun %compile-accumulate (lseg)
  (with-aliases
    (eval
     `(lambda (lseg index range)
        (with-aliases
          (funcall ,mapping
                   (aref data index)
                   (aref lazy index)
                   range))))))

(declaim (notinline update!))
(defun update! (lseg l r value)
  (declare (fixnum l r value))
  (with-aliases
    (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
          (routes-for-accumulate (%get-routes-for-accumulate base-length l r)))
      (declare (list routes-for-propagate routes-for-accumulate))
      (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
            :do (%propagate! lseg index range))
      (loop :for (index range _) :of-type (fixnum fixnum nil) :in routes-for-accumulate
            :do (setf (aref lazy index)
                      (funcall composition (aref lazy index) value)))
  update acc ( bottom - > top )
      (loop :for (index range) :of-type (fixnum fixnum) :in (nreverse routes-for-propagate)
            :for acc :of-type fixnum := (aref data index)
            :for l :of-type fixnum := (%accumulate lseg
                                                   (ash index 1)
                                                   (ash range -1))
            :for r :of-type fixnum := (%accumulate lseg
                                                   (logior 1 (ash index 1))
                                                   (ash range -1))
            :do (setf (aref data index)
                      (funcall op l r))))))

(defun compile-update! (lseg)
  (let ((%propagate! (%compile-propagate! lseg))
        (%accumulate (%compile-accumulate lseg)))
    (with-aliases
      (eval
       `(lambda (lseg l r value)
          (declare (fixnum l r value))
          (with-aliases
            (let ((routes-for-propagate (%get-routes-for-propagate base-length l r))
                  (routes-for-accumulate (%get-routes-for-accumulate base-length l r)))
              (declare (list routes-for-propagate routes-for-accumulate))
              (loop :for (index range) :of-type (fixnum fixnum) :in routes-for-propagate
                    :do (funcall ,%propagate! lseg index range))
              (loop :for (index range _) :of-type (fixnum fixnum nil) :in routes-for-accumulate
                    :do (setf (aref lazy index)
                              (funcall ,composition (aref lazy index) value)))
  update acc ( bottom - > top )
              (loop :for (index range) :of-type (fixnum fixnum) :in (nreverse routes-for-propagate)
                    :for acc :of-type fixnum := (aref data index)
                    :for l :of-type fixnum := (funcall ,%accumulate
                                                       lseg
                                                       (ash index 1)
                                                       (ash range -1))
                    :for r :of-type fixnum := (funcall ,%accumulate lseg
                                                       (logior 1 (ash index 1))
                                                       (ash range -1))
                    :do (setf (aref data index)
                              (funcall ,op l r))))))))))

#+swank
(defun bench-update ()
  (let ((lseg (make-lazy-segment-tree 10000 :init (constantly 0)
                                            :op (lambda (x y) (max x y))
                                            :op-id (constantly 0)
                                            :mapping (lambda (now lazy range)
                                                       (declare (ignore now range))
                                                       lazy)
                                            :map-id (constantly 0)
                                            :composition (lambda (x y)
                                                           (declare (ignore x))
                                                           y)))
        (rs (loop :repeat 100000
                  :for l := (random 10000)
                  :for r := (+ l (random (- 10000 l)))
                  :for v := (random 10000)
                  :collect (list l r v))))
    (time
     (loop :for (l r v) :in rs
            :do (update! lseg l r v)))))

  EOF
