-
Notifications
You must be signed in to change notification settings - Fork 0
/
fold.lisp
221 lines (191 loc) · 9.75 KB
/
fold.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
(in-package :topology)
(defclass atmatter () (()))
(defclass ataggregate (atmatter)
((aggregate :initarg :aggregate :accessor aggregate)
(atmolecules :initarg :atmolecules :initform (make-array 0 :adjustable t) :accessor atmolecules)))
(defun put-atmolecule (ataggregate atmolecule index)
(check-type ataggregate ataggregate)
(check-type atmolecule atmolecule)
(setf (aref (atmolecules ataggregate) index) atmolecule))
(defmethod resize-atmolecules ((ataggregate ataggregate) num-atmolecules)
(adjust-array (atmolecules ataggregate) num-atmolecules))
(defun walk-ataggregate-joints (ataggregate callback)
(loop for molecule-index below (length (atmolecules ataggregate))
for atmolecule = (aref (atmolecules ataggregate) molecule-index)
do (loop for residue-index below (length (atresidues atmolecule))
for atresidue = (aref (atresidues atmolecule) residue-index)
do (loop for atom-index below (length (joints atresidue))
for joint = (aref (joints atresidue) atom-index)
do (funcall callback joint (list molecule-index residue-index atom-index))))))
(defclass atmolecule (atmatter)
((molecule :initarg :molecule :accessor molecule)
(root-atresidue :initarg :root-atresidue :accessor root-atresidue)
(atresidues :initarg :atresidues
:initform (make-array 0 :adjustable t)
:accessor atresidues)))
(defmethod resize-atresidues ((atmolecule atmolecule) num-atresidues)
(adjust-array (atresidues atmolecule) num-atresidues))
(defun put-atresidue (atmolecule atresidue index)
(check-type atmolecule atmolecule)
(check-type atresidue atresidue)
(setf (aref (atresidues atmolecule) index) atresidue))
(defun atresidue-factory (residue ring-closing-monomer-map monomer topology)
(cond
((has-ring-closing-coupling monomer)
(let ((atresidue (make-instance 'ring-closing-atresidue :residue residue)))
(setf (gethash ring-closing-monomer-map monomer atresidue) atresidue)
atresidue))
(t (make-instance 'atresidue :residue residue
:topology topology))))
(defun lookup-atresidue-id (atmolecule atresidue-id)
(aref (atresidues atmolecule) atresidue-id))
(defun make-ring-closing-connections (ring-closing-monomer-map)
(when (> (hash-table-count ring-closing-monomer-map) 0)
(error "Implement me")))
(defun build-atmolecule-using-oligomer (oligomer molecule molecule-index monomer-positions joint-tree atom-table)
(let* ((root-monomer (root-monomer oligomer))
(ring-closing-monomer-map (make-hash-table))
(atmolecule (make-instance 'atmolecule :molecule molecule))
(residue-index (gethash root-monomer monomer-positions))
(residue (chem:content-at molecule residue-index))
(topology (monomer-topology root-monomer oligomer))
(root-atresidue (atresidue-factory residue ring-closing-monomer-map root-monomer topology)))
(adjust-array (atresidues atmolecule) (number-of-monomers oligomer))
(put-atresidue atmolecule root-atresidue residue-index)
(recursively-build-children joint-tree
root-atresidue
atmolecule
molecule
ring-closing-monomer-map
nil
nil
root-monomer
oligomer
monomer-positions
molecule-index
residue-index
nil
atom-table
)
(make-ring-closing-connections ring-closing-monomer-map)
(setf (root-atresidue atmolecule) root-atresidue)
atmolecule))
(defclass atresidue (atmatter)
((residue :initarg :residue :accessor residue)
(parent :initarg :parent :initform nil :accessor parent)
(parent-plug-name :initarg :parent-plug-name :initform nil :accessor parent-plug-name)
(id :initarg :id :accessor id)
(children :type hash-table :initform (make-hash-table) :initarg :children :accessor children)
(stereoisomer-name :initform nil :initarg :stereoisomer-name :accessor stereoisomer-name)
(topology :initarg :topology :accessor topology)
(conformation-index :initarg :conformation-index :accessor conformation-index)
(joints :initarg :joints
:initform (make-array 0 :adjustable t)
:accessor joints)))
(defun put-joint (atresidue joint index)
(check-type atresidue atresidue)
(check-type joint kin:joint)
(setf (aref (joints atresidue) index) joint))
(defmethod resize-atatoms ((atresidue atresidue) num-atatoms)
(adjust-array (joints atresidue) num-atatoms))
(defclass ring-closing-atresidue (atresidue)
())
(defun recursively-build-children (joint-tree
atresidue
atmolecule
molecule
ring-closing-monomer-map
parent-atresidue
coupling
monomer
oligomer
monomer-positions
atmolecule-index
atresidue-index
parent-joint
atom-table)
"Recursively build a atmolecule from an oligomer by linking together kin:atresidues"
(when parent-atresidue
(setf (parent atresidue) parent-atresidue))
(when coupling
(setf (parent-plug-name atresidue) (target-plug-name coupling)))
(let ((outgoing-plug-names-to-joint-map (fill-atresidue joint-tree atresidue parent-joint atmolecule-index atresidue-index atom-table))
(current-topology (monomer-topology monomer oligomer)))
(setf (stereoisomer-name atresidue) (current-stereoisomer-name monomer oligomer)
(topology atresidue) current-topology
(conformation-index atresidue) 0)
(maphash (lambda (plug-name coupling)
(declare (ignore plug-name))
(unless (typep coupling 'ring-coupling)
(let ((directional-coupling coupling))
(when (eq (source-monomer directional-coupling) monomer)
(let* ((other-monomer (target-monomer directional-coupling))
(other-topology (monomer-topology other-monomer oligomer))
(other-residue-index (gethash other-monomer monomer-positions))
(other-residue (chem:content-at molecule other-residue-index))
(other-atresidue (atresidue-factory other-residue
ring-closing-monomer-map
other-monomer
other-topology))
(out-plug-name (source-plug-name coupling)))
(put-atresidue atmolecule other-atresidue other-residue-index)
(setf (gethash out-plug-name (children atresidue)) other-atresidue)
(let ((new-parent-joint (gethash out-plug-name outgoing-plug-names-to-joint-map)))
(recursively-build-children joint-tree
other-atresidue
atmolecule
molecule
ring-closing-monomer-map
atresidue
directional-coupling
other-monomer
oligomer
monomer-positions
atmolecule-index
other-residue-index
new-parent-joint
atom-table)))))))
(couplings monomer))))
(defun describe-recursively (atresidue prefix stream)
(princ prefix stream)
(when (parent-plug-name atresidue)
(princ (parent-plug-name atresidue) stream)
(princ " " stream))
(format stream "~a[~a]" (class-name (class-of atresidue)) (stereoisomer-name atresidue))
(loop for child-atresidue across (children atresidue)
do (describe-recursively child-atresidue (concatenate 'string prefix " ") stream)))
(defmethod print-object ((object atresidue) stream)
(print-unreadable-object (object stream :type t)
(format stream "~a[~a]" (class-name (class-of object)) (stereoisomer-name object))))
(defun add-joint (atresidue index joint)
(when (< (length (joints atresidue)) index)
(adjust-array (joints atresidue) (1+ index)))
(setf (aref (joints atresidue) index) joint))
(defun walk-joints (atresidue function)
(loop for joint across (joints atresidue)
for joint-index from 0
do (funcall function joint-index joint)))
#+(or)(eval-when (:compile-toplevel :execute :load-toplevel)
(export
'(
atmatter
ataggregate
atmolecules
atmolecule
root-atresidue
atresidues
atresidue
parent
parent-plug-name
id
children
stereoisomer-name
topology
conformation-index
joints
put-joint
walk-ataggregate-joints
update-internal-coordinates
zero-external-coordinates
))
)