1 |
#!__PERL_LOCATION__ -w # -*- mode: perl -*- |
2 |
|
3 |
# GIFT, a flexible content based image retrieval system. |
4 |
# Copyright (C) 1998, 1999, 2000, 2001, 2002, CUI University of Geneva |
5 |
|
6 |
# This program is free software; you can redistribute it and/or modify |
7 |
# it under the terms of the GNU General Public License as published by |
8 |
# the Free Software Foundation; either version 2 of the License, or |
9 |
# (at your option) any later version. |
10 |
|
11 |
# This program is distributed in the hope that it will be useful, |
12 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 |
# GNU General Public License for more details. |
15 |
|
16 |
# You should have received a copy of the GNU General Public License |
17 |
# along with this program; if not, write to the Free Software |
18 |
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
19 |
|
20 |
# Author of this file: Wolfgang Müller |
21 |
# |
22 |
require 5.002; |
23 |
#use strict; |
24 |
use Socket; |
25 |
use FileHandle; |
26 |
use English; |
27 |
use IO::File; |
28 |
use IO::Socket; |
29 |
use XML::Parser; |
30 |
use CQueryParadigmMatcher; |
31 |
|
32 |
=pod |
33 |
|
34 |
It might be useful for a feedback client to treat multiple sessions at the same time and |
35 |
to gather the corresponding information. The session data is stored in CSessions |
36 |
|
37 |
=cut |
38 |
|
39 |
package CFeedbackClient; |
40 |
require Exporter; |
41 |
|
42 |
@ISA= qw(Exporter |
43 |
CQueryParadigmMatcher); |
44 |
@EXPORT= qw(new |
45 |
setAddress |
46 |
doQueryGroup |
47 |
startSession |
48 |
saveSession |
49 |
closeSession |
50 |
configureSession |
51 |
makeQueryString |
52 |
sendQueryString |
53 |
); |
54 |
|
55 |
|
56 |
############################################################# |
57 |
# |
58 |
# A script for performing |
59 |
# benchmarks on CBIRS systems |
60 |
# which use MRML |
61 |
# |
62 |
############################################################# |
63 |
# |
64 |
# |
65 |
# WARNING: this code is quick and dirty, but flexible. |
66 |
# it will be difficult to make it multi-threaded, but |
67 |
# this probably will not be interesting for a while |
68 |
# |
69 |
# |
70 |
############################################################# |
71 |
|
72 |
################################################## |
73 |
# |
74 |
# maintaining the xpath to the currently parsed tag |
75 |
# |
76 |
# what we are doing here is to have a path like |
77 |
# /root-element-name/child-element-name/grandchild-element-name |
78 |
# to the currently parsed XML element. |
79 |
# In the example above, the root XML element of the document |
80 |
# has the name "root-element-name", the currently parsed XML element |
81 |
# has the name "grandchild-element-name" |
82 |
|
83 |
############################## |
84 |
# |
85 |
# pushes the currently parsed XML element to the back of the path |
86 |
# |
87 |
sub pushToXMLPath( $ ){ |
88 |
|
89 |
my$self=shift; |
90 |
|
91 |
my$inElement=shift; |
92 |
|
93 |
push @{$self->{path}},$inElement; |
94 |
|
95 |
} |
96 |
############################## |
97 |
# |
98 |
# pops the last name from the path |
99 |
# |
100 |
sub popFromXMLPath( ){ |
101 |
|
102 |
my$self=shift; |
103 |
return pop @{$self->{path}}; |
104 |
|
105 |
} |
106 |
############################## |
107 |
# |
108 |
# clears the path |
109 |
# |
110 |
sub clearXMLPath( ){ |
111 |
|
112 |
my$self=shift; |
113 |
$self->{path}=[]; |
114 |
|
115 |
} |
116 |
|
117 |
############################## |
118 |
# |
119 |
# transforms the path to a string |
120 |
# |
121 |
sub getXMLPath( ){ |
122 |
|
123 |
my$self=shift; |
124 |
"/".join("/",@{$self->{path}}); |
125 |
|
126 |
} |
127 |
|
128 |
############################################################ |
129 |
# |
130 |
# constructor |
131 |
# |
132 |
############################## |
133 |
# |
134 |
# new |
135 |
# |
136 |
sub new( ){ |
137 |
my $class = shift; |
138 |
my $self = {}; |
139 |
bless $self, $class; |
140 |
$self->initialize(); |
141 |
return $self; |
142 |
} |
143 |
############################## |
144 |
# |
145 |
# initialises this: |
146 |
# create an XML parser |
147 |
# |
148 |
sub initialize(){ |
149 |
my$self=shift; |
150 |
|
151 |
$self->clearResultList(); |
152 |
|
153 |
$self->{locQuery}=[]; |
154 |
|
155 |
$self->{parser} = new XML::Parser(Handlers => {Start => \&handleStart, |
156 |
End => \&handleEnd, |
157 |
}); |
158 |
|
159 |
# Make the parser know who is this structure |
160 |
$self->{parser}->{mCaller}=$self; |
161 |
$self->{parser}->{mMagic}=42; |
162 |
############################### |
163 |
# |
164 |
# for quick changes what to look at when debugging/testing |
165 |
# set the value for a given function to "1" for getting |
166 |
# debugging code printed in this function |
167 |
# warning: this is done by hand, there is nothing automatic... |
168 |
# |
169 |
# HM 070301 added debug switch others, so we can have a completely silent mode |
170 |
$self->{vDEBUG}={ |
171 |
configureSession => 0, |
172 |
startSession => 0, |
173 |
addCollection => 0, |
174 |
doFirstQueryStep => 0, |
175 |
doQueryStep => 0, |
176 |
readAndParse => 0, |
177 |
buildNewQuery => 0, |
178 |
handleStart => 0, |
179 |
handleEnd => 0, |
180 |
setRelevantImages => 0, |
181 |
sendQueryString => 0, |
182 |
others => 0, |
183 |
}; |
184 |
# |
185 |
# printing which functions are to be debugged |
186 |
# |
187 |
print "Printing debugging info for the functions:\n" if ($self->{debug}->{others}); |
188 |
{ |
189 |
my $i; |
190 |
foreach $i (keys(%{$self->{vDEBUG}})){ |
191 |
if($self->{vDEBUG}->{$i}){ |
192 |
print "$i\n"; |
193 |
} |
194 |
} |
195 |
} |
196 |
|
197 |
############################### |
198 |
# |
199 |
# Initialise using reasonable values |
200 |
# |
201 |
|
202 |
# |
203 |
# initially no algorithms available and none chosen |
204 |
# |
205 |
$self->clearAlgorithm(); |
206 |
$self->clearCollection(); |
207 |
$self->setSessionID(""); |
208 |
|
209 |
# |
210 |
# query for 20 images without cutoff |
211 |
# |
212 |
$self->setCutoff(0.0); |
213 |
$self->setResultSize(20); |
214 |
|
215 |
# |
216 |
# talk to the localhost at port 12789 |
217 |
# |
218 |
$self->setAddress("localhost:12789"); |
219 |
} |
220 |
|
221 |
############################## |
222 |
# |
223 |
# Set a new address for the CBIR server |
224 |
# |
225 |
# Parameters: |
226 |
# inAddress: Address in "server:port" format |
227 |
# e.g. "localhost:12789" |
228 |
sub setAddress( $ ){ |
229 |
my$self=shift; |
230 |
my $inAddress=shift; |
231 |
($self->{mHost},$self->{mPort})=split(":",$inAddress); |
232 |
} |
233 |
|
234 |
|
235 |
############################### |
236 |
# |
237 |
# Setting the array of relevant images |
238 |
# the relevance feedback will be generated |
239 |
# based on these images. |
240 |
# |
241 |
# Parameter: |
242 |
# a list of URLs of relevant images |
243 |
# |
244 |
sub setRelevantImages{ |
245 |
my$self=shift; |
246 |
#a list of the relevant images |
247 |
$self->{gRelevantImages}=[]; |
248 |
@{$self->{gRelevantImages}}=@_; |
249 |
|
250 |
# |
251 |
# building a hash to look up |
252 |
# if a given url belongs to an |
253 |
# image from the list |
254 |
# |
255 |
my $i; |
256 |
foreach $i (@{$self->{gRelevantImages}}){ |
257 |
print "relevant image: $i\n" if($self->{vDEBUG}->{setRelevantImages}); |
258 |
$self->{locRelevantHash}->{$i}=1; |
259 |
} |
260 |
} |
261 |
|
262 |
############################### |
263 |
# |
264 |
# get the list of relevant images |
265 |
# |
266 |
sub getRelevantImages(){ |
267 |
my$self=shift; |
268 |
return $self->{gRelevantImages}; |
269 |
} |
270 |
|
271 |
|
272 |
######################################### |
273 |
# |
274 |
# HELPERS FOR XML WRITING |
275 |
# (largely unused, but its a c++-reflex ;-) |
276 |
# in perl things like that are more quickly done |
277 |
# by hand) |
278 |
# |
279 |
|
280 |
# |
281 |
# attribute-value pair to attribute="value" |
282 |
# |
283 |
sub toAttribute{ |
284 |
my$self=shift; |
285 |
my $inName= shift; |
286 |
my $inValue= shift; |
287 |
|
288 |
return " $inName=\"$inValue\""; |
289 |
} |
290 |
|
291 |
# |
292 |
# Elementname, list of attribute/value pairs => element start tag |
293 |
# |
294 |
sub toStartTag( $$$ ){ |
295 |
my$self=shift; |
296 |
|
297 |
|
298 |
my $inEmpty=shift; |
299 |
my $inName=shift; |
300 |
my $inAttributes=shift; |
301 |
|
302 |
my $lReturnValue=""; |
303 |
|
304 |
my $i; |
305 |
|
306 |
foreach $i (values(%$inAttributes)){ |
307 |
$lReturnValue.=$self->toAttribute(@{$i}); |
308 |
} |
309 |
|
310 |
if($inEmpty){ |
311 |
return "<$inName $lReturnValue/>\n"; |
312 |
}else{ |
313 |
return "<$inName $lReturnValue>\n"; |
314 |
} |
315 |
} |
316 |
# |
317 |
# Element name to element end tag |
318 |
# |
319 |
sub toEndTag( $ ){ |
320 |
my$self=shift; |
321 |
|
322 |
my $inName=shift; |
323 |
return "</$inName>\n"; |
324 |
} |
325 |
|
326 |
######################################## |
327 |
# |
328 |
# making a query string |
329 |
# |
330 |
# PARAMETERS: |
331 |
# lQueryImages: a REFERENCE to a list of URLs |
332 |
# |
333 |
# OPTIONAL: |
334 |
# |
335 |
# inSession: the MRML session-id of this session |
336 |
# inAlgorithm: the number of the algorithm to be used |
337 |
# inCollection: the number of the collection to be used. |
338 |
# both numbers are the number in the sequence in which they |
339 |
# were sent by the MRML server when the information was requested |
340 |
# by this client |
341 |
sub makeQueryString( $;$$$ ){ |
342 |
my$self=shift; |
343 |
my $lQueryImages=shift; |
344 |
my $inSession=(shift || $self->getSessionID()); |
345 |
my ($inAlgorithm)=$self->getAlgorithmID(shift); |
346 |
my ($inCollection)=$self->getCollectionID(shift); |
347 |
|
348 |
my $lAdditionalAlgorithmAttributes=shift || ""; |
349 |
|
350 |
my $inResultSize=$self->getResultSize(); # the desired result size |
351 |
my $inCutoff=$self->getCutoff(); # the cutoff. |
352 |
|
353 |
|
354 |
if($self->{vDEBUG}->{makeQueryString}){ |
355 |
print $inSession,"\n"; |
356 |
print $inResultSize,"\n"; |
357 |
print $inCutoff,"\n"; |
358 |
print $inCollection,"\n"; |
359 |
print $inAlgorithm,"\n"; |
360 |
} |
361 |
|
362 |
|
363 |
# |
364 |
# building the string "query-step" + headers |
365 |
# |
366 |
my $lResult=qq(<?xml version="1.0" standalone="no" ?> |
367 |
<!DOCTYPE mrml SYSTEM "~/public_html/dtd/mrml.dtd"> |
368 |
<mrml session-id="$inSession"> |
369 |
<query-step |
370 |
result-size="$inResultSize" |
371 |
result-cutoff="$inCutoff" |
372 |
collection-id="$inCollection" |
373 |
algorithm-id="$inAlgorithm"> |
374 |
<user-relevance-element-list>); |
375 |
|
376 |
foreach $i (sort {$$a[0] cmp $$b[0]} @$lQueryImages){ |
377 |
|
378 |
my($lURL,$lRelevance)=@$i; |
379 |
|
380 |
|
381 |
$lResult.=qq( |
382 |
<user-relevance-element |
383 |
user-relevance="$lRelevance" |
384 |
image-location="$lURL"/> |
385 |
); |
386 |
} |
387 |
|
388 |
$lResult.=qq(</user-relevance-element-list> |
389 |
</query-step> |
390 |
</mrml> |
391 |
); |
392 |
return $lResult; |
393 |
} |
394 |
|
395 |
############################################################ |
396 |
# |
397 |
# Handling incoming MRML |
398 |
# using XML::Parser |
399 |
# |
400 |
|
401 |
######################################## |
402 |
# |
403 |
# Building and maintaining a list of query results |
404 |
# |
405 |
############################## |
406 |
# |
407 |
# clear the list of results |
408 |
# |
409 |
sub clearResultList(){ |
410 |
my$self=shift; |
411 |
|
412 |
$self->{locResultList}=[]; |
413 |
} |
414 |
|
415 |
############################## |
416 |
# |
417 |
# add a URL-userrelevance pair to the list of results |
418 |
# PARAMETERS: |
419 |
# inURL the URL |
420 |
# inUserRelevance the relevancelevel |
421 |
sub addToResultList( $$ ){ |
422 |
my$self=shift; |
423 |
|
424 |
my $inURL= shift; |
425 |
my $inUserRelevance= shift; |
426 |
|
427 |
push @{$self->{locResultList}},[$inURL,$inUserRelevance]; |
428 |
} |
429 |
############################## |
430 |
# |
431 |
# get the list of URL-userrelevance pairs |
432 |
# the result is a reference. |
433 |
# |
434 |
sub getResultList( ){ |
435 |
my$self=shift; |
436 |
|
437 |
return $self->{locResultList}; |
438 |
} |
439 |
############################## |
440 |
# |
441 |
# turns the list of URL-userrelevance pairs |
442 |
# into a hash and returns a reference to this hash |
443 |
# |
444 |
sub getResultHash( ){ |
445 |
my$self=shift; |
446 |
|
447 |
my @lResultList=@{$self->getResultList( )}; |
448 |
|
449 |
my $lReturnValue={}; |
450 |
|
451 |
foreach $i (@lResultList){ |
452 |
$lReturnValue->{$i->[0]}=$i->[1]; |
453 |
} |
454 |
|
455 |
return $lReturnValue; |
456 |
} |
457 |
######################################## |
458 |
# |
459 |
# Expat parser handlers |
460 |
# |
461 |
|
462 |
############################## |
463 |
# |
464 |
# handle the start of an element |
465 |
# |
466 |
sub handleStart( $$ ){ |
467 |
|
468 |
my $self=shift; |
469 |
|
470 |
die "BLACK MAGIC!" if ($self->{mMagic}!=42); |
471 |
|
472 |
$self=$self->{mCaller}; |
473 |
|
474 |
my $inElement=shift; |
475 |
|
476 |
$self->pushToXMLPath($inElement); |
477 |
|
478 |
my %inAttributes=@_; |
479 |
|
480 |
my $lPath=$self->getXMLPath(); |
481 |
|
482 |
|
483 |
# |
484 |
# print debugging info if necessary |
485 |
# |
486 |
if($self->{vDEBUG}->{handleStart}){ |
487 |
print("start ",$inElement,",",join(":",%inAttributes),"\n"); |
488 |
} |
489 |
# |
490 |
# add an algorithm to the list of possible algorithms |
491 |
# |
492 |
if($lPath=~m:algorithm-list/algorithm$:){ |
493 |
$self->addAlgorithm($inAttributes{"algorithm-type"}); |
494 |
} |
495 |
# |
496 |
# add a collection to the list of possible collections |
497 |
# |
498 |
if($lPath=~m:collection-list/collection$:){ |
499 |
$self->addCollection($inAttributes{"collection-id"}); |
500 |
} |
501 |
# |
502 |
# add a collection to the list of possible collections |
503 |
# |
504 |
if($lPath=~m:algorithm/query-paradigm-list/query-paradigm:){ |
505 |
if($self->{vDEBUG}->{handleStart}){ |
506 |
print "add-QP§§§§§§§§§§§§§$inAttributes{'interaction-type'}§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§§\n"; |
507 |
} |
508 |
$self->addQueryParadigmToCurrentAlgorithm(\%inAttributes); |
509 |
} |
510 |
if($lPath=~m:collection/query-paradigm-list/query-paradigm:){ |
511 |
$self->addQueryParadigmToCurrentCollection(\%inAttributes); |
512 |
} |
513 |
|
514 |
if($lPath eq "/mrml"){ |
515 |
$self->setSessionID($inAttributes{"session-id"}); |
516 |
} |
517 |
|
518 |
if($inElement eq "query-result-element-list"){ |
519 |
$self->clearResultList(); |
520 |
} |
521 |
|
522 |
# |
523 |
# |
524 |
# |
525 |
if($inElement eq "query-result-element"){ |
526 |
$self->addToResultList($inAttributes{"image-location"}, |
527 |
$inAttributes{"calculated-similarity"}); |
528 |
} |
529 |
} |
530 |
|
531 |
############################## |
532 |
# |
533 |
# handle the end of an element |
534 |
# |
535 |
sub handleEnd( $ ){ |
536 |
my $self=shift; |
537 |
$self=$self->{mCaller}; |
538 |
|
539 |
my $inElement=shift; |
540 |
|
541 |
$self->popFromXMLPath($inElement); |
542 |
|
543 |
if($inElement eq "query-result"){ |
544 |
$self->buildNewQuery($self->getResultList(), |
545 |
$self->{locRelevantHash}); |
546 |
} |
547 |
print "end ",$inElement,"\n" if($self->{vDEBUG}->{handleEnd}); |
548 |
} |
549 |
|
550 |
|
551 |
############################################################ |
552 |
# |
553 |
# Accessors |
554 |
# |
555 |
# |
556 |
|
557 |
############################### |
558 |
# |
559 |
# The following three functions support you in |
560 |
# opening several sessions |
561 |
# |
562 |
|
563 |
############################## |
564 |
# |
565 |
# Clear the list of open sessions |
566 |
# |
567 |
sub clearSessionIDList(){ |
568 |
my$self=shift; |
569 |
$self->{mSessionIDList}=[]; |
570 |
} |
571 |
|
572 |
############################## |
573 |
# |
574 |
# add an MRML session-id to the list of open sessions |
575 |
# |
576 |
sub addSessionIDToList( $ ){ |
577 |
my$self=shift; |
578 |
|
579 |
my $lAddedItem= shift || $self->getSessionID(); |
580 |
|
581 |
$self->clearSessionID() unless defined($self->{mSessionIDList}); |
582 |
|
583 |
push @{$self->{mSessionIDList}}, |
584 |
} |
585 |
############################## |
586 |
# |
587 |
# get either the last or the nth session-id |
588 |
# from the list |
589 |
# PARAMETER |
590 |
# inN : the n-th session-id in the list is to be returned |
591 |
sub getSessionIDFromList( ;$ ){ |
592 |
my$self=shift; |
593 |
|
594 |
return $self->{mSessionIDList}->[(0 || shift)]; |
595 |
} |
596 |
|
597 |
|
598 |
############################### |
599 |
# |
600 |
# setSessionID is used at each mrml-message |
601 |
# to set the SessionID |
602 |
# TO THE ONE USED IN THE LAST MESSAGE |
603 |
# |
604 |
# remark: THIS IS NOT BEAUTIFUL |
605 |
# |
606 |
sub setSessionID( $ ){ |
607 |
my$self=shift; |
608 |
|
609 |
$self->{gSessionID}=shift; |
610 |
} |
611 |
# |
612 |
# get the sessionID as written by the function above |
613 |
# |
614 |
sub getSessionID( ){ |
615 |
my$self=shift; |
616 |
|
617 |
return $self->{gSessionID} if defined($self->{gSessionID}); |
618 |
return "no-session-id-available"; |
619 |
} |
620 |
######################################## |
621 |
# |
622 |
# creating/maintaining a list of all algorithms available |
623 |
# |
624 |
# |
625 |
############################## |
626 |
# |
627 |
# clear |
628 |
# |
629 |
sub clearAlgorithm( ){ |
630 |
my$self=shift; |
631 |
return $self->{algorithm}=[]; |
632 |
} |
633 |
############################## |
634 |
# |
635 |
# add to the "current" algorithm a query-paradigm. |
636 |
# the "current" algorithm is defined as the one |
637 |
# containing the query-paradigm tag in question |
638 |
# |
639 |
sub addQueryParadigmToCurrentAlgorithm( $ ){ |
640 |
my $self=shift; |
641 |
my $lNewQueryParadigm=shift; |
642 |
|
643 |
if($self->{vDEBUG}->{addQueryParadigmToCurrentAlgorithm}){ |
644 |
print "addQueryParadigmToCurrentAlgorithm Acting on algorithm $self->{algorithm}->[-1]->{'algorithm-id'}\n"; |
645 |
} |
646 |
$self->{algorithm}->[-1]->{"query-paradigm-list"}=[] |
647 |
unless defined($self->{algorithm}->[-1]->{"query-paradigm-list"}); |
648 |
|
649 |
# add this paradigm to the hash of query paradigms |
650 |
push @{$self->{algorithm}->[-1]->{"query-paradigm-list"}},$lNewQueryParadigm; |
651 |
} |
652 |
############################## |
653 |
# |
654 |
# add an algorithm to the list of available algorithms |
655 |
# |
656 |
sub addAlgorithm( $ ){ |
657 |
my$self=shift; |
658 |
|
659 |
my $lAlgorithmID=shift; |
660 |
|
661 |
my $lNewAlgorithm={"algorithm-id" => $lAlgorithmID, |
662 |
"query-paradigm-list" => []}; |
663 |
|
664 |
print("\naddalgorithm ",join(",",@{$lNewAlgorithm}),"\n") if $vDEBUG{addAlgorithm}; |
665 |
|
666 |
|
667 |
$self->clearAlgorithm() unless defined $self->{algorithm}; |
668 |
|
669 |
push @{$self->{algorithm}},$lNewAlgorithm; |
670 |
} |
671 |
############################## |
672 |
# |
673 |
# get either the 0th or the Nth algorithm from the list of available algorithms |
674 |
# Parameters: N |
675 |
# |
676 |
# RETURNVALUE: the algorithm given back by this is a hash containing the algorithm-id |
677 |
# as well as the list of available query paradigms |
678 |
# |
679 |
sub getAlgorithm( ;$){ |
680 |
my$self=shift; |
681 |
|
682 |
return $self->{algorithm}->[(shift || 0)]; |
683 |
} |
684 |
############################## |
685 |
# |
686 |
# get either the 0th or the Nth algorithm-id from the list of available algorithms |
687 |
# |
688 |
# |
689 |
sub getAlgorithmID( ;$){ |
690 |
my$self=shift; |
691 |
|
692 |
my $inAlgorithmNumber=shift; |
693 |
|
694 |
if($inAlgorithmNumber=~m/[^0-9 \t]/){ |
695 |
return $inAlgorithmNumber;#in fact, the algorithm number was already an ID |
696 |
} |
697 |
|
698 |
return $self->getAlgorithm($inAlgorithmNumber||0)->{"algorithm-id"} if defined($self->getAlgorithm($inAlgorithmNumber||0)->{"algorithm-id"}); |
699 |
return "adefault"; |
700 |
} |
701 |
|
702 |
############################## |
703 |
# |
704 |
# get either the 0th or the Nth algorithm-type from the list of available algorithms |
705 |
# |
706 |
# XXX: CHECK IF THIS FUNCTION IS USED |
707 |
# |
708 |
sub getAlgorithmType( ;$){ |
709 |
my$self=shift; |
710 |
|
711 |
return $self->getAlgorithm(shift||0)->{"algorithm-type"}; |
712 |
} |
713 |
|
714 |
############################################################ |
715 |
# |
716 |
# Making and maintaining a list of all collections available |
717 |
# |
718 |
# |
719 |
sub clearCollection( ){ |
720 |
my$self=shift; |
721 |
return $self->{collection}=[]; |
722 |
} |
723 |
############################## |
724 |
# |
725 |
# adding a query paradigm to the list of query-paradigms allowed for this collection |
726 |
# |
727 |
# |
728 |
sub addQueryParadigmToCurrentCollection( $ ){ |
729 |
my $self=shift; |
730 |
my $lNewParadigm=shift; |
731 |
|
732 |
# add this paradigm to the hash of query paradigms |
733 |
push @{$self->{collection}->[-1]->{"query-paradigm-list"}},$lNewQueryParadigm; |
734 |
} |
735 |
############################## |
736 |
# |
737 |
# adding a collection to this list |
738 |
# PARAMETER: ID of the collection |
739 |
# |
740 |
sub addCollection( $ ){ |
741 |
my$self=shift; |
742 |
|
743 |
my $lCollectionID=shift; |
744 |
|
745 |
my $lNewCollection={"collection-id" => $lCollectionID, |
746 |
"query-paradigm-list" => []}; |
747 |
|
748 |
print("\nxxx addcollection $lCollectionID:",join(",",(%{$lNewCollection})),"\n") if $vDEBUG{addCollection}; |
749 |
|
750 |
|
751 |
$self->clearCollection() unless defined $self->{collection}; |
752 |
|
753 |
push @{$self->{collection}},$lNewCollection; |
754 |
} |
755 |
############################## |
756 |
# |
757 |
# Get a hash describing the Nth collection |
758 |
# PARAMETER: N/CollectionID |
759 |
# |
760 |
sub getCollection( ;$){ |
761 |
my$self=shift; |
762 |
|
763 |
my $inCollectionID=shift; |
764 |
|
765 |
if($inCollectionID=~m/[a-zA-Z]/){ |
766 |
foreach $i (@{$self->{collection}}){ |
767 |
print "\ncollection-id: $i->{'collection-id'}\n"; |
768 |
if($i->{"collection-id"} eq $inCollectionID){ |
769 |
return $i; |
770 |
} |
771 |
} |
772 |
die "in CFeedbackClient::getCollection Could not get any collection matching $inCollectionID " |
773 |
} |
774 |
|
775 |
return $self->{collection}->[($inCollectionID || 0)]; |
776 |
} |
777 |
############################## |
778 |
# |
779 |
# Get the collection ID of the Nth collection |
780 |
# |
781 |
sub getCollectionID( ;$){ |
782 |
my$self=shift; |
783 |
|
784 |
my $inCollectionNumber=shift; |
785 |
|
786 |
if($inCollectionNumber=~m/[^0-9 \t]/){ |
787 |
return $inCollectionNumber;#in fact, the collection number was already an ID |
788 |
} |
789 |
|
790 |
return $self->getCollection(shift||0)->{"collection-id"}; |
791 |
} |
792 |
|
793 |
############################## |
794 |
# |
795 |
# Find out which algorithms fit your preferred query paradigm |
796 |
# PARAMETERS: inParadigm, a query paradigm element represented |
797 |
# by a hash from attriute to value |
798 |
sub getAlgorithmsByParadigm( $ ){ |
799 |
my$self=shift; |
800 |
|
801 |
my $inParadigm=shift; |
802 |
|
803 |
my @lResult; |
804 |
|
805 |
foreach $i (@{$self->{algorithm}}){ |
806 |
|
807 |
if($self->isMatchingQueryParadigmList($i->{"query-paradigm-list"}, |
808 |
$inParadigm)){ |
809 |
print "found ",$i->{"algorithm-id"},":",join(",",(%$i)),"\n"; |
810 |
|
811 |
push @lResult,$i; |
812 |
} |
813 |
} |
814 |
return @lResult; |
815 |
} |
816 |
############################## |
817 |
# |
818 |
# Find out which algorithms fit your preferred query paradigm and collection |
819 |
# |
820 |
sub getAlgorithmsByParadigmAndCollection( $$ ){ |
821 |
my$self=shift; |
822 |
|
823 |
my $inParadigm=shift; |
824 |
my $inCollection=shift; |
825 |
|
826 |
my @lResult; |
827 |
|
828 |
foreach $i (@{$self->{algorithm}}){ |
829 |
|
830 |
if(($self->isMatchingQueryParadigmList($inParadigm, |
831 |
$i->{"query-paradigm-list"}))){ |
832 |
print ("HIER\n"); |
833 |
if(($self->isMatchingQueryParadigmList($i->{"query-paradigm-list"}, |
834 |
$inCollection->{"query-paradigm-list"}))) |
835 |
{ |
836 |
print "found algorithm ",$i->{"algorithm-id"},":",join(",",(%$i)),"\n"; |
837 |
|
838 |
push @lResult,$i; |
839 |
} |
840 |
} |
841 |
} |
842 |
return @lResult; |
843 |
} |
844 |
sub getCollectionsByParadigm( $ ){ |
845 |
my$self=shift; |
846 |
|
847 |
my $inParadigm=shift; |
848 |
|
849 |
my @lResult; |
850 |
|
851 |
foreach $i (@{$self->{collection}}){ |
852 |
|
853 |
if($self->isMatchingQueryParadigmList($i->{"query-paradigm-list"}, |
854 |
$inParadigm)){ |
855 |
print "found ",$i->{"collection-id"},":",join(",",(%$i)),"\n"; |
856 |
|
857 |
push @lResult,$i->{"collection-id"}; |
858 |
} |
859 |
} |
860 |
return @lResult; |
861 |
} |
862 |
|
863 |
sub collectionToParadigmList( $ ){ |
864 |
my$self=shift; |
865 |
|
866 |
my $inCollection=shift; |
867 |
|
868 |
return $inCollection->{"query-paradigm-list"}; |
869 |
} |
870 |
sub collectionToID( $ ){ |
871 |
my$self=shift; |
872 |
|
873 |
my $inCollection=shift; |
874 |
|
875 |
return $inCollection->{"collection-id"}; |
876 |
} |
877 |
sub algorithmToParadigmList( $ ){ |
878 |
my$self=shift; |
879 |
|
880 |
my $inAlgorithm=shift; |
881 |
|
882 |
return $inAlgorithm->{"query-paradigm-list"}; |
883 |
} |
884 |
sub algorithmToID( $ ){ |
885 |
my$self=shift; |
886 |
|
887 |
my $inAlgorithm=shift; |
888 |
|
889 |
return $inAlgorithm->{"algorithm-id"}; |
890 |
} |
891 |
|
892 |
|
893 |
############################## |
894 |
# |
895 |
# Setting the desired maximum |
896 |
# size of the result of the next query |
897 |
# |
898 |
# |
899 |
sub getResultSize( ){ |
900 |
my$self=shift; |
901 |
|
902 |
return $self->{gResultSize}; |
903 |
} |
904 |
sub setResultSize( $ ){ |
905 |
my$self=shift; |
906 |
|
907 |
$self->{gResultSize}=shift; |
908 |
} |
909 |
############################## |
910 |
# |
911 |
# Setting the "cutoff": minimal desired calculated relevance |
912 |
# of the retrieved result |
913 |
# |
914 |
sub getCutoff( ){ |
915 |
my$self=shift; |
916 |
|
917 |
return $self->{gCutoff}; |
918 |
} |
919 |
sub setCutoff( $ ){ |
920 |
my$self=shift; |
921 |
|
922 |
$self->{gCutoff}=shift; |
923 |
} |
924 |
|
925 |
|
926 |
|
927 |
############################## |
928 |
# |
929 |
# Build a new query using makeQueryString |
930 |
# out of a list of retrieved images. |
931 |
# |
932 |
# |
933 |
# In fact this is the main function which users of this class |
934 |
# will need to overload |
935 |
# |
936 |
sub buildNewQuery( $$ ){ |
937 |
my$self=shift; |
938 |
|
939 |
#a reference to an ARRAY containing the retrieved images |
940 |
my $inRetrieved=shift; |
941 |
|
942 |
if($self->{vDEBUG}->{buildNewQuery}){ |
943 |
print "--------------------buildNewQuery"; |
944 |
my $i; |
945 |
foreach $i (@$inRetrieved){ |
946 |
print "buildNewQuery: $$i[0]\n"; |
947 |
}; |
948 |
} |
949 |
|
950 |
#a reference to a HASH containing the relevant images as keys |
951 |
my $inRelevantHash=shift; |
952 |
|
953 |
# this array has to be filled up using the feedback algorithm |
954 |
my @outQueryImages=(); |
955 |
|
956 |
################################################## |
957 |
# |
958 |
# This is the real feedback algorithm |
959 |
# Heirs put changements here! |
960 |
# |
961 |
|
962 |
# in this case: |
963 |
{#these braces are there for scoping reasons |
964 |
my $i; |
965 |
foreach $i (@$inRetrieved){#for each retrieved image,... |
966 |
if($$inRelevantHash{$$i[0]}){#...which is in the hash of relevant images... |
967 |
push @outQueryImages,[$$i[0],1];#...add it to the query. |
968 |
#... and give some output , if requested |
969 |
print "adding query image $$i[0]\n" if $self->{vDEBUG}->{buildNewQuery}; |
970 |
} |
971 |
} |
972 |
}#these braces are there for scoping reasons |
973 |
|
974 |
# |
975 |
# this was the feedback algorithm |
976 |
# |
977 |
################################################## |
978 |
# die qq(Error in feedback generating algorithm: $@) if $@; |
979 |
$locQuery=$self->makeQueryString(\@outQueryImages, |
980 |
$self->getSessionID(0), |
981 |
$self->getAlgorithmID(0), |
982 |
$self->getCollectionID(0), |
983 |
); |
984 |
} |
985 |
|
986 |
|
987 |
|
988 |
|
989 |
|
990 |
############################################################# |
991 |
# |
992 |
# |
993 |
# NETWORKING |
994 |
# |
995 |
# |
996 |
sub old_opensock( ;$$ ){ |
997 |
my$self=shift; |
998 |
#snipped from the perlbook |
999 |
|
1000 |
my($remote,$port,$iaddr,$paddr,$proto,$line,$newport); |
1001 |
|
1002 |
$remote = shift || 'localhost'; |
1003 |
$port = shift || 12789; |
1004 |
$newport=$port; |
1005 |
|
1006 |
if($port=~/\D/){$newport=getservbyname($newport,'tcp');} |
1007 |
die "No port" unless $newport; |
1008 |
$iaddr = main::inet_aton($remote) or die "no host: $remote"; |
1009 |
$paddr = main::sockaddr_in($newport,$iaddr); |
1010 |
|
1011 |
$proto = getprotobyname('tcp'); |
1012 |
|
1013 |
socket(SOCK,main::PF_INET,main::SOCK_STREAM,$proto) or die "socket: $!"; |
1014 |
connect(SOCK,$paddr) or die "connect: $!"; |
1015 |
|
1016 |
autoflush SOCK 1; |
1017 |
autoflush STDOUT 1; |
1018 |
|
1019 |
} |
1020 |
|
1021 |
|
1022 |
############################################################# |
1023 |
# |
1024 |
# |
1025 |
# NETWORKING open a socket |
1026 |
# PARAMETERS: remote host, port. |
1027 |
# |
1028 |
# by default the values of $self->{mHost} and $self->{mPort}; |
1029 |
# are taken. |
1030 |
sub opensock( ;$$ ){ |
1031 |
my$self=shift; |
1032 |
#snipped from man IO::Socket |
1033 |
|
1034 |
my($remote,$port,$iaddr,$paddr,$proto,$line,$newport); |
1035 |
|
1036 |
$remote = shift || $self->{mHost}; |
1037 |
$port = shift || $self->{mPort}; |
1038 |
|
1039 |
autoflush STDOUT 1; |
1040 |
|
1041 |
print "connecting to: $remote:$port\n" if $vDEBUG{opensock}; |
1042 |
|
1043 |
$self->{mSocket} = IO::Socket::INET->new(PeerAddr => $remote, |
1044 |
PeerPort => $port, |
1045 |
Proto => 'tcp'); |
1046 |
|
1047 |
print "finished making the socket" if $vDEBUG{opensock}; |
1048 |
|
1049 |
$self->{mSocket}->autoflush(1); |
1050 |
} |
1051 |
|
1052 |
|
1053 |
|
1054 |
############################### |
1055 |
# |
1056 |
# read from the socket and parse. |
1057 |
# returns the string read. |
1058 |
# |
1059 |
sub readAndParse( ){ |
1060 |
my$self=shift; |
1061 |
|
1062 |
print "\nNow I will try to read...\n" if($self->{vDEBUG}->{readAndParse}); |
1063 |
|
1064 |
#parsing directly from the stream |
1065 |
# $self->{parser}->parse($self->{mSocket}); |
1066 |
# "\nthis value should not be used!\n"; |
1067 |
|
1068 |
#we read, and then we parse |
1069 |
#for this reason, we can return the |
1070 |
#string read |
1071 |
{ |
1072 |
my $lRead=join("",$self->{mSocket}->getlines()); |
1073 |
|
1074 |
if($lRead){ |
1075 |
|
1076 |
if($self->{vDEBUG}->{readAndParse}){ |
1077 |
print "Parsing: $lRead"; |
1078 |
$lOF= new IO::File; |
1079 |
$lOF->open(">mrml-parsing-log"); |
1080 |
print $lOF $lRead; |
1081 |
print "--\n"; |
1082 |
} |
1083 |
# |
1084 |
$self->clearXMLPath(); |
1085 |
$self->{parser}->parse($lRead); |
1086 |
} |
1087 |
$lRead; |
1088 |
} |
1089 |
} |
1090 |
|
1091 |
|
1092 |
############################### |
1093 |
# |
1094 |
# sends an ihandshake message |
1095 |
# to the server. |
1096 |
# |
1097 |
sub startSession(){ |
1098 |
my$self=shift; |
1099 |
|
1100 |
my $lUser=shift || "default-user"; |
1101 |
my $lSession=shift || "--feedback-client-session--"; |
1102 |
|
1103 |
$self->opensock(); |
1104 |
|
1105 |
$_= qq(<?xml version="1.0" standalone="no" ?> |
1106 |
<!DOCTYPE mrml SYSTEM "file:__DATADIR__/mrml.dtd"> |
1107 |
<mrml session-id="nothing"> |
1108 |
<open-session user-id="$lUser" session-name="--feedback-client-session--"/> |
1109 |
<get-algorithms /> |
1110 |
<get-collections /> |
1111 |
</mrml> |
1112 |
); |
1113 |
|
1114 |
$self->{mSocket}->print($_); |
1115 |
print "Sent: $_" if($vDEBUG{startSession}); |
1116 |
$self->readAndParse(); |
1117 |
} |
1118 |
############################### |
1119 |
# |
1120 |
# Save the state of the session on the server |
1121 |
# |
1122 |
# FIXME: presently this is empty |
1123 |
# |
1124 |
sub saveSession(){ |
1125 |
my$self=shift; |
1126 |
} |
1127 |
############################### |
1128 |
# |
1129 |
# close the session |
1130 |
# |
1131 |
# FIXME: presently this is empty |
1132 |
# |
1133 |
sub closeSession(){ |
1134 |
my$self=shift; |
1135 |
} |
1136 |
############################### |
1137 |
# |
1138 |
# FOR TESTING ONLY: TRYING TO SIMULATE A SESSION |
1139 |
# |
1140 |
# configures an algorithm |
1141 |
# to the server. |
1142 |
# HM 060201 added parametres that are needed for the benchmark |
1143 |
# |
1144 |
sub configureSession(;$$$$$$$$$ ){ |
1145 |
my$self=shift; |
1146 |
|
1147 |
my $inSessionID=shift || $self->getSessionID(); |
1148 |
my $inAlgorithmID=shift || $self->getAlgorithmID(); |
1149 |
my $inCollectionID=shift || $self->getCollectionID(); |
1150 |
my $inAdditionalAlgorithmAttributes=shift || ""; |
1151 |
my $inColorHistogramBlocked=shift || "false"; |
1152 |
my $inColorBlocksBlocked=shift || "false"; |
1153 |
my $inGaborHistogramBlocked=shift || "false"; |
1154 |
my $inGaborBlocksBlocked=shift || "false"; |
1155 |
my $inFeaturePercentage=shift || "100"; |
1156 |
|
1157 |
|
1158 |
my $MESSAGEFILE="__DATADIR__/gift-iconfigure.mrml"; |
1159 |
|
1160 |
$self->opensock(); |
1161 |
|
1162 |
############################### |
1163 |
# |
1164 |
# We read a prefabricated configuration message, in which we |
1165 |
# replace the appropriate attribute values |
1166 |
# |
1167 |
# open MESSAGEFILE,$MESSAGEFILE or die "There is no $MESSAGEFILE: $!"; |
1168 |
# while(<MESSAGEFILE>){ |
1169 |
# s/PPsessionidPP/$inSessionID/; |
1170 |
# s/PPalgorithmidPP/$inAlgorithmID/; |
1171 |
# s/PPcollectionidPP/$inCollectionID/; |
1172 |
# s/PPadditionalalgorithmattributesPP/$inAdditionalAlgorithmAttributes/; |
1173 |
# $self->{mSocket}->print($_); |
1174 |
# print "Sent: $_" if $self->{vDEBUG}->{configureSession}; |
1175 |
# } |
1176 |
$_= qq(<?xml version="1.0" standalone="no" ?> |
1177 |
<!DOCTYPE mrml SYSTEM "http://isrpc85.epfl.ch/Charmer/code/mrml.dtd"> |
1178 |
<mrml session-id="$inSessionID"> |
1179 |
<configure-session session-id="$inSessionID" > |
1180 |
<algorithm |
1181 |
algorithm-id="$inAlgorithmID" |
1182 |
algorithm-type="adefault" |
1183 |
collection-id="$inCollectionID" |
1184 |
cui-block-color-histogram="$inColorHistogramBlocked" |
1185 |
cui-block-color-blocks="$inColorBlocksBlocked" |
1186 |
cui-block-texture-histogram="$inGaborHistogramBlocked" |
1187 |
cui-block-texture-blocks="$inGaborBlocksBlocked" |
1188 |
cui-pr-percentage-of-features="$inFeaturePercentage" > |
1189 |
</algorithm> |
1190 |
</configure-session> |
1191 |
<query-step session-id="$inSessionID" result-size="30" algorithm-id="$inAlgorithmID" collection="$inCollectionID"/> |
1192 |
</mrml>); |
1193 |
|
1194 |
$self->{mSocket}->print($_); |
1195 |
print "Sent: $_" if($vDEBUG{startSession}); |
1196 |
|
1197 |
|
1198 |
$self->readAndParse(); |
1199 |
} |
1200 |
|
1201 |
############################## |
1202 |
# |
1203 |
# Send a query to the server |
1204 |
# |
1205 |
sub sendQueryString( $ ){ |
1206 |
my$self=shift; |
1207 |
my $lQuery=shift; |
1208 |
$self->opensock(); |
1209 |
|
1210 |
if($self->{vDEBUG}->{sendQueryString}){ |
1211 |
print "sendQueryString++++++++++++++++++++++++++++++Sending query....\n\n"; |
1212 |
print $lQuery; |
1213 |
print "\nsendQueryString------------------------------Sending query....\n\n"; |
1214 |
} |
1215 |
|
1216 |
$self->{mSocket}->print($lQuery); |
1217 |
|
1218 |
$self->readAndParse(); |
1219 |
|
1220 |
$self->{mSocket}->close(); |
1221 |
} |
1222 |
|
1223 |
############################## |
1224 |
# |
1225 |
# generate a query and feed it to the server. |
1226 |
# subsequent queries will be generated by the xml parser |
1227 |
# and its helpers. |
1228 |
sub doFirstQueryStep( $;$$$ ){ |
1229 |
my$self=shift; |
1230 |
|
1231 |
my $lInstruction=shift; |
1232 |
my $lQuery=shift || [[$self->getRelevantImages()->[0],1]]; |
1233 |
|
1234 |
my $inSession=(shift || ($self->getSessionID(0))); |
1235 |
my $inAlgorithm=(shift || ($self->getAlgorithmID(0))); |
1236 |
my $inCollection=(shift || ($self->getCollectionID(0))); |
1237 |
|
1238 |
my $lQueryString; |
1239 |
|
1240 |
if($lInstruction eq "query-step"){ |
1241 |
$lQueryString=$self->makeQueryString($lQuery, |
1242 |
$inSession, |
1243 |
$inAlgorithm, |
1244 |
$inCollection); |
1245 |
} |
1246 |
if($lInstruction eq "cui-hierarchy-up"){ |
1247 |
my $inResultSize=$self->getResultSize(); |
1248 |
my $inCutoff=$self->getCutoff(); |
1249 |
$lQueryString=qq(<?xml version="1.0" standalone="no" ?> |
1250 |
<!DOCTYPE mrml SYSTEM "~/public_html/dtd/mrml.dtd"> |
1251 |
<mrml session-id=\"$inSession\"> |
1252 |
<query-step |
1253 |
result-size="$inResultSize" |
1254 |
result-cutoff="$inCutoff" |
1255 |
collection-id="$inCollection" |
1256 |
algorithm-id="$inAlgorithm"> |
1257 |
<cui-hierarchy-up/> |
1258 |
</query-step> |
1259 |
</mrml>); |
1260 |
|
1261 |
} |
1262 |
if($self->{vDEBUG}->{doFirstQueryStep}){ |
1263 |
print "doFirstQueryStep++++++++++++++++++++++++++++++Sending query....\n\n"; |
1264 |
} |
1265 |
$self->sendQueryString($lQueryString); |
1266 |
{ |
1267 |
print "\ndoFirstQueryStep------------------------------Sending query....\n\n"; |
1268 |
} |
1269 |
return $lQueryString; |
1270 |
} |
1271 |
|
1272 |
############################### |
1273 |
# |
1274 |
# send a feedback query, if the same query was not performed |
1275 |
# in the last step. |
1276 |
# |
1277 |
sub doQueryStep( $$ ){ |
1278 |
my$self=shift; |
1279 |
|
1280 |
my $inCount=shift; |
1281 |
my $lOld=shift; |
1282 |
my $lNow=$locQuery; |
1283 |
|
1284 |
if ($lOld ne $lNow){ |
1285 |
if($self->{vDEBUG}->{doQueryStep}){ |
1286 |
print "$inCount ++++++++++++++++++++++++++++++Sending query....\n\n"; |
1287 |
print $locQuery; |
1288 |
print "\n$inCount ------------------------------Sending query....\n\n"; |
1289 |
} |
1290 |
$self->opensock(); |
1291 |
$self->{mSocket}->print($locQuery); |
1292 |
$self->readAndParse(); |
1293 |
return $lNow; |
1294 |
}else{ |
1295 |
if($self->{vDEBUG}->{doQueryStep}){ |
1296 |
print "$inCount ++NOT SENDING QUERY\n"; |
1297 |
print $locQuery; |
1298 |
print "\n$inCount --NOT SENDING QUERY\n"; |
1299 |
} |
1300 |
} |
1301 |
return ""; |
1302 |
} |
1303 |
|
1304 |
|
1305 |
############################################################ |
1306 |
# |
1307 |
# perform a group of queries. This can be a browsing |
1308 |
# query process or a simple sequence of next neigbour |
1309 |
# query feedback steps. What it really is depends on the |
1310 |
# heir which overloads doQueryStep |
1311 |
# |
1312 |
# PARAMETERS: |
1313 |
# $inImages reference to a list containing the relevant images |
1314 |
# |
1315 |
sub doQueryGroup( $ ){ |
1316 |
my$self=shift; |
1317 |
|
1318 |
my $inImages=shift; |
1319 |
$self->setRelevantImages(@$inImages); |
1320 |
|
1321 |
|
1322 |
$self->startSession("default-user"); |
1323 |
$self->configureSession(); |
1324 |
{ |
1325 |
my $lOldQuery=$self->doFirstQueryStep("query-step"); |
1326 |
my $lCount=1; |
1327 |
while(($lOldQuery=$self->doQueryStep($lCount, |
1328 |
$lOldQuery)) |
1329 |
&& |
1330 |
($lCount<100)){ |
1331 |
++$lCount; |
1332 |
}; |
1333 |
} |
1334 |
} |
1335 |
|
1336 |
|
1337 |
|