/[gift]/gift/scripts/perl/CFeedbackClient.pre-pm
ViewVC logotype

Contents of /gift/scripts/perl/CFeedbackClient.pre-pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations) (download)
Tue Feb 26 13:20:19 2002 UTC (22 years, 2 months ago) by muellerw
Branch: MAIN
CVS Tags: gift_0_1_11, gift-0-1-9+3epsilon, version-0-1-9, alpha_0_1_15a, HEAD
Changes since 1.3: +1 -1 lines
for all files the copyright date was adjusted

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

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26