More changes to support new shape-keys

Author: Christian Schafmeisterr

src/lisp/topology/assembler.lisp

@@ -560,7 +560,7 @@ Specialize the foldamer argument to provide methods"))
     (t (error "Illegal value for monomer-subset ~s - must be NIL or a hash-table"))))
 
 (defun maybe-update-shape-key-cache (assembler internals)
-  (error "How do I use internals")
+  (error "Don't use the shape-key-cahce in the monomer-shape")
   (loop for oligomer-shape in (oligomer-shapes assembler)
         for rotamers-database = (rotamers-database oligomer-shape)
         for foldamer-name = (foldamer-name rotamers-database)
@@ -711,6 +711,7 @@ ENERGY-FUNCTION-FACTORY - If defined, call this with the aggregate to make the e
                      when external-adjusts
                        do (loop for adjust in external-adjusts
                                 do (initialize-adjustment adjust assembler))))
+      #+(or)
       (unless monomer-subset
         (error "I don't think I want to update the internals now that there isn't built in internals")
         ;; update the internals so we can build dihedral caches
@@ -903,47 +904,47 @@ ENERGY-FUNCTION-FACTORY - If defined, call this with the aggregate to make the e
 
 
 
-(defun build-atom-tree-external-coordinates* (assembler coords oligomer-shape maybe-orientation)
+(defun build-atom-tree-external-coordinates* (assembler assembler-internals coords oligomer-shape maybe-orientation)
   (let* ((orientation (orientation maybe-orientation assembler))
          (one-oligomer (oligomer oligomer-shape))
          (joints (gethash one-oligomer (root-map (joint-tree assembler)))))
     (when (null joints)
       (error "Could not find oligomer ~s in root-map ~s" one-oligomer (root-map (joint-tree assembler))))
     (with-orientation orientation
       (loop for joint in joints
-            do (update-xyz-coords assembler internals joint coords)))))
+            do (update-xyz-coords assembler assembler-internals joint coords)))))
 
 
-(defun build-atom-tree-for-monomer-shape-external-coordinates* (assembler coords oligomer-shape monomer-shape maybe-orientation)
+(defun build-atom-tree-for-monomer-shape-external-coordinates* (assembler assembler-internals coords oligomer-shape monomer-shape maybe-orientation)
   (let* ((orientation (orientation maybe-orientation assembler))
          (one-oligomer (oligomer oligomer-shape))
          (joints (gethash one-oligomer (root-map (joint-tree assembler)))))
     (when (null joints)
       (error "Could not find oligomer ~s in root-map ~s" one-oligomer (root-map (joint-tree assembler))))
     (with-orientation orientation
       (loop for joint in joints
-            do (update-xyz-coords assembler internals joint coords)))))
+            do (update-xyz-coords assembler assembler-internals joint coords)))))
 
 
-(defun adjust-atom-tree-external-coordinates (assembler coords oligomer-shape)
+(defun adjust-atom-tree-external-coordinates (assembler assembler-internals coords oligomer-shape)
   (let* ((pos (position oligomer-shape (oligomer-shapes assembler)))
          (atmol (elt (atmolecules (ataggregate assembler)) pos)))
     (loop for atres across (atresidues atmol)
           for adjustments = (gethash atres (external-adjustments (adjustments assembler)))
           do (loop for adjustment in adjustments
-                   do (external-adjust adjustment assembler coords)))))
+                   do (external-adjust adjustment assembler assembler-internals coords)))))
 
-(defun adjust-all-atom-tree-external-coordinates (assembler coords)
+(defun adjust-all-atom-tree-external-coordinates (assembler assembler-internals coords)
   (loop for oligomer-shape in (oligomer-shapes assembler)
-        do (adjust-atom-tree-external-coordinates assembler coords oligomer-shape)))
+        do (adjust-atom-tree-external-coordinates assembler assembler-internals coords oligomer-shape)))
 
 (defun build-all-atom-tree-external-coordinates-and-adjust (assembler coords)
   (loop for oligomer-shape in (oligomer-shapes assembler)
-        do (build-atom-tree-external-coordinates-and-adjust assembler coords oligomer-shape oligomer-shape)))
+        do (build-atom-tree-external-coordinates-and-adjust assembler assembler-internals coords oligomer-shape oligomer-shape)))
 
