diff options
| -rw-r--r-- | Hermes/GUI.rkt | 40 | ||||
| -rw-r--r-- | Hermes/client.rkt | 13 |
2 files changed, 49 insertions, 4 deletions
diff --git a/Hermes/GUI.rkt b/Hermes/GUI.rkt index 41dbd29..e8f3ec1 100644 --- a/Hermes/GUI.rkt +++ b/Hermes/GUI.rkt @@ -17,7 +17,9 @@ ; store input into a message list ; will create closure later +(define messages-s (make-semaphore 1)) (define messages '()) +(define sleep-t 0.1) ; (define-values (gui-in gui-out) (make-pipe #f)) (define (make-gui) @@ -79,7 +81,9 @@ (if (< 0 (string-length (send input get-value))) (begin ; (send-message (send input get-value) my-color);; + (semaphore-wait messages-s) (set! messages (append messages (list (send input get-value)))) + (semaphore-post messages-s) ; (open-input-string ) ) '())) @@ -88,6 +92,7 @@ ; retrieves a message user inputed to the text field (define (get-message) + (semaphore-wait messages-s) (define one-message (if (not (null? messages)) (begin @@ -96,9 +101,16 @@ ;(set! messages (cdr messages)) ) '())) + (semaphore-post messages-s) + (if (not (string? one-message)) - (get-message) - (begin (set! messages (cdr messages)) + (begin + (sleep sleep-t) ; so we don't burn cpu cycles + (get-message)) + (begin + (semaphore-wait messages-s) + (set! messages (cdr messages)) + (semaphore-post messages-s) one-message))) ; creates the send button (define send-button (new button% @@ -190,8 +202,29 @@ (define min-v-size 30) (define listy (list (list "Server" "Connected" "Red" 0))) ; initializes ; listy with first message to be drawn on screen + ; wrap in closure (define my-color "black") ; default color of the text messages if none ; specified + ; associated methods to prompt for color, get color and set color + (define (set-color new-color) + (set! my-color new-color)) + + (define (get-my-color) + my-color) + + ; TODO loop to make sure you get right user input + ; not really needed as user can set in window + (define (prompt-color) + (define returned (get-text-from-user "Color set-up" "Please enter color for text" + main-frame "black" (list 'disallow-invalid) + #:validate + (lambda (input) + (if (and (string? input) (<= (string-length input) 10) + (>= (string-length input) 3)) + #t + #f)))) + (set! my-color returned) + returned) (define height 15) ; height between messages drawn on the screen ;; prompt user for username @@ -215,6 +248,9 @@ ; show gui should return the users the name as well as its first message ; to be called (cond ((eq? command 'show) (lambda () (send main-frame show #t))) + ((eq? command 'get-color) get-my-color) + ((eq? command 'set-color) set-color) + ((eq? command 'prompt-color) prompt-color) ((eq? command 'get-username) get-username) ((eq? command 'send) send-message) ;; call to show a message in a gui ((eq? command 'set-name) (lambda (newname) (if (string? newname) diff --git a/Hermes/client.rkt b/Hermes/client.rkt index 6752c1e..e955027 100644 --- a/Hermes/client.rkt +++ b/Hermes/client.rkt @@ -19,6 +19,8 @@ (define port-num 4321) (define sleep-t 0.1) +(define hermes-gui-s (make-semaphore 1)) + ; we won't need this. Just me being overzealous (define hermes-conf (open-output-file "./hermes_client.conf" #:exists 'append)) (define hermes-conf-s (make-semaphore 1)) @@ -95,7 +97,9 @@ ;; read, quits when user types in "quit" ;; TODO read from GUI instead ;(define input (read-line)) + (semaphore-wait hermes-gui-s) (define input ((hermes-gui 'get-message))) + (semaphore-post hermes-gui-s) ; TODO prompt for color as well ; TODO /quit instead of quit @@ -110,7 +114,8 @@ (displayln (string-append date-print username ": " input) out) (flush-output out)) -; sigh why you do this racket +; a wrap around to call ((hermes-gui 'send) zzz yyy) without complaints from +; drracket (define send-to-gui (lambda (message color) ((hermes-gui 'send) message color))) @@ -127,7 +132,11 @@ ] [(string? evt) (displayln-safe evt convs-out-s convs-out) - (send-to-gui evt "black") + ; TODO set color to current client if the message is from him + ; otherwise set it to the remote + (semaphore-wait hermes-gui-s) + (send-to-gui evt ((hermes-gui 'get-color))) + (semaphore-post hermes-gui-s) ] ; could time stamp here or to send message [else (displayln-safe (string-append "Nothing received from server for 2 minutes.") convs-out-s convs-out)])) |