-
Notifications
You must be signed in to change notification settings - Fork 1
/
xio.rkt
229 lines (188 loc) · 6.66 KB
/
xio.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
#lang racket
(require srfi/13)
(require "x-misc.rkt"
(prefix-in settings: "xsettings.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; File: xio.scm ;;
;; Project: the specializer Unmix ;;
;; Author: S.A.Romanenko, the Institute for Applied ;;
;; Mathematics, the USSR Acedemy of Sciences, ;;
;; Moscow. ;;
;; Created: 6 December 1989 ;;
;; Revised: 28 March 1990 ;;
;; 27 July 1990 ;;
;; October 1993 ;;
;; ;;
;; Contents: The input/output functions, menus etc. ... ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Screen size
(define *ux:screen-height* 24)
(define *ux:screen-width* 80)
;; Clears the screen.
;(define (uio:clear-screen)
; (do ((i 0 (+ 1 i))) ((>= i *ux:screen-height*) #f) (newline)))
(define (uio:clear-screen)
(newline))
(define (uio:spaces k)
(do ((k k (- k 1))) ((<= k 0) #f) (display " ")))
;; Centers and displays a message.
(define (uio:center msg)
(let ((lm (quotient (- *ux:screen-width* 1 (string-length msg)) 2) ))
(uio:spaces lm)
(display msg)))
(define (uio:display-menu msg* column items prompt replies)
(define title
'())
(define *line* 1)
(for-each (lambda (item) (display item) (newline)
(set! *line* (+ 1 *line*)))
title)
(newline) (newline) (set! *line* (+ 2 *line*))
(for-each (lambda (item) (uio:center item) (newline)
(set! *line* (+ 1 *line*)))
msg*)
(newline) (set! *line* (+ 1 *line*))
(do ((items items (cdr items)))
((null? items))
(uio:spaces column)
(display (car items))(newline)(set! *line* (+ 1 *line*)))
(do ((*line* *line* (+ 1 *line*)))
((>= *line* *ux:screen-height*))
(newline))
(uio:query prompt replies))
;;
;; Reads a character from the keyboard.
;; The character must be on the list lst.
;;
(define (uio:query msg lst)
(do () ((not (char-ready?))) (read-char))
(let loop ()
(when (not (null? msg))
(begin (display msg) (display ": ")))
(let ((item (read)))
(if (member item lst)
item
(begin (display " ???") (newline) (loop))))))
;;
;; Waits for a key to be pressed.
;;
(define (uio:pause)
(newline) (display "Press Enter to continue...") (newline)
(do () ((not (char-ready?))) (read-char))
(uio:read-line))
;;
;; Requests a string.
;;
(define (uio:request-string msg)
(do () ((not (char-ready?))) (read-char))
(newline) (display msg)
(uio:read-line))
(define (uio:string-upcase s)
(let* ((len (string-length s))
(new-s (make-string len)))
(do ((k 0 (+ 1 k)))
((= k len) new-s)
(string-set! new-s k (char-upcase (string-ref s k))))))
;;
;; Reads characters upto #\newline.
;;
(define (uio:read-line)
(string-trim (read-line)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Input and Output ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Reads a Scheme program from the file "src".
;;
(define (uio:file->list file)
(let ((port (open-input-file file)))
(let loop ((acc '()))
(let ((o (read port)))
(if (eof-object? o)
(begin (close-input-port port) (reverse acc))
(loop (cons o acc)))))))
(define (uio:list->file name lst)
(let ((p (open-output-file name)))
(uio:write-list lst p)
(close-output-port p)))
(define (uio:write-list lst port)
(for-each
(lambda (item) (write item port) (newline port) (newline port))
lst))
;;
;; Pretty prints list "lst" into the file "name".
;; Used to write target scheme/racket files.
;;
(define (uio:list->pp-target-file file lst width)
(let ([lang-expr (if settings:**output-as-racket-module**
(format "~a\n\n" settings:**lang-directive**)
"")]
[provide-expr (if settings:**output-as-racket-module**
(format "~a" '(provide (all-defined-out)))
"")])
(uio:list->pp-file file lst width lang-expr provide-expr)))
;;
;; Pretty prints list "lst" into the file "name".
;; The "header" and "footer" can be used to provide some additional info
;; before and after the pretty-printed list "lst".
;;
(define (uio:list->pp-file file lst width [header ""] [footer ""])
(let ((p (open-output-file file)))
(write-string header p)
(uio:pp-list lst p)
(write-string footer p)
(close-output-port p)))
(define (uio:pp-list mexp* port)
(let ([exp* (mpairs->pairs mexp*)]) ; converting to immutable
; using pretty-write to pretty print expressions without quotes
(for-each (lambda (exp) (pretty-write exp port) (newline port)) exp*)))
;;
;; Requests name.
;;
(define (uio:request-name msg name)
(let* ((name (uio:cut-off-ext name))
(str (uio:request-string (string-append msg " [" name "]:"))))
(if (string=? str "") name str)))
;;
;; Requests file name.
;;
(define (uio:request-file-name msg name ext)
(let ((name (uio:cut-off-ext name)))
(uio:norm-file-name
name ext
(uio:request-string (string-append msg " [" name "." ext "]: ")))))
;;
;; Normalizes file name.
;;
(define (uio:norm-file-name name ext name-ext)
(let ((len (string-length name-ext)))
(when (not (zero? len))
(let ((pos (uio:char-pos #\. name-ext)))
(cond
((not pos) (set! name name-ext))
((zero? pos) (set! ext (substring name-ext 1 len)))
(else
(set! name (substring name-ext 0 pos))
(set! ext (substring name-ext (+ pos 1) len)))))))
(string-append name "." ext))
;;
;; Cuts off file name extension.
;;
(define (uio:cut-off-ext name-ext)
(let ((pos (uio:char-pos #\. name-ext)))
(if pos
(substring name-ext 0 pos)
name-ext)))
(define (uio:char-pos char str)
(let ((len (string-length str)))
(let loop ((n 0))
(cond
((= n len) #f)
((eqv? char (string-ref str n)) n)
(else
(loop (+ n 1)))))))
(provide (all-defined-out))