hop


Après avoir dévoré articles et ouvrages sur Hop, je tentais d'écrire moi aussi quelques lignes de codes. Ce fut d'abord un généateur de tirage de loto. Puis, twithop, un twitter instantané parlant. Et oui, en Hop tout semble possible. Il fonctionne avec Hop 2.0.1 sur le serveur et Firefox comme navigateur. Voici les codes source complets :


Lothop


; Langage Hop 2.0.1

(define liste-tirages '())

(define-service (lothop)
  (<HTML>
        (<HEAD> :alt=" title "Lothop")
   (let ((table-tirages (make-loto-table liste-tirages)))
     (<BODY> 
      ~(add-event-listener! "loto" "server"
                            (lambda (e)
                              (with-hop ($refresh-loto-table)
                                        (lambda (h)
                                          (innerHTML-set! $table-tirages h))))
                            #t)
      (<BUTTON> :onclick ~(with-hop ($nouvelle-loto-table)
                                    (lambda (h)
                                      (innerHTML-set! $table-tirages h)))
                "Tirage")
      (<BUTTON> :onclick ~(with-hop ($reset-loto-table)
                                    (lambda (h)
                                      (innerHTML-set! $table-tirages h)))
                "Effacer")
      table-tirages
      (<FOOT> "Lothop version 0.0.1 par jeeve corporation")))))

(define (make-loto-table tirages)
  (<TABLE> :border 1
           tirages))

(define-service (refresh-loto-table)
  (make-loto-table liste-tirages))

(define-service (nouvelle-loto-table)
  (let ((tirages (cons (<TIRAGE>)         
                       liste-tirages)))
    (begin
      (set! liste-tirages tirages)
      (hop-event-broadcast! "loto" "tirage")
      (make-loto-table tirages))))

(define-service (reset-loto-table)
  (begin
    (set! liste-tirages '())
    (hop-event-broadcast! "loto" "tirage")
    (make-loto-table liste-tirages)))

(define (<TIRAGE>)
  (<TR>
   (let ((jeu-initial (iota 49 1)))
     (cons
      (<TD> (current-date))
      (map (lambda (n) (<TD> n))
           (tire-boules 5 jeu-initial))))))

(define (tire-boules n jeu)
  (if (= n 1)
      (list (list-ref jeu (random (- (length jeu) 1))))
      (let* ((indice (random (- (length jeu) 1)))
             (boule (list-ref jeu indice)))
        (append (tire-boules (- n 1) (remq boule jeu))
                (list (list-ref jeu indice))))))


Bonne chance....


Twithop


; Twithop 0.0.3 par jeeve
; Langage Hop 2.0.1

(define liste-messages '())

(define-service (twithop)
  (let ((audio (<AUDIO> :controls #f :browser 'flash ))
        (champ-pseudo (<INPUT> :name "pseudo"))
        (champ-langue (<SELECT> :name "langue"
                                (<OPTION> :value "fr" "français")
                                (<OPTION> :value "en" "anglais")))
        (champ-phrase (<INPUT> :name "phrase"))
        (table-phrases (make-table liste-messages)))
    (<HTML>
     (<HEAD> :include "hop-audio" :alt=" title "Twithop")
     (<BODY>  
      (<FORM> :action ~(with-hop ($nouveau-message (pseudo $champ-pseudo.value $champ-langue.value)
                                                   $champ-langue.value
                                                   (allocution $champ-phrase.value $champ-langue.value))
                                 (lambda (h)
                                   (begin
                                     (innerHTML-set! $table-phrases h)
                                     (set! $champ-phrase.value ""))))
              (<H2> "Twithop")
              audio  
             
              ~(define (pseudo nom langue)
                 (if (equal? nom "")
                     (if (equal? langue "fr")
                         "un anonyme"
                         "anonymous")
                     nom))       
             
              ~(define (allocution phrase langue)
                 (if (equal? phrase "")
                     (if (equal? langue "fr")
                         "rien"
                         "nothing")
                     phrase))
             
              ~(define (convert-to-mots h)
                 (pregexp-replace* " " h "+"))
             
              ~(define (event-langue event)
                 (list-ref event 0))
             
              ~(define (event-phrase event)
                 (list-ref event 1))
             
              ~(define (sing audio langue phrase)
                 (let ((url (string-append "http://translate.google.com/translate_tts?tl=" langue "&q="
                                           (convert-to-mots phrase))))
                   (audio-load audio url #t))) 
             
              ~(add-event-listener! "parle" "server"
                                    (lambda (e)
                                      (with-hop ($refresh-table)
                                                (lambda (h)
                                                  (begin
                                                    (innerHTML-set! $table-phrases h)
                                                    (if (equal? (event-value e) "")
                                                        '()
                                                        (sing $audio
                                                              (event-langue (event-value e))
                                                              (allocution (event-phrase (event-value e))
                                                                          (event-langue (event-value e)))))))))
                                    #f)  
              (<TABLE>
               (<TR> (<TD> (<B> "Votre pseudo ")) (<TD> champ-pseudo) (<TD> champ-langue))
               (<TR> (<TD> (<B> "Votre phrase ")) (<TD> champ-phrase)
                     (<TD>
                      (<INPUT> :type 'submit :value "Dire")))))            
      (<BUTTON> :onclick ~(with-hop ($reset-table)
                                    (lambda (h)
                                      (innerHTML-set! $table-phrases h)))
                "Effacer tout")
      (<BUTTON> :onclick ~(with-hop ($efface-dernier-message)
                                    (lambda (h)
                                      (innerHTML-set! $table-phrases h)))
                "Effacer dernier")
      (<BR>)
      table-phrases
      (<FOOT> "Twithop version 0.0.3 par jeeve corporation")))))

(define (make-table messages)
  (let* ((ligne (lambda (message)
                  (map (lambda (h) (<TD> h))
                       (list (message-pseudo message) (string-append " " (dit (message-langue message)) " : ")
                             (message-phrase message)))))
         (rtd (lambda (t)
                (map ligne
                     t))))        
    (<TABLE> :border 0
             (map (lambda (h)
                    (<TR> h))
                  (rtd messages)))))

(define-service (refresh-table)
  (make-table liste-messages))

(define (dit langue)
  (if (equal? langue "fr")
      "dit"
      "says"))

(define-service (nouveau-message pseudo langue phrase)
  (begin
    (set! liste-messages (cons (list (current-date) pseudo langue phrase)        
                               liste-messages))
    (hop-event-broadcast! "parle" (list langue (string-append pseudo (dit langue) phrase)))
    (make-table liste-messages)))

(define-service (reset-table)
  (begin
    (set! liste-messages '())
    (hop-event-broadcast! "parle" "")
    (make-table liste-messages)))

(define-service (efface-dernier-message)
  (if (null? liste-messages)
      '()
      (begin
        (set! liste-messages (cdr liste-messages))
        (hop-event-broadcast! "parle" "")
        (make-table liste-messages))))

(define (message-date message)
  (list-ref message 0))

(define (message-pseudo message)
  (list-ref message 1))

(define (message-langue message)
  (list-ref message 2))

(define (message-phrase message)
  (list-ref message 3))


Je vous invite à l'essayer. En plus, ça permet de faire parler un ordinateur à distance, et donc potientiellement de faire quelques blagues à ses amis. L'auteur décline toute responsabilité quant aux usages abusifs du programme.