bhm.lisp (6262B)
1 (defpackage :bhm 2 (:use :common-lisp :blas :tensor :mps) 3 (:export :ket-physical-index 4 :bra-physical-index 5 :bose-hubbard-site-hamiltonian 6 :binary-bose-hubbard-site-hamiltonian)) 7 8 (in-package :bhm) 9 10 (defun ket-physical-index (n) 11 (loop for i below n collect 12 (make-segment :numbers (list i) :dimension 1))) 13 14 (defun bra-physical-index (n) 15 (loop for i below n collect 16 (make-segment :numbers (list (- i)) :dimension 1))) 17 18 ;; 19 ;; bose-hubbard site hamiltonian 20 ;; 21 ;; -1 0 0 1 22 ;; 23 ;; +------+ 24 ;; -1 | b+ 0 | 25 ;; +-------+------+-------+ 26 ;; 0 | 0 | 1 0 | 0 | 27 ;; 0 | -j*b+ | h 1 | -j*b- | 28 ;; +-------+------+-------+ 29 ;; 1 | b- 0 | 30 ;; +------+ 31 ;; 32 33 (defun bose-hubbard-site-operators (j u e) 34 (list 35 (cons '0 #'(lambda (n) (declare (ignore n)) 0)) 36 (cons '1 #'(lambda (n) (declare (ignore n)) 1)) 37 (cons 'b- #'(lambda (n) (sqrt n))) 38 (cons 'b+ #'(lambda (n) (sqrt (1+ n)))) 39 (cons '-jb- #'(lambda (n) (* (- j) (sqrt n)))) 40 (cons '-jb+ #'(lambda (n) (* (- j) (sqrt (1+ n))))) 41 (cons 'h #'(lambda (n) (+ (* 1/2 u n (1- n)) (* e n)))))) 42 43 (defun bose-hubbard-site-hamiltonian (dimension j u e) 44 (let ((ops (bose-hubbard-site-operators j u e)) 45 (tbl (flet ((f (x y z) 46 (cons (list (make-subscript 47 :numbers (list (first x)) 48 :subscript (second x)) 49 (make-subscript 50 :numbers (list (first y)) 51 :subscript (second y))) 52 z))) 53 (list 54 (f '(-1 0) '( 0 0) 'b+) 55 (f '(-1 0) '( 0 1) '0) 56 (f '( 0 0) '(-1 0) '0) 57 (f '( 0 0) '( 0 0) '1) 58 (f '( 0 0) '( 0 1) 0) 59 (f '( 0 0) '( 1 0) '0) 60 (f '( 0 1) '(-1 0) '-jb+) 61 (f '( 0 1) '( 0 0) 'h) 62 (f '( 0 1) '( 0 1) '1) 63 (f '( 0 1) '( 1 0) '-jb-) 64 (f '( 1 0) '( 0 0) 'b-) 65 (f '( 1 0) '( 0 1) '0))))) 66 (let ((l (list (make-segment :numbers '(-1) :dimension 1) 67 (make-segment :numbers '(0) :dimension 2) 68 (make-segment :numbers '(1) :dimension 1)))) 69 (functional-tensor 70 (list l (ket-physical-index dimension) (bra-physical-index dimension) l) 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 ;; 83 ;; binary bose-hubbard site hamiltonian 84 ;; 85 86 (defun bose-hubbard-site-hamiltonian-a (dimension j u e ux) 87 (let ((ops (cons 88 (cons 'uxn #'(lambda (n) (* ux n))) 89 (bose-hubbard-site-operators j u e))) 90 (tbl (flet ((f (x y z) 91 (cons (list (make-subscript 92 :numbers (first x) 93 :subscript (second x)) 94 (make-subscript 95 :numbers (first y) 96 :subscript (second y))) 97 z))) 98 (list 99 (f '((-1 0) 0) '(( 0 0) 0) 'b+) 100 (f '(( 0 -1) 0) '(( 0 1) 0) '1) 101 (f '(( 0 0) 0) '(( 0 0) 0) '1) 102 (f '(( 0 0) 1) '((-1 0) 0) '-jb+) 103 (f '(( 0 0) 1) '(( 0 0) 0) 'h) 104 (f '(( 0 0) 1) '(( 0 0) 1) 'uxn) 105 (f '(( 0 0) 1) '(( 0 0) 2) '1) 106 (f '(( 0 0) 1) '(( 1 0) 0) '-jb-) 107 (f '(( 0 1) 0) '(( 0 -1) 0) '1) 108 (f '(( 1 0) 0) '(( 0 0) 0) 'b-))))) 109 (functional-tensor 110 (list 111 (list (make-segment :numbers '(-1 0) :dimension 1) 112 (make-segment :numbers '( 0 -1) :dimension 1) 113 (make-segment :numbers '( 0 0) :dimension 2) 114 (make-segment :numbers '( 0 1) :dimension 1) 115 (make-segment :numbers '( 1 0) :dimension 1)) 116 (loop for i below dimension collect 117 (make-segment :numbers (list i 0) :dimension 1)) 118 (loop for i below dimension collect 119 (make-segment :numbers (list (- i) 0) :dimension 1)) 120 (list (make-segment :numbers '(-1 0) :dimension 1) 121 (make-segment :numbers '( 0 -1) :dimension 1) 122 (make-segment :numbers '( 0 0) :dimension 3) 123 (make-segment :numbers '( 0 1) :dimension 1) 124 (make-segment :numbers '( 1 0) :dimension 1))) 125 #'(lambda (s) 126 (let ((x (find 127 (list (first s) (fourth s)) 128 tbl 129 :test #'equalp 130 :key #'car))) 131 (if x 132 (funcall (cdr (find (cdr x) ops :key #'car)) 133 (- (first (subscript-numbers (third s))))) 134 0)))))) 135 136 (defun bose-hubbard-site-hamiltonian-b (dimension j u e) 137 (let ((ops (cons 138 (cons 'n #'(lambda (n) n)) 139 (bose-hubbard-site-operators j u e))) 140 (tbl (flet ((f (x y z) 141 (cons (list (make-subscript 142 :numbers (first x) 143 :subscript (second x)) 144 (make-subscript 145 :numbers (first y) 146 :subscript (second y))) 147 z))) 148 (list 149 (f '((-1 0) 0) '(( 1 0) 0) '1) 150 (f '(( 0 -1) 0) '(( 0 0) 0) 'b+) 151 (f '(( 0 0) 0) '(( 0 0) 0) '1) 152 (f '(( 0 0) 1) '(( 0 0) 0) 'n) 153 (f '(( 0 0) 2) '(( 0 -1) 0) '-jb+) 154 (f '(( 0 0) 2) '(( 0 0) 0) 'h) 155 (f '(( 0 0) 2) '(( 0 0) 1) '1) 156 (f '(( 0 0) 2) '(( 0 1) 0) '-jb-) 157 (f '(( 0 1) 0) '(( 0 0) 0) 'b-) 158 (f '(( 1 0) 0) '((-1 0) 0) '1))))) 159 (functional-tensor 160 (list 161 (list (make-segment :numbers '(-1 0) :dimension 1) 162 (make-segment :numbers '( 0 -1) :dimension 1) 163 (make-segment :numbers '( 0 0) :dimension 3) 164 (make-segment :numbers '( 0 1) :dimension 1) 165 (make-segment :numbers '( 1 0) :dimension 1)) 166 (loop for i below dimension collect 167 (make-segment :numbers (list 0 i) :dimension 1)) 168 (loop for i below dimension collect 169 (make-segment :numbers (list 0 (- i)) :dimension 1)) 170 (list (make-segment :numbers '(-1 0) :dimension 1) 171 (make-segment :numbers '( 0 -1) :dimension 1) 172 (make-segment :numbers '( 0 0) :dimension 2) 173 (make-segment :numbers '( 0 1) :dimension 1) 174 (make-segment :numbers '( 1 0) :dimension 1))) 175 #'(lambda (s) 176 (let ((x (find 177 (list (first s) (fourth s)) 178 tbl 179 :test #'equalp 180 :key #'car))) 181 (if x 182 (funcall (cdr (find (cdr x) ops :key #'car)) 183 (- (second (subscript-numbers (third s))))) 184 0)))))) 185 186 (defun binary-bose-hubbard-site-hamiltonian (dimensiona dimensionb ja jb ua ub ux ea eb) 187 (let ((a (bose-hubbard-site-hamiltonian-a dimensiona ja ua ea ux)) 188 (b (bose-hubbard-site-hamiltonian-b dimensionb jb ub eb))) 189 (tensor-fuse 190 (tensor-permute 191 (tensor-contract a 3 b 0) 192 '(0 1 3 2 4 5)) 193 '(1 3 5) 194 '(:normal :normal :reverse :reverse))))