-(defun build-atom-tree-external-coordinates-and-adjust (assembler coords oligomer-shape maybe-orientation)
-  (build-atom-tree-external-coordinates* assembler coords oligomer-shape maybe-orientation)
-  (adjust-atom-tree-external-coordinates assembler coords oligomer-shape))
+(defun build-atom-tree-external-coordinates-and-adjust (assembler assembler-internals coords oligomer-shape maybe-orientation)
+  (build-atom-tree-external-coordinates* assembler assembler-internals coords oligomer-shape maybe-orientation)
+  (adjust-atom-tree-external-coordinates assembler assembler-internals coords oligomer-shape))
 
 #+(or)
 (defun build-atresidue-atom-tree-external-coordinates (assembler atresidue coords)
@@ -1363,8 +1364,8 @@ Return the COORDS."
       (let ((orientation (lookup-orientation assembler orientation)))
         (when (and oligomer-shape (not orientationp))
           (error "You must provide orientation when you provide oligomer-shape"))
-        (build-atom-tree-external-coordinates* assembler coords oligomer-shape orientation)
-        (adjust-atom-tree-external-coordinates assembler coords oligomer-shape)
+        (build-atom-tree-external-coordinates* assembler assembler-internals coords oligomer-shape orientation)
+        (adjust-atom-tree-external-coordinates assembler assembler-internals coords oligomer-shape)
         (when (local-frame-specs orientation)
           (transform-externals-to-global-frame assembler oligomer-shape orientation coords))
         )
@@ -1392,4 +1393,4 @@ Return the COORDS."
          (joint0 (elt joints 0)))
     (with-orientation orientation
       (update-xyz-coords assembler assembler-internals joint0 coords))
-    (adjust-atom-tree-external-coordinates assembler coords oligomer-shape)))
+    (adjust-atom-tree-external-coordinates assembler assembler-internals coords oligomer-shape)))

src/lisp/topology/internals.lisp

@@ -5,38 +5,35 @@
 (defparameter *-pi-s* (- (float PI 1.0s0)))
 (defconstant +bin-size+ 10 )
 
