revivals.lisp (4038B)
1 ;; parameters 2 3 (defparameter *dimension* 15) ;; physical dimension 4 (defparameter *length* 11) 5 (defparameter *particles* 11) 6 (defparameter *maxdim* '(nil nil 100)) 7 8 ;; libraries 9 10 (load "conf.lisp") 11 (require :tebdol) 12 13 (use-package '(:array :tensor :mps :bhm)) 14 (setf *print-level* 2) 15 16 ;; main 17 18 (defun left-normalize (mps maxdim) 19 (let ((n (length mps))) 20 (loop for i below (1- n) do 21 (multiple-value-bind (l s r) (tensor-decompose (svref mps i) '(0 1) maxdim :left) 22 (declare (ignore s)) 23 (setf (svref mps i) l) 24 (setf (svref mps (1+ i)) (tensor-contract r 1 (svref mps (1+ i)) 0)))) 25 (setf (svref mps (1- n)) (tensor-normalize (svref mps (1- n)))))) 26 27 (defun right-compress (mps maxdim) 28 (let ((n (length mps))) 29 (loop for i from (1- n) above 0 do 30 (multiple-value-bind (l s r) (tensor-decompose (svref mps i) '(0) maxdim :right) 31 (declare (ignore s)) 32 (setf (svref mps i) r) 33 (setf (svref mps (1- i)) (tensor-contract (svref mps (1- i)) 2 l 0)))))) 34 35 ;; 36 ;; particle in a box creation operator 37 ;; 38 ;; -1 0 39 ;; 40 ;; +----+---+ 41 ;; 0 | b+ | 1 | 42 ;; +----+---+ 43 ;; 1 | 1 | 0 | 44 ;; +----+---+ 45 ;; 46 47 (defun site-piab (dimension weight) 48 (let ((ops (list 49 (cons '1 #'(lambda (n) (declare (ignore n)) 1)) 50 (cons 'b+ #'(lambda (n) (* weight (sqrt (1+ n))))))) 51 (tbl (flet ((f (x y z) 52 (cons (list (make-subscript 53 :numbers (list (first x)) 54 :subscript (second x)) 55 (make-subscript 56 :numbers (list (first y)) 57 :subscript (second y))) 58 z))) 59 (list 60 (f '(0 0) '(-1 0) 'b+) 61 (f '(0 0) '( 0 0) '1) 62 (f '(1 0) '(-1 0) '1))))) 63 (functional-tensor 64 (list 65 (list (make-segment :numbers '(0) :dimension 1) 66 (make-segment :numbers '(1) :dimension 1)) 67 (ket-physical-index dimension) 68 (bra-physical-index dimension) 69 (list (make-segment :numbers '(-1) :dimension 1) 70 (make-segment :numbers '(0) :dimension 1))) 71 #'(lambda (s) 72 (let ((x (find 73 (list (first s) (fourth s)) 74 tbl 75 :test #'equalp 76 :key #'car))) 77 (if x 78 (funcall (cdr (find (cdr x) ops :key #'car)) 79 (- (first (subscript-numbers (third s))))) 80 0)))))) 81 82 (defun right-tensor (operator) 83 (let* ((i (fourth (tensor-indices operator)))) 84 (functional-tensor 85 (list (conjugate-index i) 86 (list (make-segment :numbers '(-1) :dimension 1))) 87 #'(lambda (s) 88 (if (zerop (subscript-subscript (first s))) 89 1 90 0))))) 91 92 (defun make-piab-mpo (dimension length) 93 (loop 94 with m = (make-array length) 95 for i from 1 below (1- length) 96 do 97 (setf (svref m i) (site-piab dimension (sin (/ (* pi (1+ i)) (1+ length))))) 98 finally 99 (let ((o (site-piab dimension (sin (/ (* pi 1) (1+ length)))))) 100 (setf (svref m 0) (tensor-contract (left-open-boundary-tensor o) 1 o 0))) 101 (let ((o (site-piab dimension (sin (/ (* pi length) (1+ length)))))) 102 (setf (svref m (1- length)) (tensor-contract o 3 (right-tensor o) 0))) 103 (return m))) 104 105 (defun apply-and-fuse (mpo mps) 106 (let* ((n (length mpo)) 107 (o (make-array n))) 108 (dotimes (i n o) 109 (setf 110 (svref o i) 111 (tensor-fuse 112 (tensor-permute 113 (tensor-contract (svref mpo i) 2 (svref mps i) 1) 114 '(0 2 3 1 4)) 115 '(2 3) 116 '(:normal :normal :reverse)))))) 117 118 (defun make-vacuum-mps (dimension length) 119 (let* ((m (make-array length)) 120 (l (list (make-segment :numbers '(0) :dimension 1))) 121 (u (functional-tensor 122 (list l (ket-physical-index dimension) l) 123 #'(lambda (s) (declare (ignore s)) 1)))) 124 (dotimes (i length m) 125 (setf (svref m i) u)))) 126 127 (defparameter *mps* (make-vacuum-mps *dimension* *length*)) 128 (defparameter *mpp* (make-piab-mpo *dimension* *length*)) 129 130 (dotimes (i *particles*) 131 (format t "creating particle #~a~%" (1+ i)) 132 (setf *mps* (apply-and-fuse *mpp* *mps*)) 133 (left-normalize *mps* *maxdim*) 134 (right-compress *mps* *maxdim*)) 135 136 (save-mps 137 *mps* 138 *dimension* 139 *particles* 140 (make-pathname 141 :directory 142 (list :relative (format nil "inputs/revivals-l-~A-n-~A" *length* *particles*))))