Fiddled around with it for a bit
I mostly added a few safties onto the string-lenght and substring functions so they wouldn't cause a crash, but now somewhere there is some error where string-append is trying to append to something that isn't a string, but I have no idea where it is.
This commit is contained in:
Douglas-Richardson
parent
5e3bdbeeb4
commit
aebda4ef57
3
.gitignore
vendored
3
.gitignore
vendored
@ -9,3 +9,6 @@
|
||||
# ignore racket compile files
|
||||
*.dep
|
||||
*.zo
|
||||
|
||||
#ignore backup files
|
||||
*.bak
|
||||
@ -15,7 +15,7 @@
|
||||
(begin
|
||||
;;Create the frame
|
||||
(define main-frame (new frame%
|
||||
[label "Example5"]
|
||||
[label "Hermes"]
|
||||
[width 500]
|
||||
[height 700]
|
||||
))
|
||||
@ -54,13 +54,18 @@
|
||||
;;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)))
|
||||
(define given-input (send input get-value))
|
||||
(if (string? given-input)
|
||||
(if (color-change-request? given-input)
|
||||
(set! my-color (get-color-from-input given-input))
|
||||
(if (quit-request? given-input)
|
||||
(write "quit" the-output-port)
|
||||
(if (< 0 (string-length-safe given-input))
|
||||
(send-message (send input get-value) my-color);;
|
||||
'()))
|
||||
(send input set-value "")
|
||||
))
|
||||
'())))
|
||||
'())
|
||||
(send input set-value "")))
|
||||
|
||||
(define send-button (new button%
|
||||
[parent main-frame]
|
||||
[label "Send"]
|
||||
@ -72,33 +77,39 @@
|
||||
;;messaging stuff
|
||||
|
||||
(define (user-message-parse string start)
|
||||
(begin
|
||||
(define (helper str index)
|
||||
(if (string? string)
|
||||
(if (>= (+ start index) (string-length-safe string))
|
||||
(display string);;Something went wrong
|
||||
(if (eq? (string-ref str (+ start index)) #\~)
|
||||
(substring str start (+ start index))
|
||||
(substring-s str start (+ start index))
|
||||
(helper str (+ index 1))))
|
||||
(helper string 0)))
|
||||
'()))
|
||||
(helper string start))
|
||||
|
||||
(define (user-message onetrueinput)
|
||||
(begin
|
||||
(if (string? onetrueinput)
|
||||
(let();;This is kind of stupid but whatever it works.
|
||||
(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))))
|
||||
(define user-input (user-message-parse onetrueinput (+ 1(string-length-safe username))))
|
||||
(define color (substring-s onetrueinput (+ 2 (string-length-safe username) (string-length-safe user-input)) (string-length-safe onetrueinput)))
|
||||
(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)))
|
||||
(send dc draw-text (string-append username ":" user-input) 0 height)
|
||||
(set! listy (appendlist listy (list username user-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)))
|
||||
(if (> (* 20 (string-length-safe user-input)) min-h-size)
|
||||
(set! min-h-size (* 20 (string-length-safe user-input)))
|
||||
'())
|
||||
(send read-canvas init-auto-scrollbars min-h-size min-v-size 0 1)
|
||||
))
|
||||
(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
|
||||
|
||||
(define the-output-port (open-output-string))
|
||||
|
||||
;;This probably won't change...
|
||||
(define (send-message input color)
|
||||
(user-message (string-append name "~" input "~" color)))
|
||||
(write (string-append name "~" input "~" color) the-output-port))
|
||||
;;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)
|
||||
@ -138,8 +149,9 @@
|
||||
(set! name newname)
|
||||
(print "Thats not good"))))
|
||||
((eq? command 'recieve-message) user-message)
|
||||
((eq? command 'get-list) listy)
|
||||
((eq? command 'set-list) update)
|
||||
;((eq? command 'get-list) listy)
|
||||
;((eq? command 'set-list) update)
|
||||
((eq? command 'get-output-port) the-output-port)
|
||||
;;Something up with that
|
||||
(else (error "Invalid Request" command))
|
||||
))
|
||||
@ -179,18 +191,38 @@
|
||||
(define (get-height-from-list in-list)
|
||||
(car (cdr (cdr (cdr in-list)))))
|
||||
|
||||
(define (get-color-from-input input)
|
||||
(substring-s input 6 (string-length-safe input)))
|
||||
|
||||
|
||||
|
||||
;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")
|
||||
(if (> (string-length-safe given-string) 7)
|
||||
(if (equal? (substring-s given-string 0 6) "/color")
|
||||
#t
|
||||
#f)
|
||||
#f))
|
||||
|
||||
(define (get-color-from-input given-string)
|
||||
(substring given-string 7))
|
||||
|
||||
(define (quit-request? given-string)
|
||||
(if (>= (string-length-safe given-string) 5)
|
||||
(if ((equal? substring-s given-string 0 5) "/quit")
|
||||
#t
|
||||
#f)
|
||||
#f))
|
||||
|
||||
(define (string-length-safe string)
|
||||
(if (string? string)
|
||||
(string-length string)
|
||||
0))
|
||||
|
||||
(define (substring-s string start end)
|
||||
(if (<= start end)
|
||||
(if (<= end (string-length-safe string))
|
||||
(substring string start end)
|
||||
"")
|
||||
""))
|
||||
;(define thing1 (make-gui))
|
||||
;(define thing2 (make-gui))
|
||||
|
||||
|
||||
@ -25,6 +25,7 @@
|
||||
(define error-out (open-output-file "./error_client.out" #:exists 'append))
|
||||
(define error-out-s (make-semaphore 1))
|
||||
|
||||
(define gui (make-gui))
|
||||
; custodian for client connections
|
||||
(define main-client-cust (make-custodian))
|
||||
; make connection to server
|
||||
@ -38,9 +39,10 @@
|
||||
; info used for authentication with server
|
||||
(displayln "What's your name?")
|
||||
(define username (read-line))
|
||||
|
||||
((gui 'set-name) username)
|
||||
(gui 'show)
|
||||
;send the username to the server (username in out)
|
||||
(displayln username out)
|
||||
;(displayln username out)
|
||||
(flush-output out)
|
||||
|
||||
(define a (thread
|
||||
@ -77,16 +79,22 @@
|
||||
(number->string (date-second date-today))
|
||||
" | "))
|
||||
;; read, quits when user types in "quit"
|
||||
(define input (read-line))
|
||||
;(define input (read-line))
|
||||
(define input (get-output-string (gui 'get-output-port)))
|
||||
; TODO /quit instead of 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)
|
||||
(close-output-port error-out)
|
||||
(close-output-port convs-out)
|
||||
(exit)))
|
||||
|
||||
(displayln (string-append date-print username ": " input) out)
|
||||
;(displayln (string-append date-print username ": " input) out)
|
||||
(if (not (null? input))
|
||||
(begin
|
||||
(display input)
|
||||
(displayln input out))
|
||||
'())
|
||||
(flush-output out))
|
||||
|
||||
; receives input from server and displays it to stdout
|
||||
@ -100,9 +108,12 @@
|
||||
;(exit)
|
||||
]
|
||||
[(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)] ; could time stamp here or to send message
|
||||
((gui 'recieve-message) evt)]
|
||||
[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)
|
||||
(define stop-client (client 4321))
|
||||
|
||||
@ -126,10 +126,10 @@
|
||||
(semaphore-post c-count-s)
|
||||
|
||||
(displayln-safe successful-connection-m)
|
||||
(displayln welcome-message out)
|
||||
;(displayln welcome-message out)
|
||||
;; print to server log and client
|
||||
(define print-no-users (string-append "Number of users in chat: "
|
||||
(number->string ((c-count 'current-count)))))
|
||||
(define print-no-users (string-append "Server~Number of users in chat: "
|
||||
(number->string ((c-count 'current-count))) "~Red"))
|
||||
(displayln print-no-users out)
|
||||
(displayln-safe print-no-users convs-out-s convs-out)
|
||||
(flush-output out)
|
||||
@ -195,7 +195,7 @@
|
||||
; try to send that user the whisper
|
||||
(if (port-closed? (get-output-port that-user-ports))
|
||||
(begin
|
||||
(displayln "User is unavailable" out)
|
||||
(displayln "Server~User is unavailable~red" out)
|
||||
(flush-output out))
|
||||
(begin
|
||||
(displayln (string-append (whisper-info whisper) (whisper-message whisper))
|
||||
@ -206,8 +206,9 @@
|
||||
;;should put a semaphore on connections
|
||||
(semaphore-wait c-count-s)
|
||||
(semaphore-wait connections-s)
|
||||
(define no-of-users (string-append "Number of users in chat: "
|
||||
(number->string ((c-count 'current-count)))))
|
||||
(define no-of-users (string-append "Server~Number of users in chat: "
|
||||
(number->string ((c-count 'current-count)))
|
||||
"~red"))
|
||||
(displayln no-of-users out)
|
||||
(flush-output out)
|
||||
(semaphore-post connections-s)
|
||||
@ -216,10 +217,13 @@
|
||||
[list-users
|
||||
(semaphore-wait connections-s)
|
||||
; map over connections sending the username to the client
|
||||
(displayln "Here is a list of users in chat." out)
|
||||
(displayln "Server~Here is a list of users in chat.~red" out)
|
||||
(map
|
||||
(lambda (ports)
|
||||
(displayln (get-username ports) out))
|
||||
(displayln (string-append
|
||||
"Server~"
|
||||
(get-username ports)
|
||||
"~red")out))
|
||||
((c-connections 'cons-list)))
|
||||
(flush-output out)
|
||||
(semaphore-post connections-s)]
|
||||
@ -262,7 +266,10 @@
|
||||
(lambda (ports)
|
||||
(if (not (port-closed? (get-output-port ports)))
|
||||
(begin
|
||||
(displayln (first ((c-messages 'mes-list))) (get-output-port ports))
|
||||
(displayln (string-append "Server~"
|
||||
(first ((c-messages 'mes-list)))
|
||||
"~red"
|
||||
) (get-output-port ports))
|
||||
(flush-output (get-output-port ports)))
|
||||
(displayln-safe "Failed to broadcast. Port not open." error-out-s error-out)))
|
||||
((c-connections 'cons-list)))
|
||||
|
||||
@ -1,194 +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
|
||||
|
||||
(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))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user