1 (use-modules 
   2  (oop goops)
   3  (oop goops describe))
   4 
   5 ;;;;;;;;;Class definitions;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6    
   7 ;; IDL
   8 ;; Matchrule
   9 
  10 (define-class <MatchRule> ()
  11   (states #:getter get-states #:init-keyword #:s)
  12   (state-match-type #:getter get-state-match-type #:init-keyword #:smt)
  13   (attributes #:getter get-attributes #:init-keyword #:a)
  14   (attribute-match-type #:getter get-attribute-match-type #:init-keyword #:amt)
  15   (roles #:getter get-roles #:init-keyword #:r)
  16   (role-match-type #:getter get-role-match-type #:init-keyword #:rmt)
  17   (interfaces #:getter get-interfaces #:init-keyword #:i)
  18   (interface-match-type #:getter get-interface-match-type #:init-keyword #:imt)
  19   (invert #:getter get-invert #:init-keyword #:iv))
  20 
  21 ;; IDL
  22 ;; Accessible
  23 (define-class <Accessible> ()
  24   (name #:init-value "NONE" #:getter get-name #:setter set-name!)
  25   (state #:init-value '("STATE_ACTIVE") #:getter get-state #:setter set-state!)
  26   (role #:init-value "ROLE_NONE" #:getter get-role #:setter set-role!)
  27   (attributes #:init-value '() #:getter get-attributes #:setter set-attributes!)
  28   (interface #:init-value "" #:getter get-interface #:setter set-interface!)
  29   (children #:init-value '() #:getter get-children #:init-keyword #:children) ;; extra
  30   (childCount #:init-value 0 #:getter get-childCount #:setter set-childCount!))
  31 
  32 
  33 ;; IDL
  34 (define-method (get-child-at-index (obj <Accessible>) i)
  35   (list-ref (get-children obj) i))
  36   
  37 
  38 ;; app-new, button-new, text-new create "Accessibles"
  39 ;; to simulate what we would have coming from the AT
  40 
  41 
  42 (define-method (app-new name state attribute interface ls )
  43   (let ((app (make <Accessible> #:children ls)))
  44     (set-name! app name)
  45     (set-role! app "ROLE_APPLICATION")
  46     app))
  47  
  48 (define-method (button-new name state attribute interface)
  49   (let ((button (make <Accessible>)))
  50     (set-state! button state)
  51     (set-attributes! button (string-split attribute #\;))
  52     (set-name! button name)
  53     (set-role! button "ROLE_PUSH_BUTTON")
  54     button))
  55 
  56 (define-method (text-new name state attribute interface)
  57   (let ((button (make <Accessible>)))
  58     (set-state! button state)
  59     (set-attributes! button (string-split attribute #\;))
  60     (set-name! button name)
  61     (set-role! button "ROLE_TEXT")
  62     button))
  63 
  64 
  65 ;;;;;;;;;;;;;;;;;;;;;;;; Collection  ;;;;;;;;;;;;;;;;;;;;;;;;;
  66 
  67 ;; object-match-X? functions...
  68 ;; Check whether obj matches any of the conditions included in 
  69 ;; args. We compare each element from args to whatever we get from 
  70 ;; applying func to obj. In this case the same function works
  71 ;; for state, role, attribute and interface. All three methods
  72 ;; are the same except for the way the recurse through args
  73 
  74 ;;(object-match-any? button get-role MATCH_ANY '(ROLE_BUTTON))
  75 ;;; Return matching object or #f
  76 
  77 ;; (object-match-any? (car buttons) get-role '("ROLE_PUSH_BUTTON"))
  78 ;; (object-match-any? (car buttons) get-state '("STATE_ENABLED" "STATE_ANY"))
  79 ;; (object-match-any? (car buttons) get-role '("ROLE_PUSH_BUTTON"))
  80 ;; (object-match-any? (car buttons) get-state '("STATE_ENABLED" "STATE_ANY"))
  81 
  82 
  83 (define-method (object-match-any? (obj <Accessible>) func args)
  84   (cond 
  85    ((null? args)   #f)
  86    ((equal? (car args) (func obj)) obj)
  87    ((and (list? (func obj))(member (car args) (func obj))) obj)
  88    (else (object-match-any? obj func (cdr args)))))
  89 
  90 ;;;(object-match-all? button get-role '(ROLE_BUTTON))
  91 ;;; Return matching object or #f
  92 
  93 ;; (object-match-all? (car buttons) get-role '("ROLE_PUSH_BUTTON"))
  94 ;; (object-match-all? (car buttons) get-state '("STATE_ACTIVE" "STATE_NULL"))
  95 
  96 (define-method (object-match-all? (obj <Accessible>) func args)
  97   (define (helper args) 
  98     (cond
  99      ((null? args) obj)
 100      ((equal? (car args) (func obj)) (helper (cdr args)))
 101      ((and (list? (func obj))(member (car args)(func obj))) (helper (cdr args)))
 102      (else #f)))
 103   (helper args))
 104 
 105 ;;(object-match-none? button get-role '(ROLE_BUTTON))
 106 ;; Return matching object or #f 
 107 
 108 ; (object-match-none? (car buttons) get-role '("ROLE_PUSH_BUTTON"))
 109 ; (object-match-none? (car buttons) get-role '("ROLE_FOO_BUTTON"))
 110 ; (object-match-none? (car buttons) get-state '("STATE_FOO" "STATE_ACTIVE"))
 111 ; (object-match-none? (car buttons) get-state '("STATE_FOO" "STATE_BLA"))
 112 
 113 (define-method (object-match-none? (obj <Accessible>) func args)
 114   
 115   (define (helper args)
 116     (cond 
 117      ((null? args) obj)
 118      ((equal? (car args) (func obj)) #f)
 119      ((and (list? (func obj)) (member (car args) (func obj))) #f)
 120      (else (helper (cdr args)))))
 121   (helper args))
 122 
 123 
 124 ;;(object-match? button get-role MATCH_ANY '(ROLE_BUTTON))
 125 
 126 ;; Convenience function to call instead of above three.
 127 ; (object-match? (car buttons) get-role 'MATCH_ALL '("ROLE_PUSH_BUTTON"))
 128 ; (object-match? (car buttons) get-state 'MATCH_ALL '("STATE_ACTIVE"))
 129 
 130 (define-method (object-match? (obj <Accessible>) func matchtype args)
 131   (cond
 132    ((and (equal? 'MATCH_ANY matchtype) (null? args)) obj)
 133    ((equal? 'MATCH_ALL matchtype)  (object-match-all? obj func args))
 134    ((equal? 'MATCH_ANY matchtype)  (object-match-any? obj func args))
 135    ((equal? 'MATCH_NONE matchtype) (object-match-none? obj func args))
 136    (else #f)))
 137 
 138 
 139 ;; IDL
 140 ;; (create-match-rule mr s smt a amt r rmt i imt iv)
 141 ;; Return a new allocated list
 142 
 143 (define-method (create-match-rule s smt a amt r rmt i imt iv)
 144   (make <MatchRule> #:s s #:smt smt #:a a #:amt amt #:r r #:rmt rmt #:i i #:imt imt #:iv iv))
 145 
 146 ;; IDL
 147 ;; (free-match-rule mr)
 148 ;; Free Matchrule resources (dummy)
 149 
 150 (define-method (free-match-rule (mr <MatchRule>)) ((lambda ())))
 151  
 152 
 153 (define (strip ls obj) (delete obj ls))
 154 
 155 
 156 ;; IDL
 157 ;; (get-children obj matchrule sortby recurse count)
 158 
 159 ;; First we get all the children.  In the C implementation we need to first to
 160 ;; get childCount and call getChild for each of the children.
 161 ;; Here, things are simplified for example purposes. But the general idea should
 162 ;; be the same, i.e. first check for state, then for attribute and so on. 
 163 ;; In all cases we use object-match? and everything is nice. At the end we return 
 164 ;; a pair with the count and the matched objects.
 165 
 166 (define-method (get-children (obj <Accessible>)  (mr <MatchRule>) sortby recurse count)
 167   (let*  ((children (get-children obj))
 168 	  (state-children (strip (map (lambda (c)(object-match? c get-state  (get-state-match-type mr) (get-states mr))) children) #f))
 169 	  (attribute-children (strip (map (lambda (c) (object-match? c get-attributes (get-attribute-match-type mr) 
 170 								     (if (list? (get-attributes mr))
 171 									 '()
 172 									 (string-split (get-attributes mr) #\;)))) state-children) #f))
 173 	  (role-children (strip (map (lambda (c) (object-match? c get-role (get-role-match-type mr) (get-roles mr))) attribute-children) #f))
 174 	  (interface-children (strip (map (lambda (c) (object-match? c get-interface (get-interface-match-type mr) (get-interfaces mr))) role-children) #f))
 175 	  (count (length interface-children)))
 176     (cons count interface-children)))
 177 
 178 
 179 ;; (print-children ch)
 180 ;; print the result of get-Children. Prints Accessible name 
 181 (define (print-children ch)
 182   (display (car ch))
 183   (newline)
 184   (for-each (lambda (x)(display (get-name x)))(cdr ch))
 185   (newline))