Diff -- /var/www/vhosts/3dshawn.com/shop.3dshawn.com/MODS/ShopCart/PricingExperiments.pm
Diff

/var/www/vhosts/3dshawn.com/shop.3dshawn.com/MODS/ShopCart/PricingExperiments.pm

added on local at 2026-07-01 22:09:38

Added
+526
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to e376c11a5bb8
Restore this content →
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.
1package MODS::ShopCart::PricingExperiments;
2#======================================================================
3# ShopCart - price-test + Van Westendorp survey helpers.
4#
5# Two adjacent tools that share the same Optimization page:
6# price_tests -- per-model bandit / rule-based price
7# adjuster (CRUD only this round; the
8# auto-priced bandit worker lands in a
9# follow-up).
10# price_surveys -- Van Westendorp Price Sensitivity Meter.
11# Seller creates a survey; buyers respond
12# via a public URL; results aggregate to
13# the four canonical intersection points:
14# PMC -- Point of Marginal Cheapness
15# PME -- Point of Marginal Expensiveness
16# OPP -- Optimum Price Point
17# IPP -- Indifference Price Point
18#
19# Survey response aggregation is done in plain Perl over the raw
20# rows in price_survey_responses -- N is small (sellers typically run
21# these on 50-500 buyers), so a hash + sort per page-load is fine. We
22# don't precompute or cache; results stay accurate the moment a new
23# response lands.
24#
25# Public surface:
26# $px = MODS::ShopCart::PricingExperiments->new;
27# $px->schema_ready($db, $dbh, $DB)
28# $px->list_user_price_tests($db, $dbh, $DB, $uid)
29# $px->list_user_surveys($db, $dbh, $DB, $uid)
30# $px->create_price_test($db, $dbh, $DB, $uid, %args)
31# $px->set_test_status($db, $dbh, $DB, $uid, $test_id, $status)
32# $px->delete_price_test($db, $dbh, $DB, $uid, $test_id)
33# $px->create_survey($db, $dbh, $DB, $uid, %args) -- returns ($id, $token)
34# $px->close_survey($db, $dbh, $DB, $uid, $survey_id)
35# $px->delete_survey($db, $dbh, $DB, $uid, $survey_id)
36# $px->record_survey_response($db, $dbh, $DB, $token, %p)
37# $px->survey_for_token($db, $dbh, $DB, $token)
38# $px->survey_results($db, $dbh, $DB, $uid, $survey_id)
39#======================================================================
40
41use strict;
42use warnings;
43use Digest::SHA qw(sha1_hex);
44
45sub new {
46 my ($class) = @_;
47 return bless {}, $class;
48}
49
50# ---- Schema probe ---------------------------------------------------
51sub schema_ready {
52 my ($self, $db, $dbh, $DB) = @_;
53 foreach my $t (qw(price_tests price_surveys price_survey_responses)) {
54 my $r = $db->db_readwrite($dbh, qq~
55 SELECT COUNT(*) AS n FROM information_schema.tables
56 WHERE table_schema='$DB' AND table_name='$t'
57 ~, $ENV{SCRIPT_NAME}, __LINE__);
58 return 0 unless $r && $r->{n};
59 }
60 # Probe for the columns we added in the migration -- pre-migration
61 # installs that only have the OLD price_surveys shape still pass
62 # the table-exists check above but lack public_token + status.
63 my $c = $db->db_readwrite($dbh, qq~
64 SELECT COUNT(*) AS n FROM information_schema.columns
65 WHERE table_schema='$DB' AND table_name='price_surveys'
66 AND column_name='public_token'
67 ~, $ENV{SCRIPT_NAME}, __LINE__);
68 return ($c && $c->{n}) ? 1 : 0;
69}
70
71# Ownership guard: a model must belong to the calling user (or to the
72# user's owner if they're a team member). We resolve to "effective
73# owner" by walking owner_user_id on the users row.
74sub _effective_owner {
75 my ($self, $db, $dbh, $DB, $uid) = @_;
76 $uid =~ s/[^0-9]//g if defined $uid;
77 return 0 unless $uid;
78 my $r = $db->db_readwrite($dbh, qq~
79 SELECT COALESCE(owner_user_id, id) AS owner
80 FROM `${DB}`.users WHERE id='$uid' LIMIT 1
81 ~, $ENV{SCRIPT_NAME}, __LINE__);
82 return ($r && $r->{owner}) ? $r->{owner} : $uid;
83}
84
85sub _model_belongs_to {
86 my ($self, $db, $dbh, $DB, $model_id, $owner_uid) = @_;
87 $model_id =~ s/[^0-9]//g if defined $model_id;
88 $owner_uid =~ s/[^0-9]//g if defined $owner_uid;
89 return 0 unless $model_id && $owner_uid;
90 my $r = $db->db_readwrite($dbh, qq~
91 SELECT id FROM `${DB}`.models
92 WHERE id='$model_id' AND user_id='$owner_uid' LIMIT 1
93 ~, $ENV{SCRIPT_NAME}, __LINE__);
94 return ($r && $r->{id}) ? 1 : 0;
95}
96
97# ---- Price tests (CRUD; bandit worker is future work) ---------------
98
99sub list_user_price_tests {
100 my ($self, $db, $dbh, $DB, $uid) = @_;
101 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
102 return () unless $owner;
103 return $db->db_readwrite_multiple($dbh, qq~
104 SELECT pt.id, pt.model_id, pt.current_price_cents, pt.test_rules,
105 pt.status, pt.last_adjusted_at, pt.created_at,
106 m.title AS model_title
107 FROM `${DB}`.price_tests pt
108 JOIN `${DB}`.models m ON m.id = pt.model_id
109 WHERE m.user_id='$owner'
110 ORDER BY pt.created_at DESC
111 ~, $ENV{SCRIPT_NAME}, __LINE__);
112}
113
114sub create_price_test {
115 my ($self, $db, $dbh, $DB, $uid, %a) = @_;
116 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
117 return { ok => 0, error => 'no user' } unless $owner;
118
119 my $mid = $a{model_id} || 0;
120 $mid =~ s/[^0-9]//g;
121 return { ok => 0, error => 'missing model_id' } unless $mid;
122 return { ok => 0, error => 'not your model' }
123 unless $self->_model_belongs_to($db, $dbh, $DB, $mid, $owner);
124
125 my $min_c = int($a{min_price_cents} || 0);
126 my $max_c = int($a{max_price_cents} || 0);
127 my $step = int($a{step_cents} || 100);
128 return { ok => 0, error => 'invalid range' } if $min_c <= 0 || $max_c <= $min_c;
129
130 # Pull the current model price as the starting point.
131 my $m = $db->db_readwrite($dbh, qq~
132 SELECT price_cents FROM `${DB}`.models WHERE id='$mid'
133 ~, $ENV{SCRIPT_NAME}, __LINE__);
134 my $current = ($m && $m->{price_cents}) ? $m->{price_cents} : $min_c;
135
136 # JSON-encode the rules. Hand-written so we don't need JSON::PP at
137 # call sites that already use the data through string compare only.
138 my $rules = sprintf(
139 '{"min":%d,"max":%d,"step":%d,"trigger":"%s","cooldown_hours":%d}',
140 $min_c, $max_c, $step,
141 ($a{trigger} || 'conversion'), int($a{cooldown_hours} || 24),
142 );
143 $rules =~ s/'/''/g;
144
145 $db->db_readwrite($dbh, qq~
146 INSERT INTO `${DB}`.price_tests
147 SET model_id='$mid',
148 current_price_cents='$current',
149 test_rules='$rules',
150 status='draft',
151 created_at=NOW()
152 ~, $ENV{SCRIPT_NAME}, __LINE__);
153 my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__);
154 return { ok => 1, id => ($r ? $r->{id} : 0) };
155}
156
157sub set_test_status {
158 my ($self, $db, $dbh, $DB, $uid, $test_id, $status) = @_;
159 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
160 return { ok => 0 } unless $owner;
161 $test_id =~ s/[^0-9]//g if defined $test_id;
162 return { ok => 0 } unless $test_id;
163 $status = '' unless defined $status;
164 $status = '' unless $status =~ /^(draft|running|paused|complete)$/;
165 return { ok => 0 } unless length $status;
166
167 # Ownership check via the join: only update if the test's model
168 # belongs to this owner.
169 my $own = $db->db_readwrite($dbh, qq~
170 SELECT pt.id FROM `${DB}`.price_tests pt
171 JOIN `${DB}`.models m ON m.id = pt.model_id
172 WHERE pt.id='$test_id' AND m.user_id='$owner' LIMIT 1
173 ~, $ENV{SCRIPT_NAME}, __LINE__);
174 return { ok => 0 } unless $own && $own->{id};
175
176 $db->db_readwrite($dbh, qq~
177 UPDATE `${DB}`.price_tests SET status='$status' WHERE id='$test_id'
178 ~, $ENV{SCRIPT_NAME}, __LINE__);
179 return { ok => 1 };
180}
181
182sub delete_price_test {
183 my ($self, $db, $dbh, $DB, $uid, $test_id) = @_;
184 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
185 return { ok => 0 } unless $owner;
186 $test_id =~ s/[^0-9]//g if defined $test_id;
187 return { ok => 0 } unless $test_id;
188
189 my $own = $db->db_readwrite($dbh, qq~
190 SELECT pt.id FROM `${DB}`.price_tests pt
191 JOIN `${DB}`.models m ON m.id = pt.model_id
192 WHERE pt.id='$test_id' AND m.user_id='$owner' LIMIT 1
193 ~, $ENV{SCRIPT_NAME}, __LINE__);
194 return { ok => 0 } unless $own && $own->{id};
195
196 $db->db_readwrite($dbh, qq~
197 DELETE FROM `${DB}`.price_tests WHERE id='$test_id'
198 ~, $ENV{SCRIPT_NAME}, __LINE__);
199 return { ok => 1 };
200}
201
202# ---- Van Westendorp surveys ----------------------------------------
203
204# Canonical four Van Westendorp prompts. Stored as the questions JSON
205# when survey_type='van_westendorp' so the public response page
206# renders identical wording for every survey.
207sub vw_default_questions {
208 return [
209 { key => 'too_cheap',
210 prompt => 'At what price would this model be so cheap that you would doubt its quality?' },
211 { key => 'bargain',
212 prompt => 'At what price would this model be a bargain -- a great deal for the money?' },
213 { key => 'expensive',
214 prompt => 'At what price would this model be starting to get expensive -- you would still consider buying, but you would have to think about it?' },
215 { key => 'too_expensive',
216 prompt => 'At what price would this model be so expensive that you would not consider buying it?' },
217 ];
218}
219
220sub list_user_surveys {
221 my ($self, $db, $dbh, $DB, $uid) = @_;
222 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
223 return () unless $owner;
224 return $db->db_readwrite_multiple($dbh, qq~
225 SELECT ps.id, ps.model_id, ps.survey_type, ps.title,
226 ps.public_token, ps.status, ps.response_count, ps.created_at,
227 m.title AS model_title
228 FROM `${DB}`.price_surveys ps
229 JOIN `${DB}`.models m ON m.id = ps.model_id
230 WHERE m.user_id='$owner'
231 ORDER BY ps.created_at DESC
232 ~, $ENV{SCRIPT_NAME}, __LINE__);
233}
234
235sub create_survey {
236 my ($self, $db, $dbh, $DB, $uid, %a) = @_;
237 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
238 return { ok => 0, error => 'no user' } unless $owner;
239
240 my $mid = $a{model_id} || 0;
241 $mid =~ s/[^0-9]//g;
242 return { ok => 0, error => 'missing model_id' } unless $mid;
243 return { ok => 0, error => 'not your model' }
244 unless $self->_model_belongs_to($db, $dbh, $DB, $mid, $owner);
245
246 my $title = defined $a{title} ? $a{title} : '';
247 $title =~ s/[\r\n]+/ /g;
248 $title =~ s/'/''/g;
249 $title = substr($title, 0, 191);
250
251 my $type = $a{survey_type} || 'van_westendorp';
252 $type = 'van_westendorp' unless $type =~ /^(van_westendorp|gabor_granger|custom)$/;
253
254 # Token: 40-char hex (sha1 of uid|mid|time|random) -- unique enough
255 # for public URLs without being a guess target.
256 my $rand = '';
257 $rand .= chr(int(rand(256))) for 1..16;
258 my $token = sha1_hex("$owner|$mid|" . time() . "|$rand");
259
260 # Default questions = canonical VW prompts when survey_type is
261 # van_westendorp. JSON-encoded as a simple array of {key,prompt}
262 # so the public page renders the same wording on every survey.
263 my $questions_json = '[]';
264 if ($type eq 'van_westendorp') {
265 my $qs = $self->vw_default_questions;
266 my @parts;
267 foreach my $q (@$qs) {
268 my $k = $q->{key}; $k =~ s/'/''/g;
269 my $p = $q->{prompt}; $p =~ s/'/''/g;
270 push @parts, sprintf('{"key":"%s","prompt":"%s"}', $k, $p);
271 }
272 $questions_json = '[' . join(',', @parts) . ']';
273 }
274 $questions_json =~ s/'/''/g;
275
276 $db->db_readwrite($dbh, qq~
277 INSERT INTO `${DB}`.price_surveys
278 SET model_id='$mid',
279 survey_type='$type',
280 title='$title',
281 public_token='$token',
282 status='open',
283 questions='$questions_json',
284 created_at=NOW()
285 ~, $ENV{SCRIPT_NAME}, __LINE__);
286 my $r = $db->db_readwrite($dbh, qq~SELECT LAST_INSERT_ID() AS id~, $ENV{SCRIPT_NAME}, __LINE__);
287 return { ok => 1, id => ($r ? $r->{id} : 0), token => $token };
288}
289
290sub close_survey {
291 my ($self, $db, $dbh, $DB, $uid, $survey_id) = @_;
292 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
293 return { ok => 0 } unless $owner;
294 $survey_id =~ s/[^0-9]//g if defined $survey_id;
295 return { ok => 0 } unless $survey_id;
296
297 my $own = $db->db_readwrite($dbh, qq~
298 SELECT ps.id FROM `${DB}`.price_surveys ps
299 JOIN `${DB}`.models m ON m.id = ps.model_id
300 WHERE ps.id='$survey_id' AND m.user_id='$owner' LIMIT 1
301 ~, $ENV{SCRIPT_NAME}, __LINE__);
302 return { ok => 0 } unless $own && $own->{id};
303
304 $db->db_readwrite($dbh, qq~
305 UPDATE `${DB}`.price_surveys
306 SET status='closed', completed_at=COALESCE(completed_at, NOW())
307 WHERE id='$survey_id'
308 ~, $ENV{SCRIPT_NAME}, __LINE__);
309 return { ok => 1 };
310}
311
312sub delete_survey {
313 my ($self, $db, $dbh, $DB, $uid, $survey_id) = @_;
314 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
315 return { ok => 0 } unless $owner;
316 $survey_id =~ s/[^0-9]//g if defined $survey_id;
317 return { ok => 0 } unless $survey_id;
318
319 my $own = $db->db_readwrite($dbh, qq~
320 SELECT ps.id FROM `${DB}`.price_surveys ps
321 JOIN `${DB}`.models m ON m.id = ps.model_id
322 WHERE ps.id='$survey_id' AND m.user_id='$owner' LIMIT 1
323 ~, $ENV{SCRIPT_NAME}, __LINE__);
324 return { ok => 0 } unless $own && $own->{id};
325
326 # CASCADE on the FK takes care of the response rows.
327 $db->db_readwrite($dbh, qq~
328 DELETE FROM `${DB}`.price_surveys WHERE id='$survey_id'
329 ~, $ENV{SCRIPT_NAME}, __LINE__);
330 return { ok => 1 };
331}
332
333# Public lookup -- used by /price_survey.cgi to render the form for an
334# anonymous respondent. We return the survey row PLUS the model title
335# + decoded questions list, but never any responses.
336sub survey_for_token {
337 my ($self, $db, $dbh, $DB, $token) = @_;
338 return undef unless defined $token && length $token;
339 my $safe = $token; $safe =~ s/[^a-f0-9]//gi; $safe = substr($safe, 0, 40);
340 return undef unless length($safe) == 40;
341 my $r = $db->db_readwrite($dbh, qq~
342 SELECT ps.id, ps.model_id, ps.survey_type, ps.title, ps.status,
343 ps.questions, m.title AS model_title
344 FROM `${DB}`.price_surveys ps
345 JOIN `${DB}`.models m ON m.id = ps.model_id
346 WHERE ps.public_token='$safe' LIMIT 1
347 ~, $ENV{SCRIPT_NAME}, __LINE__);
348 return ($r && $r->{id}) ? $r : undef;
349}
350
351# Insert a response row. All four VW price fields are optional at the
352# DB level so partially-filled surveys still record useful data. The
353# aggregator just skips missing values.
354sub record_survey_response {
355 my ($self, $db, $dbh, $DB, $token, %p) = @_;
356 my $s = $self->survey_for_token($db, $dbh, $DB, $token);
357 return { ok => 0, error => 'survey not found' } unless $s;
358 return { ok => 0, error => 'survey closed' } unless ($s->{status} || '') eq 'open';
359
360 my @cols = qw(too_cheap bargain expensive too_expensive);
361 my %vals;
362 foreach my $k (@cols) {
363 my $v = $p{$k};
364 $v = '' unless defined $v;
365 $v =~ s/[^0-9.]//g; # accept "12.99" -> we'll multiply by 100
366 $v = 0 + ($v || 0);
367 $vals{$k} = ($v > 0) ? int($v * 100) : 0;
368 }
369 # Require at least one answer to count the response.
370 my $any = 0; $any += $vals{$_} for @cols;
371 return { ok => 0, error => 'no answers' } unless $any;
372
373 my $email = defined $p{email} ? $p{email} : '';
374 $email =~ s/[\r\n]+/ /g; $email =~ s/'/''/g; $email = substr($email, 0, 191);
375 my $ip = $ENV{REMOTE_ADDR} || ''; $ip =~ s/'/''/g; $ip = substr($ip, 0, 45);
376 my $sid = $s->{id};
377
378 my $col_assign = sub {
379 my ($col, $v) = @_;
380 return $v ? "$col='$v'" : "$col=NULL";
381 };
382
383 $db->db_readwrite($dbh, qq~
384 INSERT INTO `${DB}`.price_survey_responses
385 SET survey_id='$sid',
386 ~ . $col_assign->('vw_too_cheap_cents', $vals{too_cheap}) . qq~,
387 ~ . $col_assign->('vw_bargain_cents', $vals{bargain}) . qq~,
388 ~ . $col_assign->('vw_expensive_cents', $vals{expensive}) . qq~,
389 ~ . $col_assign->('vw_too_expensive_cents', $vals{too_expensive}) . qq~,
390 respondent_email='$email',
391 respondent_ip='$ip'
392 ~, $ENV{SCRIPT_NAME}, __LINE__);
393
394 $db->db_readwrite($dbh, qq~
395 UPDATE `${DB}`.price_surveys SET response_count = response_count + 1 WHERE id='$sid'
396 ~, $ENV{SCRIPT_NAME}, __LINE__);
397
398 return { ok => 1, survey_id => $sid };
399}
400
401# Survey results aggregator. Computes the four canonical Van Westendorp
402# intersection points by:
403# 1. Sorting each price-question's responses ascending
404# 2. Building cumulative percentage curves
405# (too_cheap = inverse cumulative -- "% would say AT THIS PRICE or higher")
406# 3. Finding where pairs of curves cross. Specifically:
407# PMC -- too_cheap (decreasing) ∩ bargain (decreasing)
408# PME -- expensive (increasing) ∩ too_expensive (increasing)
409# OPP -- too_cheap (decreasing) ∩ too_expensive (increasing)
410# IPP -- bargain (decreasing) ∩ expensive (increasing)
411#
412# Returns a hash:
413# { ok=>1, n=>N, pmc=>cents, pme=>cents, opp=>cents, ipp=>cents,
414# curve_points => [ {price_cents, too_cheap_pct, bargain_pct,
415# expensive_pct, too_expensive_pct}, ... ] }
416# Caller renders the prices as $X.XX and can plot curve_points if they
417# want a chart.
418sub survey_results {
419 my ($self, $db, $dbh, $DB, $uid, $survey_id) = @_;
420 my $owner = $self->_effective_owner($db, $dbh, $DB, $uid);
421 return { ok => 0 } unless $owner;
422 $survey_id =~ s/[^0-9]//g if defined $survey_id;
423 return { ok => 0 } unless $survey_id;
424
425 my $own = $db->db_readwrite($dbh, qq~
426 SELECT ps.id FROM `${DB}`.price_surveys ps
427 JOIN `${DB}`.models m ON m.id = ps.model_id
428 WHERE ps.id='$survey_id' AND m.user_id='$owner' LIMIT 1
429 ~, $ENV{SCRIPT_NAME}, __LINE__);
430 return { ok => 0 } unless $own && $own->{id};
431
432 my @rows = $db->db_readwrite_multiple($dbh, qq~
433 SELECT vw_too_cheap_cents, vw_bargain_cents,
434 vw_expensive_cents, vw_too_expensive_cents
435 FROM `${DB}`.price_survey_responses WHERE survey_id='$survey_id'
436 ~, $ENV{SCRIPT_NAME}, __LINE__);
437 my $n = scalar @rows;
438 return { ok => 1, n => 0 } unless $n;
439
440 my @too_cheap = map { $_->{vw_too_cheap_cents} } grep { $_->{vw_too_cheap_cents} } @rows;
441 my @bargain = map { $_->{vw_bargain_cents} } grep { $_->{vw_bargain_cents} } @rows;
442 my @expensive = map { $_->{vw_expensive_cents} } grep { $_->{vw_expensive_cents} } @rows;
443 my @too_expensive = map { $_->{vw_too_expensive_cents} } grep { $_->{vw_too_expensive_cents} } @rows;
444
445 # Build the set of distinct price points to evaluate the curves at.
446 # Union of all submitted prices -- the curves only change values
447 # at these discrete points.
448 my %seen;
449 foreach my $p (@too_cheap, @bargain, @expensive, @too_expensive) {
450 $seen{$p}++;
451 }
452 my @points = sort { $a <=> $b } keys %seen;
453
454 # Cumulative-percentage helpers. "decreasing" curves (too_cheap +
455 # bargain) drop as price rises -- at price P, the % is the share
456 # of respondents whose answer was >= P. "increasing" curves
457 # (expensive + too_expensive) rise as price rises -- share whose
458 # answer was <= P.
459 my @cnt_tc = sort { $a <=> $b } @too_cheap;
460 my @cnt_ba = sort { $a <=> $b } @bargain;
461 my @cnt_ex = sort { $a <=> $b } @expensive;
462 my @cnt_te = sort { $a <=> $b } @too_expensive;
463
464 my $share_ge = sub {
465 my ($p, $arr_ref) = @_;
466 my $total = scalar @$arr_ref;
467 return 0 unless $total;
468 my $hits = grep { $_ >= $p } @$arr_ref;
469 return $hits / $total;
470 };
471 my $share_le = sub {
472 my ($p, $arr_ref) = @_;
473 my $total = scalar @$arr_ref;
474 return 0 unless $total;
475 my $hits = grep { $_ <= $p } @$arr_ref;
476 return $hits / $total;
477 };
478
479 my @curve;
480 foreach my $p (@points) {
481 push @curve, {
482 price_cents => $p,
483 too_cheap_pct => $share_ge->($p, \@cnt_tc),
484 bargain_pct => $share_ge->($p, \@cnt_ba),
485 expensive_pct => $share_le->($p, \@cnt_ex),
486 too_expensive_pct => $share_le->($p, \@cnt_te),
487 };
488 }
489
490 # Find where two curves cross by scanning adjacent points until
491 # the sign of (curve_a - curve_b) flips, then linearly interpolating
492 # between the two adjacent prices.
493 my $intersect = sub {
494 my ($key_a, $key_b) = @_;
495 return 0 unless @curve >= 2;
496 for (my $i = 1; $i < @curve; $i++) {
497 my $d_prev = $curve[$i-1]{$key_a} - $curve[$i-1]{$key_b};
498 my $d_curr = $curve[$i ]{$key_a} - $curve[$i ]{$key_b};
499 if (($d_prev <= 0 && $d_curr >= 0) || ($d_prev >= 0 && $d_curr <= 0)) {
500 # Linear interpolation. If both are zero, just return
501 # the left price -- they cross at any value here.
502 my $span = $d_prev - $d_curr;
503 if (abs($span) < 1e-9) {
504 return $curve[$i-1]{price_cents};
505 }
506 my $t = $d_prev / $span;
507 my $price = $curve[$i-1]{price_cents}
508 + $t * ($curve[$i]{price_cents} - $curve[$i-1]{price_cents});
509 return int($price);
510 }
511 }
512 return 0; # no crossing found
513 };
514
515 return {
516 ok => 1,
517 n => $n,
518 pmc => $intersect->('too_cheap_pct', 'bargain_pct'),
519 pme => $intersect->('expensive_pct', 'too_expensive_pct'),
520 opp => $intersect->('too_cheap_pct', 'too_expensive_pct'),
521 ipp => $intersect->('bargain_pct', 'expensive_pct'),
522 curve_points => \@curve,
523 };
524}
525
5261;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help