+(defgeneric shape-key-for-sidechain-monomer (foldamer monomer-context oligomer-shape focus-monomer)
+  (:documentation "Return a shape-key for the sidechain-monomer"))
+
+(defun transform-string (input)
+  "Remove parentheses and spaces; replace periods with underscores; copy other characters."
+  (with-output-to-string (out)
+    (loop for ch across input
+          if (member ch '(#\Space #\( #\) #\: #\.))
+            do (write-char #\_ out)
+          else
+            do (write-char ch out))))
 
-(defclass shape-key (cando.serialize:serializable)
-  ((parts :initarg :parts :reader parts)))
-
-(defmethod print-object ((shape-key shape-key) stream)
-  (if *print-readably*
-      (call-next-method)
-      (print-unreadable-object (shape-key stream :type t)
-        (format stream "~s" (parts shape-key)))))
+(defun shape-key-as-pathname-part (shape-key)
+  (format nil "shape-key-~a" (transform-string (format nil "~a" shape-key))))
 
+(defun shape-key-parts (shape-key)
+  shape-key)
 
 (defun make-shape-key (&rest pparts)
-  (make-instance 'shape-key :parts pparts))
+  pparts)
 
 (defun ensure-shape-key (shape-key)
-  (unless (typep shape-key 'shape-key)
+  (unless (consp shape-key)
     (error "The shape-key ~s must be a shape-key" shape-key))
   shape-key)
 
 
-(defclass shape-key-map ()
-  ((ht :initarg :ht :reader ht)))
-
-(defun shape-key-map-hash (value)
-  (sxhash (parts value)))
-
-(defun shape-key-map-test (v1 v2)
-  (equal (parts v1) (parts v2)))
-
 (defmethod make-shape-key-map ()
-  (make-hash-table :hash-function #'shape-key-map-hash :test #'shape-key-map-test))
-
+  (make-hash-table :test 'equal))
 
 
 (defclass dihedral-range (cando.serialize:serializable)
@@ -453,7 +450,7 @@ changing the SHAPE-KEY-CACHE."
 
 
 (defclass sidechain-rotamers (rotamers)
-  ((shape-key-to-index :initarg :shape-key-to-index :initform (make-hash-table :test 'equal) :accessor shape-key-to-index
+  ((shape-key-to-index :initarg :shape-key-to-index :initform (make-shape-key-map) :accessor shape-key-to-index
                        :documentation "This is a cons of (phi.psi)")))
 
 (defclass backbone-rotamers-base (rotamers) ())

src/lisp/topology/joint-templates.lisp

@@ -41,8 +41,8 @@
 
 (defgeneric initialize-adjustment (adjustment assembler))
 
-(defgeneric external-adjust (adjustment assembler coordinates))
-(defmethod external-adjust ((adjustment internal-adjustment) assembler coordinates)
+(defgeneric external-adjust (adjustment assembler assembler-internals coordinates))
+(defmethod external-adjust ((adjustment internal-adjustment) assembler assembler-internals coordinates)
   "default - don't do anything"
   nil)
 

src/lisp/topology/manipulator.lisp

@@ -904,18 +904,22 @@ while nesting several WITH-CPRING5 forms."
           do (build-internals-from-cpinternals (assembler manipulator) driver internals temp-externals cpinternals)))
   (call-next-method))
 
-(defun fscale-frac (num &optional (bin-size 0.01))
+(defparameter +fscale-frac-bin-size+ 0.05) ; Bin Cremer-Pople q-values in 0.05 value bin sizes - it was 0.01 but that generates too many shape-key
+(defparameter +fscale-deg-bin-size+ 5)     ; Bin angles in 5-degree bin sizes  - it was 1-degree but that generates too many shape-key
+
+(defun fscale-frac (num &optional (bin-size +fscale-frac-bin-size+))
   (floor (fround (/ num bin-size))))
 
-(defun fscale-frac-reverse (int &optional (bin-size 0.01))
+(defun fscale-frac-reverse (int &optional (bin-size +fscale-frac-bin-size+))
   (* int bin-size))
 
-(defun fscale-deg (num &optional (bin-size 1))
+(defun fscale-deg (num &optional (bin-size +fscale-deg-bin-size+))
   (floor (fround (/ (topology:rad-to-deg num) bin-size))))
 
-(defun fscale-deg-reverse (int &optional (bin-size 1))
+(defun fscale-deg-reverse (int &optional (bin-size +fscale-deg-bin-size+))
   (topology:deg-to-rad (* int bin-size)))
 
+
 (defgeneric binned-shape-key (driver cpinternals))
 (defgeneric binned-shape-key-write (driver cpinternals shape-key))
 

src/lisp/topology/packages.lisp

@@ -249,7 +249,7 @@
    #:foldamer
    #:shape-info
    #:shape-key
-   #:parts
+   #:shape-key-parts
    #:ensure-shape-key
    #:validate-shape-key
    #:make-shape-key-old-style
@@ -587,7 +587,11 @@
    #:binned-shape-key-write
    #:ring-joints
    #:ring-driver-distance-angle-arrays
-   #:build-only-ring-externals-from-cpinternals))
+   #:build-only-ring-externals-from-cpinternals
+   #:shape-key-as-pathname-part
+   #:shape-key-monomers-callback
+   #:make-shape-key-callback
+   #:shape-key-for-sidechain-monomer))
 
 (defpackage #:topology.dag
   (:use #:common-lisp)

src/lisp/topology/shape.lisp

@@ -82,7 +82,7 @@ If ORIGINAL-ROTAMER-SHAPE is defined then it must be a ROTAMER-SHAPE and we copy
    (molecule :initarg :molecule :reader molecule)))
 
 (defclass backbone-residue-shape (residue-shape)
-  ((shape-key-cache-deg :initarg :shape-key-cache-deg
+  (#+(or)(shape-key-cache-deg :initarg :shape-key-cache-deg
                                 :accessor shape-key-cache-deg)))
 
 (defmethod copy-monomer-shape ((residue-shape residue-shape))
@@ -583,6 +583,7 @@ If UNINITIALIZED then leave them unbound."
 
 
 (defun lookup-dihedral-cache-impl (oligomer-shape monomer-shape dihedral-name &key ignore-degrees)
+  (error "Don't use this - lookup the dihedral cache in the rotamer database")
   (let* ((monomer-shape-index (position monomer-shape (monomer-shape-vector oligomer-shape)))
          (monomer-shape-info (aref (monomer-shape-info-vector oligomer-shape) monomer-shape-index))
          (monomer (monomer monomer-shape-info))
@@ -664,11 +665,12 @@ If UNINITIALIZED then leave them unbound."
       (write-rotamers oligomer-shape ss (random-rotamers ss))
       (let* ((ass (make-assembler (list oligomer-shape)))
              (coords (make-coordinates-for-assembler ass))
+             (internals (make-internals-for-assembler ass))
              )
-        (update-internals ass :oligomer-shape oligomer-shape)
-        (update-externals ass :oligomer-shape oligomer-shape
-                              :orientation oligomer-shape
-                              :coords coords)
+        (update-internals ass internals :oligomer-shape oligomer-shape)
+        (update-externals ass internals :oligomer-shape oligomer-shape
+                                        :orientation oligomer-shape
+                                        :coords coords)
         (copy-all-joint-positions-into-atoms ass coords)
         (aggregate ass)))))
 
@@ -686,9 +688,10 @@ If UNINITIALIZED then leave them unbound."
 (defmethod aggregate ((oligomer-shape oligomer-shape))
   "Generate a unique aggregate for the OLIGOMER-SHAPE. This can be called multiple times and each time a new, unique aggregate will be generated."
   (let* ((ass (make-assembler (list oligomer-shape)))
-         (coords (make-coordinates-for-assembler ass)))
-    (update-internals ass :oligomer-shape oligomer-shape)
-    (build-all-atom-tree-external-coordinates-and-adjust ass coords)
+         (coords (make-coordinates-for-assembler ass))
+         (internals (make-internals-for-assembler ass)))
+    (update-internals ass internals :oligomer-shape oligomer-shape)
+    (build-all-atom-tree-external-coordinates-and-adjust ass internals coords)
     (copy-all-joint-positions-into-atoms ass coords)
     (chem:matter-copy (aggregate ass))))
 

src/lisp/topology/steppers.lisp

@@ -27,28 +27,28 @@
 
 (defun calculate-allowed-rotamers (monomer-shape-index sidechain-monomer-shape sidechain-monomer-shape-info oligomer-shape shape-key-to-allowed-rotamers)
   (declare (ignorable monomer-shape-index))
-    #+debug-mover
-    (let ((*print-pretty* nil))
-      (format t "calculate-allowed-rotamers monomer-shape-index ~a~%" monomer-shape-index))
-    (let* ((phi-deg (topology:lookup-dihedral-cache oligomer-shape sidechain-monomer-shape :phi))
-           (psi-deg (topology:lookup-dihedral-cache oligomer-shape sidechain-monomer-shape :psi))
-           (shape-key nil)
-           (result (if (and phi-deg psi-deg)
-                       (progn
-                         (setf shape-key (make-phi-psi phi-deg psi-deg))
-                         (gethash shape-key shape-key-to-allowed-rotamers))
-                       nil)))
-      (unless result
-        (let* ((*print-pretty* nil)
-               (monomer (monomer sidechain-monomer-shape-info)))
-          (error 'no-rotamers :message (format nil "Found no allowed-rotamers for ~s - phi-deg: ~s  psi-deg: ~s - shape-key ~s -  ~s in ~s - this shouldn't be possible if a backbone-stepper was created and applied to the oligomer-shape" monomer phi-deg psi-deg shape-key sidechain-monomer-shape oligomer-shape))))
-      (when (= 0 (length result))
-        (error 'no-rotamers :message (format nil "The resulting rotamers vector is empty for shape-key ~s - available keys ~s" shape-key (alexandria:hash-table-keys shape-key-to-allowed-rotamers))))
-      #+debug-mover
-      (let ((*print-pretty* nil))
-        (format t "   calculate-allowed-rotamers  phi-deg ~d  psi-deg ~d    allowed-rotamers -> ~s~%" phi-deg psi-deg result))
-      result
-      ))
+  #+debug-mover
+  (let ((*print-pretty* nil))
+    (format t "calculate-allowed-rotamers monomer-shape-index ~a~%" monomer-shape-index))
+  (let* ((foldamer (foldamer (oligomer-space oligomer-shape))))
+    (multiple-value-bind (shape-key rotamers monomer-contexts)
+        (shape-key-for-sidechain-monomer foldamer
+                                         (monomer-context sidechain-monomer-shape-info)
+                                         oligomer-shape
+                                         (monomer sidechain-monomer-shape-info))
+      (let ((result (gethash shape-key shape-key-to-allowed-rotamers)))
+        (unless result
+          (let* ((*print-pretty* nil)
+                 (monomer (monomer sidechain-monomer-shape-info)))
+            (error 'no-rotamers :message (format nil "Found no allowed-rotamers for ~s~%- monomer-context: ~s~%- shape-key ~s -  ~s in ~s~%- this shouldn't be possible if a backbone-stepper was created and applied to the oligomer-shape~%- backbone rotamers: ~{bb ~s~%~}- monomer-contexts: ~s" monomer (monomer-context sidechain-monomer-shape-info)
+                                                 shape-key sidechain-monomer-shape oligomer-shape rotamers monomer-contexts))))
+        (when (= 0 (length result))
+          (error 'no-rotamers :message (format nil "The resulting rotamers vector is empty for shape-key ~s - available keys ~s" shape-key (alexandria:hash-table-keys shape-key-to-allowed-rotamers))))
+        #+debug-mover
+        (let ((*print-pretty* nil))
+          (format t "   calculate-allowed-rotamers  phi-deg ~d  psi-deg ~d    allowed-rotamers -> ~s~%" phi-deg psi-deg result))
+        result
+        ))))
 
 (defclass permissible-rotamer ()
   ((monomer-shape-locus :initarg :monomer-shape-locus :reader monomer-shape-locus)