-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathformulas.lisp
214 lines (174 loc) · 8.3 KB
/
formulas.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
;---------------------------------------------
; FORMULAS: This file contains some general formulas used in Copycat.
;---------------------------------------------
(in-package 'user)
(defun update-temperature (&aux rule-weakness)
; Updates the temperature, which is a function of the average total-unhappiness
; of objects on the workspace (weigted by importance) and the weakness of the
; rule.
(if* (not *clamp-temperature*)
then (setq rule-weakness
(if* (null *rule*)
then 100
else (fake-reciprocal (send *rule* :total-strength))))
(setq *temperature*
(weighted-average
`((,(send *workspace* :total-unhappiness) . 8)
(,rule-weakness . 2))))))
;---------------------------------------------
(defun get-answer-temperature-threshold-distribution (&aux bond-density)
; Returns the probability-distribution from which to
; choose a temperature threshold, used by rule-translator codelets in deciding
; whether or not to try to translate the rule and create an answer. Which
; distribution to use is a function of the amount of structure that has been
; built (irrespective of its strength). The more structure, the more the
; distribution is slanted towards low temperatures. The idea behind this
; can be given by listing the various cases:
;
; If lots of structure has been built and it is good, then
; the temperature will be low and it's probably a good time to try to
; create an answer, so return a distribution slanted towards low
; temperature, which, since the temperature is low, will make it likely
; that the rule-translator codelet will decide to create an answer.
;
; If lots of structure has been built and it isn't good, then the
; temperature will be high. Since the program has found some structure,
; it is likely that there *is* a better way of structuring things, so
; return a distribution slanted towards low temperature, i.e., make
; it unlikely to create an answer soon.
;
; If not much structure has been found, then it is not likely that much
; more will be found (since the rule-translator codelet most likely
; will not even be running until there has been opportunity to find
; structure if there is any). Thus the program shouldn't have to wait
; much longer to go ahead and create an answer, since the lack of structure
; at this point indicates that it probably will not be able to do much
; better. So return a distribution slanted more towards higher
; temperatures.
;
; This function only roughly measures how much structure there is.
(if* (and (= (send *initial-string* :length) 1)
(= (send *target-string* :length) 1))
then (setq bond-density 1)
else (setq bond-density
(/ (length (append (send *initial-string* :bond-list)
(send *target-string* :bond-list)))
(+ (1- (send *initial-string* :length))
(1- (send *target-string* :length))))))
(cond ((>= bond-density .8)
%very-low-answer-temperature-threshold-distribution%)
((>= bond-density .6)
%low-answer-temperature-threshold-distribution%)
((>= bond-density .4)
%medium-answer-temperature-threshold-distribution%)
((>= bond-density .2)
%high-answer-temperature-threshold-distribution%)
(t %very-high-answer-temperature-threshold-distribution%)))
;---------------------------------------------
(defun get-temperature-adjusted-probability (prob &aux low-prob-factor
result)
; This function is a filter: it inputs a value (from 0 to 100) and returns
; a probability (from 0 - 1) based on that value and the temperature. When
; the temperature is 0, the result is (/ value 100), but at higher
; temperatures, values below 50 get raised and values above 50 get lowered
; as a function of temperature.
; I think this whole formula could probably be simplified.
(setq result
(cond ((= prob 0) 0)
((<= prob .5)
(setq low-prob-factor (max 1 (truncate (abs (log prob 10)))))
(min (+ prob
(* (/ (- 10 (sqrt (fake-reciprocal *temperature*)))
100)
(- (expt 10 (- (1- low-prob-factor))) prob)))
.5))
((= prob .5) .5)
((> prob .5)
(max (- 1
(+ (- 1 prob)
(* (/ (- 10 (sqrt (fake-reciprocal *temperature*)))
100)
(- 1 (- 1 prob)))))
.5))))
result)
;---------------------------------------------
(defun test-get-temperature-adjusted-probability (prob)
(with-open-file (ostream "testfile" :direction :output
:if-does-not-exist :create
:if-exists :append)
(format ostream "prob: ~a~&" prob)
(loop for temp in '(0 10 20 30 40 50 60 70 80 90 100) do
(setq *temperature* temp)
(format ostream "Temperature: ~a; probability ~a~&"
temp (float (get-temperature-adjusted-probability prob))))
(format ostream "~%")))
;---------------------------------------------
(defun get-temperature-adjusted-value-list (value-list &aux exponent)
; Returns a list with values that are exponential functions of the original
; values, with the exponent being a function of the temperature. The higher
; the temperature, the bigger the difference between unequal values.
(setq exponent (+ (/ (fake-reciprocal *temperature*) 30) .5))
(loop for value in value-list collect (round (expt value exponent))))
;---------------------------------------------
(defun test-get-tempterature-adjusted-value-list (value-list)
(loop for temp in '(0 10 20 30 40 50 60 70 80 90 100) do
(setq *temperature* temp)
(format t "Temperature: ~a; adjusted-value-list: ~a~&"
temp (get-temperature-adjusted-value-list value-list))))
;---------------------------------------------
(defun get-post-codelet-probability (structure-category &aux probability)
; This function gives the program a simple form of self-watching. For a given
; structure-category (e.g., description, or bond), it returns a probability
; to use in deciding whether or not codelets looking for this type of
; structure should be posted.
(cond ((eq structure-category 'description)
(setq probability (/ (sqr *temperature*) 100)))
((eq structure-category 'bond)
(setq probability (send *workspace* :intra-string-unhappiness)))
((eq structure-category 'group)
(setq probability (send *workspace* :intra-string-unhappiness)))
((eq structure-category 'replacement)
(setq probability
(if* (send *workspace* :unreplaced-objects) then 100 else 0)))
((eq structure-category 'correspondence)
(setq probability (send *workspace* :inter-string-unhappiness)))
((eq structure-category 'rule)
(setq probability
(if* (null *rule*)
then 100 else (send *rule* :total-weakness))))
((eq structure-category 'translated-rule)
(setq probability (if* *rule* then 100 else 0))))
(/ probability 100))
;---------------------------------------------
(defun get-num-of-codelets-to-post (structure-category &aux number)
; This function gives the program a simple form of self-watching. For a given
; structure-category (e.g., description, or bond), it returns the number
; of codelets looking for this type of structure that should be posted.
(cond ((eq structure-category 'description)
(setq number 1))
((eq structure-category 'bond)
(setq number (case (send *workspace* :rough-num-of-unrelated-objects)
(few 1) (medium 2) (many 3))))
((eq structure-category 'group)
(setq number
(if* (null (send *workspace* :bond-list))
then 0
else (case (send *workspace*
:rough-num-of-ungrouped-objects)
(few 1) (medium 2) (many 3)))))
((eq structure-category 'replacement)
(setq number
(if* *rule*
then 0
else (case (send *workspace* :rough-num-of-unreplaced-objects)
(few 1) (medium 2) (many 3)))))
((eq structure-category 'correspondence)
(setq number
(case (send *workspace* :rough-num-of-uncorresponding-objects)
(few 1) (medium 3) (many 3))))
((eq structure-category 'rule)
(setq number 2))
((eq structure-category 'translated-rule)
(setq number (if* (null *rule*) then 0 else 1))))
number)
;---------------------------------------------