commit
044e36ff5d
322
Hermes/GUI.rkt
Normal file
322
Hermes/GUI.rkt
Normal file
@ -0,0 +1,322 @@
|
|||||||
|
#lang racket
|
||||||
|
(require racket/gui/base)
|
||||||
|
;Author:Douglas Richardson
|
||||||
|
;Notes:Our GUI mostly deals with lists of a list of 3 strings and a number
|
||||||
|
;although the number is always delt with locally
|
||||||
|
;When using user-message you need to give it a list of 3 things
|
||||||
|
;The name of the user as a string, what they said as a string,
|
||||||
|
;and the color as a string
|
||||||
|
|
||||||
|
;Object stuff
|
||||||
|
; TODO make different objects threadable send button vs text area vs canvas
|
||||||
|
; TODO gui is just a relay remember
|
||||||
|
; TODO create a dialog to ask user for his username. This should be wrapped in a
|
||||||
|
; function get-username that we can call
|
||||||
|
|
||||||
|
(provide make-gui)
|
||||||
|
|
||||||
|
; 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)
|
||||||
|
;;Create the frame/window with title "Example5", width 500 and height 700
|
||||||
|
(define main-frame (new frame%
|
||||||
|
[label "Hermes"]
|
||||||
|
[width 500]
|
||||||
|
[height 700]
|
||||||
|
))
|
||||||
|
;;Editing canvas
|
||||||
|
(define (do-stuff-paint paint-canvas paint-dc)
|
||||||
|
(do-more-stuff-paint listy paint-canvas paint-dc))
|
||||||
|
|
||||||
|
(define (do-more-stuff-paint paint-listy paint-canvas paint-dc)
|
||||||
|
(if (null? paint-listy)
|
||||||
|
'()
|
||||||
|
(begin
|
||||||
|
(re-draw-message (get-username-from-list (car paint-listy))
|
||||||
|
(get-message-from-list (car paint-listy))
|
||||||
|
(get-color-from-list (car paint-listy))
|
||||||
|
(get-height-from-list (car paint-listy)))
|
||||||
|
(do-more-stuff-paint (cdr paint-listy) paint-canvas paint-dc))))
|
||||||
|
|
||||||
|
; canvas for displaying messages with horizontal and vertical scrollbar.
|
||||||
|
; on an event it calls do-stuff-paint to redraw things on the screen
|
||||||
|
; properly
|
||||||
|
(define read-canvas (new canvas%
|
||||||
|
[parent main-frame]
|
||||||
|
[paint-callback do-stuff-paint]
|
||||||
|
[style '(hscroll vscroll)]
|
||||||
|
))
|
||||||
|
|
||||||
|
; "send" is rackets way of doing object-oriented programming. It calls an
|
||||||
|
; objects functions in this case "read-canvas" object's init-auto-scrollbars
|
||||||
|
(send read-canvas init-auto-scrollbars #f #f 0 0);Start with no scrollbars
|
||||||
|
|
||||||
|
; editing area callback. Gets called when enter is pressed.
|
||||||
|
(define (text-field-callback callback-type other-thing)
|
||||||
|
(if (equal? 'text-field-enter (send other-thing get-event-type))
|
||||||
|
(button-do-stuff 'irrelevant 'not-used)
|
||||||
|
'()))
|
||||||
|
|
||||||
|
; creates the editing area as part of the parent "main-frame" define above.
|
||||||
|
; initially labelled "Username:"
|
||||||
|
; NOTE: we pad label with additional spaces so we don't have to recompute
|
||||||
|
; the window dimensions to fit the new label (the actual username)
|
||||||
|
; TODO make label setable
|
||||||
|
(define input (new text-field%
|
||||||
|
[parent main-frame]
|
||||||
|
[label "username "]
|
||||||
|
[callback text-field-callback]
|
||||||
|
))
|
||||||
|
|
||||||
|
; It's a callback function activated when the send button is pressed in the
|
||||||
|
; GUI. It is also called manually when textfield receives an enter key
|
||||||
|
(define (button-do-stuff b e);b and e do nothing :/
|
||||||
|
(if (color-change-request? (send input get-value))
|
||||||
|
(set! my-color (get-color-from-input (send input get-value)))
|
||||||
|
(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 )
|
||||||
|
)
|
||||||
|
'()))
|
||||||
|
(send input set-value "")
|
||||||
|
)
|
||||||
|
|
||||||
|
; retrieves a message user inputed to the text field
|
||||||
|
(define (get-message)
|
||||||
|
(semaphore-wait messages-s)
|
||||||
|
(define one-message
|
||||||
|
(if (not (null? messages))
|
||||||
|
(begin
|
||||||
|
;(define msg (car messages))
|
||||||
|
(car messages)
|
||||||
|
;(set! messages (cdr messages))
|
||||||
|
)
|
||||||
|
'()))
|
||||||
|
(semaphore-post messages-s)
|
||||||
|
|
||||||
|
(if (not (string? one-message))
|
||||||
|
(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%
|
||||||
|
[parent main-frame]
|
||||||
|
[label "Send"]
|
||||||
|
[callback button-do-stuff]))
|
||||||
|
|
||||||
|
; get-dc retrieves the canvas' device context. From racket docs. A dc object
|
||||||
|
; is a drawing context for drawing graphics and text. It represents output
|
||||||
|
; devices in a generic way.
|
||||||
|
; Specifically the line below retrieves our canvas device context object.
|
||||||
|
(define dc (send read-canvas get-dc))
|
||||||
|
(send dc set-scale 1 1) ; set scaling config of output display to 1 to 1
|
||||||
|
; no scalling
|
||||||
|
(send dc set-text-foreground "black") ; color of text that gets drawn on the
|
||||||
|
; canvas with "draw-text"
|
||||||
|
; (send dc set-smoothing 'aligned)
|
||||||
|
;;messaging stuff
|
||||||
|
|
||||||
|
; could convert below to regexes
|
||||||
|
(define (user-message-parse string-i start)
|
||||||
|
(define (helper str index)
|
||||||
|
(if (eq? (string-ref str (+ start index)) #\~) ; regexes would allow us
|
||||||
|
; to avoid this #\~
|
||||||
|
(substring str start (+ start index))
|
||||||
|
(helper str (+ index 1))))
|
||||||
|
(helper string-i 0))
|
||||||
|
|
||||||
|
|
||||||
|
;; draws a user input to the screen
|
||||||
|
(define (user-message user-input)
|
||||||
|
(define username (user-message-parse user-input 0))
|
||||||
|
(define input (user-message-parse user-input (+ 1 (string-length username))))
|
||||||
|
(define color (substring user-input (+ 2 (string-length username) (string-length input))))
|
||||||
|
(send dc set-text-foreground color) ; set dc's text color to user
|
||||||
|
; provided
|
||||||
|
; (send dc draw-text (string-append username ":" input) 0 height)
|
||||||
|
(send dc draw-text input 0 height) ;; just print message to string
|
||||||
|
|
||||||
|
(set! listy (appendlist listy (list username input color height)))
|
||||||
|
(set! height (+ height 15))
|
||||||
|
; redraw overly long text on gui
|
||||||
|
(set! min-v-size (+ min-v-size 15))
|
||||||
|
(if (> (* 20 (string-length input)) min-h-size)
|
||||||
|
(set! min-h-size (* 20 (string-length input)))
|
||||||
|
'())
|
||||||
|
(send read-canvas init-auto-scrollbars min-h-size min-v-size 0 1)
|
||||||
|
)
|
||||||
|
;;Add a function that parces input from a string-i and extracts elements
|
||||||
|
|
||||||
|
; actually gets called to send input to the screen. user-message is in effect
|
||||||
|
; its helper. It uses "~" to delimit the different components of message
|
||||||
|
(define (send-message input color)
|
||||||
|
(user-message (string-append name "~" input "~" color)))
|
||||||
|
|
||||||
|
;; draws messages to the screen canvas as text
|
||||||
|
(define (re-draw-message username input color in-height)
|
||||||
|
(send dc set-text-foreground color)
|
||||||
|
; (send dc draw-text (string-append username ":" input) 0 in-height)
|
||||||
|
(send dc draw-text input 0 in-height)
|
||||||
|
)
|
||||||
|
|
||||||
|
; used when redrawing the screen along with its helper.
|
||||||
|
(define (update given-list)
|
||||||
|
(set! listy '())
|
||||||
|
(set! height 0)
|
||||||
|
(update-helper given-list))
|
||||||
|
|
||||||
|
(define (update-helper given-list)
|
||||||
|
(if (null? given-list)
|
||||||
|
'()
|
||||||
|
(if (null? (car given-list))
|
||||||
|
'()
|
||||||
|
(begin (user-message
|
||||||
|
(get-username-from-list (car given-list))
|
||||||
|
(get-message-from-list (car given-list))
|
||||||
|
(get-color-from-list (car given-list)))
|
||||||
|
(update-helper (cdr given-list))))))
|
||||||
|
|
||||||
|
;;Variables go below functions
|
||||||
|
; for interfacing with outside elements
|
||||||
|
(define gui-input-in-s '())
|
||||||
|
(define gui-input-out-s '())
|
||||||
|
(define gui-input-in '())
|
||||||
|
(define gui-input-out '())
|
||||||
|
|
||||||
|
(define name "Me")
|
||||||
|
(define min-h-size 80)
|
||||||
|
(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
|
||||||
|
;; could randomly assign a user
|
||||||
|
;; after calling get-text set it as new label of text-field
|
||||||
|
(define (get-username)
|
||||||
|
(define returned (get-text-from-user "Username set-up" "Please enter a username"
|
||||||
|
main-frame "user" (list 'disallow-invalid)
|
||||||
|
#:validate
|
||||||
|
(lambda (input)
|
||||||
|
(if (and (string? input) (<= (string-length input) 10)
|
||||||
|
(>= (string-length input) 2))
|
||||||
|
#t
|
||||||
|
#f))))
|
||||||
|
(send input set-label returned)
|
||||||
|
returned)
|
||||||
|
|
||||||
|
;;dispatch goes below that
|
||||||
|
;; TODO get username function maybe
|
||||||
|
(define (dispatch command)
|
||||||
|
; 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)
|
||||||
|
(set! name newname)
|
||||||
|
(print "Thats not good"))))
|
||||||
|
; ((eq? command 'recieve-message) user-message)
|
||||||
|
; ((eq? command 'get-list) listy)
|
||||||
|
; ((eq? command 'set-list) update)
|
||||||
|
;;Something up with that
|
||||||
|
; else should assume a message and output to screen we do not want it
|
||||||
|
; to fail
|
||||||
|
((eq? command 'get-message) get-message)
|
||||||
|
(else (error "Invalid Request" command))
|
||||||
|
))
|
||||||
|
;;dispatch goes below that
|
||||||
|
dispatch)
|
||||||
|
|
||||||
|
|
||||||
|
;This one displays information
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;Initilize scrolling
|
||||||
|
|
||||||
|
;Then we need to find out if we need them or not.
|
||||||
|
|
||||||
|
;Listy is going to be a list of lists of strings
|
||||||
|
;each element in listy will contain three strings
|
||||||
|
;the username the message they said and the color they used
|
||||||
|
;The the height the message should display at
|
||||||
|
|
||||||
|
; listoflist is listy here, and add-to-end is what gets appended to the end
|
||||||
|
; really expensive operation but its important for Doug to showcase some opl
|
||||||
|
; concepts
|
||||||
|
(define (appendlist listoflist add-to-end)
|
||||||
|
(if (null? listoflist)
|
||||||
|
(cons add-to-end '())
|
||||||
|
(cons (car listoflist) (appendlist (cdr listoflist) add-to-end))))
|
||||||
|
|
||||||
|
(define (get-username-from-list in-list)
|
||||||
|
(car in-list))
|
||||||
|
|
||||||
|
(define (get-message-from-list in-list)
|
||||||
|
(car (cdr in-list)))
|
||||||
|
|
||||||
|
(define (get-color-from-list in-list)
|
||||||
|
(car (cdr (cdr in-list))))
|
||||||
|
|
||||||
|
(define (get-height-from-list in-list)
|
||||||
|
(car (cdr (cdr (cdr in-list)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
; did user request for color change /
|
||||||
|
(define (color-change-request? given-string)
|
||||||
|
(if (> (string-length given-string) 7)
|
||||||
|
(if (equal? (substring given-string 0 6) "/color")
|
||||||
|
#t
|
||||||
|
#f)
|
||||||
|
#f))
|
||||||
|
|
||||||
|
; we should use regexes for this.
|
||||||
|
(define (get-color-from-input given-string)
|
||||||
|
(substring given-string 7))
|
||||||
|
;(define thing1 (make-gui))
|
||||||
|
;(define thing2 (make-gui))
|
||||||
|
|
@ -1,196 +0,0 @@
|
|||||||
#lang racket
|
|
||||||
(require racket/gui/base)
|
|
||||||
;Author:Douglas Richardson
|
|
||||||
;Notes:Our GUI mostly deals with lists of a list of 3 strings and a number
|
|
||||||
;although the number is always delt with locally
|
|
||||||
;When using user-message you need to give it a list of 3 things
|
|
||||||
;The name of the user as a string, what they said as a string,
|
|
||||||
;and the color as a string
|
|
||||||
|
|
||||||
;Object stuff
|
|
||||||
|
|
||||||
(provide make-gui)
|
|
||||||
|
|
||||||
(define (make-gui)
|
|
||||||
(begin
|
|
||||||
;;Create the frame
|
|
||||||
(define main-frame (new frame%
|
|
||||||
[label "Example5"]
|
|
||||||
[width 500]
|
|
||||||
[height 700]
|
|
||||||
))
|
|
||||||
;;Editing canvas
|
|
||||||
(define (do-stuff-paint paint-canvas paint-dc)
|
|
||||||
(do-more-stuff-paint listy paint-canvas paint-dc))
|
|
||||||
|
|
||||||
(define (do-more-stuff-paint paint-listy paint-canvas paint-dc)
|
|
||||||
(if (null? paint-listy)
|
|
||||||
'()
|
|
||||||
(begin
|
|
||||||
(re-draw-message (get-username-from-list (car paint-listy))
|
|
||||||
(get-message-from-list (car paint-listy))
|
|
||||||
(get-color-from-list (car paint-listy))
|
|
||||||
(get-height-from-list (car paint-listy)))
|
|
||||||
(do-more-stuff-paint (cdr paint-listy) paint-canvas paint-dc))))
|
|
||||||
|
|
||||||
(define read-canvas (new canvas%
|
|
||||||
[parent main-frame]
|
|
||||||
[paint-callback do-stuff-paint]
|
|
||||||
[style '(hscroll vscroll)]
|
|
||||||
))
|
|
||||||
|
|
||||||
(send read-canvas init-auto-scrollbars #f #f 0 0);Start with no scrollbars
|
|
||||||
;;text-field stuff
|
|
||||||
(define (text-feild-callback callback-type other-thing)
|
|
||||||
(if (equal? 'text-field-enter (send other-thing get-event-type))
|
|
||||||
(button-do-stuff 'irrelevant 'not-used)
|
|
||||||
'()))
|
|
||||||
|
|
||||||
(define input (new text-field%
|
|
||||||
[parent main-frame]
|
|
||||||
[label "Username:"]
|
|
||||||
[callback text-feild-callback]
|
|
||||||
))
|
|
||||||
;;button stuff
|
|
||||||
(define (button-do-stuff b e);b and e do nothing :/
|
|
||||||
(begin
|
|
||||||
(if (color-change-request? (send input get-value))
|
|
||||||
(set! my-color (get-color-from-input (send input get-value)))
|
|
||||||
(if (< 0 (string-length (send input get-value)))
|
|
||||||
(send-message (send input get-value) my-color);;
|
|
||||||
'()))
|
|
||||||
(send input set-value "")
|
|
||||||
))
|
|
||||||
(define send-button (new button%
|
|
||||||
[parent main-frame]
|
|
||||||
[label "Send"]
|
|
||||||
[callback button-do-stuff]))
|
|
||||||
;;I forget what these do but don't move them
|
|
||||||
(define dc (send read-canvas get-dc))
|
|
||||||
(send dc set-scale 1 1)
|
|
||||||
(send dc set-text-foreground "black")
|
|
||||||
;;messaging stuff
|
|
||||||
|
|
||||||
(define (user-message-parse string start)
|
|
||||||
(begin
|
|
||||||
(define (helper str index)
|
|
||||||
(if (eq? (string-ref str (+ start index)) #\~)
|
|
||||||
(substring str start (+ start index))
|
|
||||||
(helper str (+ index 1))))
|
|
||||||
(helper string 0)))
|
|
||||||
|
|
||||||
(define (user-message onetrueinput)
|
|
||||||
(begin
|
|
||||||
(define username (user-message-parse onetrueinput 0))
|
|
||||||
(define input (user-message-parse onetrueinput (+ 1(string-length username))))
|
|
||||||
(define color (substring onetrueinput (+ 2 (string-length username) (string-length input))))
|
|
||||||
(send dc set-text-foreground color)
|
|
||||||
(send dc draw-text (string-append username ":" input) 0 height)
|
|
||||||
(set! listy (appendlist listy (list username input color height)))
|
|
||||||
(set! height (+ height 15))
|
|
||||||
(set! min-v-size (+ min-v-size 15))
|
|
||||||
(if (> (* 20 (string-length input)) min-h-size)
|
|
||||||
(set! min-h-size (* 20 (string-length input)))
|
|
||||||
'())
|
|
||||||
(send read-canvas init-auto-scrollbars min-h-size min-v-size 0 1)
|
|
||||||
))
|
|
||||||
;;Add a function that parces input from a string and extracts elements
|
|
||||||
|
|
||||||
;;This probably won't change...
|
|
||||||
(define (send-message input color)
|
|
||||||
(user-message (string-append name "~" input "~" color)))
|
|
||||||
;;Although re-draw is kind of misleading, it is just print the whole
|
|
||||||
;;list of strings to the screen
|
|
||||||
(define (re-draw-message username input color in-height)
|
|
||||||
(begin
|
|
||||||
(send dc set-text-foreground color)
|
|
||||||
(send dc draw-text (string-append username ":" input) 0 in-height)
|
|
||||||
))
|
|
||||||
|
|
||||||
(define (update given-list)
|
|
||||||
(begin (set! listy '())
|
|
||||||
(set! height 0)
|
|
||||||
(update-helper given-list)))
|
|
||||||
|
|
||||||
(define (update-helper given-list)
|
|
||||||
(if (null? given-list)
|
|
||||||
'()
|
|
||||||
(if (null? (car given-list))
|
|
||||||
'()
|
|
||||||
(begin (user-message
|
|
||||||
(get-username-from-list (car given-list))
|
|
||||||
(get-message-from-list (car given-list))
|
|
||||||
(get-color-from-list (car given-list)))
|
|
||||||
(update-helper (cdr given-list))))))
|
|
||||||
|
|
||||||
;;Variables go below functions
|
|
||||||
(define name "Me")
|
|
||||||
(define min-h-size 80)
|
|
||||||
(define min-v-size 30)
|
|
||||||
(define listy (list (list "Server" "Connected" "Red" 0)))
|
|
||||||
(define my-color "black")
|
|
||||||
(define height 15)
|
|
||||||
;;dispatch goes below that
|
|
||||||
(define (dispatch command)
|
|
||||||
(cond ((eq? command 'show) (send main-frame show #t))
|
|
||||||
((eq? command 'send) send-message)
|
|
||||||
((eq? command 'set-name) (lambda (newname) (if (string? newname)
|
|
||||||
(set! name newname)
|
|
||||||
(print "Thats not good"))))
|
|
||||||
((eq? command 'recieve-message) user-message)
|
|
||||||
((eq? command 'get-list) listy)
|
|
||||||
((eq? command 'set-list) update)
|
|
||||||
;;Something up with that
|
|
||||||
(else (error "Invalid Request" command))
|
|
||||||
))
|
|
||||||
;;dispatch goes below that
|
|
||||||
dispatch))
|
|
||||||
|
|
||||||
|
|
||||||
;This one displays information
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;Initilize scrolling
|
|
||||||
|
|
||||||
;Then we need to find out if we need them or not.
|
|
||||||
|
|
||||||
;Listy is going to be a list of lists of strings
|
|
||||||
;each element in listy will contain three strings
|
|
||||||
;the username the message they said and the color they used
|
|
||||||
;The the height the message should display at
|
|
||||||
|
|
||||||
|
|
||||||
(define (appendlist listoflist add-to-end)
|
|
||||||
(if (null? listoflist)
|
|
||||||
(cons add-to-end '())
|
|
||||||
(cons (car listoflist) (appendlist (cdr listoflist) add-to-end))))
|
|
||||||
|
|
||||||
(define (get-username-from-list in-list)
|
|
||||||
(car in-list))
|
|
||||||
|
|
||||||
(define (get-message-from-list in-list)
|
|
||||||
(car (cdr in-list)))
|
|
||||||
|
|
||||||
(define (get-color-from-list in-list)
|
|
||||||
(car (cdr (cdr in-list))))
|
|
||||||
|
|
||||||
(define (get-height-from-list in-list)
|
|
||||||
(car (cdr (cdr (cdr in-list)))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;this one is a crap version of justpressing the enter key
|
|
||||||
(define (color-change-request? given-string)
|
|
||||||
(if (> (string-length given-string) 7)
|
|
||||||
(if (equal? (substring given-string 0 6) "/color")
|
|
||||||
#t
|
|
||||||
#f)
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(define (get-color-from-input given-string)
|
|
||||||
(substring given-string 7))
|
|
||||||
;(define thing1 (make-gui))
|
|
||||||
;(define thing2 (make-gui))
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
|||||||
FEATURES
|
FEATURES
|
||||||
5. parser in the client side should do something similar (/color, /quit)
|
5. parser in the client side should do something similar (/color, /quit)
|
||||||
16. plain tcp -> ssl based
|
16. plain tcp -> ssl based
|
||||||
17. fix breaks for improper disconnects from clients
|
***17. fix breaks for improper disconnects from clients
|
||||||
18. Add topics after project completion
|
18. Add topics after project completion
|
||||||
** regexes to parse strings for different formats -related to 5
|
** regexes to parse strings for different formats -related to 5
|
||||||
** align code better for readability
|
** align code better for readability
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
#lang racket
|
#lang racket
|
||||||
|
|
||||||
(require "modules/general.rkt" "Hermes_Gui1.3.rkt")
|
(require "modules/general.rkt" "GUI.rkt")
|
||||||
(require math/base) ;; for random number generation
|
(require math/base) ;; for random number generation
|
||||||
;; TODO clean up string message output and alignment
|
;; TODO clean up string message output and alignment
|
||||||
;; TODO close ports after done
|
;; TODO close ports after done
|
||||||
@ -10,13 +10,19 @@
|
|||||||
;; notes: output may need to be aligned and formatted nicely
|
;; notes: output may need to be aligned and formatted nicely
|
||||||
|
|
||||||
|
|
||||||
; we will prompt for these in the gui
|
(define hermes-gui (make-gui)) ;; our gui
|
||||||
|
((hermes-gui 'show))
|
||||||
|
;(sleep 0.25)
|
||||||
|
|
||||||
|
|
||||||
(define host3 "localhost")
|
(define host3 "localhost")
|
||||||
(define port-num 4321)
|
(define port-num 4321)
|
||||||
(define sleep-t 0.1)
|
(define sleep-t 0.1)
|
||||||
|
|
||||||
|
(define hermes-gui-s (make-semaphore 1))
|
||||||
|
|
||||||
; we won't need this. Just me being overzealous
|
; we won't need this. Just me being overzealous
|
||||||
(define hermes-conf (open-output-file "./hermes_client.conf" #:exists'append))
|
(define hermes-conf (open-output-file "./hermes_client.conf" #:exists 'append))
|
||||||
(define hermes-conf-s (make-semaphore 1))
|
(define hermes-conf-s (make-semaphore 1))
|
||||||
|
|
||||||
(define convs-out (open-output-file "./convs_client.out" #:exists 'append))
|
(define convs-out (open-output-file "./convs_client.out" #:exists 'append))
|
||||||
@ -37,8 +43,16 @@
|
|||||||
|
|
||||||
; store username to a file for later retrieval along with relevent
|
; store username to a file for later retrieval along with relevent
|
||||||
; info used for authentication with server
|
; info used for authentication with server
|
||||||
(displayln "What's your name?")
|
; TODO
|
||||||
(define username (read-line))
|
; semaphore for gui object
|
||||||
|
; could display a bubble and prompt for username in GUI object
|
||||||
|
|
||||||
|
; create a gui object
|
||||||
|
; (define hermes-gui (make-gui))
|
||||||
|
; ((hermes-gui 'show))
|
||||||
|
;(displayln "What's your name?")
|
||||||
|
;(define username (read-line))
|
||||||
|
(define username ((hermes-gui 'get-username)))
|
||||||
|
|
||||||
;send the username to the server (username in out)
|
;send the username to the server (username in out)
|
||||||
(displayln username out)
|
(displayln username out)
|
||||||
@ -59,11 +73,14 @@
|
|||||||
(sleep sleep-t)
|
(sleep sleep-t)
|
||||||
(loop)))))
|
(loop)))))
|
||||||
(displayln-safe "Now waiting for sender thread." error-out-s error-out)
|
(displayln-safe "Now waiting for sender thread." error-out-s error-out)
|
||||||
(thread-wait t) ;; returns prompt back to drracket
|
; (thread-wait t) ;; returns prompt back to drracket
|
||||||
|
)
|
||||||
|
|
||||||
|
(lambda ()
|
||||||
(displayln-safe "Closing client ports." error-out-s error-out)
|
(displayln-safe "Closing client ports." error-out-s error-out)
|
||||||
(close-input-port in)
|
;(close-input-port in)
|
||||||
(close-output-port out))
|
;(close-output-port out)
|
||||||
(custodian-shutdown-all main-client-cust))
|
(custodian-shutdown-all main-client-cust)))
|
||||||
|
|
||||||
|
|
||||||
;; sends a message to the server
|
;; sends a message to the server
|
||||||
@ -78,18 +95,31 @@
|
|||||||
(number->string (date-second date-today))
|
(number->string (date-second date-today))
|
||||||
" | "))
|
" | "))
|
||||||
;; read, quits when user types in "quit"
|
;; read, quits when user types in "quit"
|
||||||
(define input (read-line))
|
;; 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
|
; TODO /quit instead of quit
|
||||||
(cond ((string=? input "quit")
|
(cond ((string=? input "/quit")
|
||||||
(displayln (string-append date-print username " signing out. See ya!") out)
|
(displayln (string-append date-print username " signing out. See ya!") out)
|
||||||
(flush-output out)
|
(flush-output out)
|
||||||
(close-output-port error-out)
|
(close-output-port error-out)
|
||||||
(close-output-port convs-out)
|
(close-output-port convs-out)
|
||||||
|
;(custodian-shutdown-all main-client-cust)
|
||||||
(exit)))
|
(exit)))
|
||||||
|
|
||||||
(displayln (string-append date-print username ": " input) out)
|
(displayln (string-append date-print username ": " input) out)
|
||||||
(flush-output out))
|
(flush-output out))
|
||||||
|
|
||||||
|
; 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)))
|
||||||
|
|
||||||
; receives input from server and displays it to stdout
|
; receives input from server and displays it to stdout
|
||||||
(define (receive-messages in)
|
(define (receive-messages in)
|
||||||
; retrieve a message from server
|
; retrieve a message from server
|
||||||
@ -101,9 +131,18 @@
|
|||||||
;(exit)
|
;(exit)
|
||||||
]
|
]
|
||||||
[(string? evt)
|
[(string? evt)
|
||||||
(displayln-safe evt convs-out-s convs-out)] ; could time stamp here or to send message
|
(displayln-safe evt convs-out-s convs-out)
|
||||||
|
; 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
|
[else
|
||||||
(displayln-safe (string-append "Nothing received from server for 2 minutes.") convs-out-s convs-out)]))
|
(displayln-safe (string-append "Nothing received from server for 2 minutes.") convs-out-s convs-out)]))
|
||||||
|
|
||||||
(displayln-safe "Starting client." error-out-s error-out)
|
(displayln-safe "Starting client." error-out-s error-out)
|
||||||
(define stop-client (client 4321))
|
(define stop-client (client 4321))
|
||||||
|
;(define stop-client (client 4321))
|
||||||
|
; we will prompt for these in the gui
|
||||||
|
|
||||||
|
@ -186,6 +186,7 @@
|
|||||||
(define list-count (regexp-match #px"(.*)/list\\s+count\\s*" evt-t0)) ;; is client asking for number of logged in users
|
(define list-count (regexp-match #px"(.*)/list\\s+count\\s*" evt-t0)) ;; is client asking for number of logged in users
|
||||||
(define list-users (regexp-match #px"(.*)/list\\s+users\\s*" evt-t0)) ;; user names
|
(define list-users (regexp-match #px"(.*)/list\\s+users\\s*" evt-t0)) ;; user names
|
||||||
; do something whether it was a message, a whisper, request for number of users and so on
|
; do something whether it was a message, a whisper, request for number of users and so on
|
||||||
|
; TODO if user doesn't exist handle it********
|
||||||
(cond [whisper
|
(cond [whisper
|
||||||
(semaphore-wait connections-s)
|
(semaphore-wait connections-s)
|
||||||
; get output port for user
|
; get output port for user
|
||||||
|
Loading…
Reference in New Issue
Block a user