about summary refs log tree commit diff stats
path: root/080trace_browser.cc
blob: f399ae7e4bbc2a82c99938d9674605be6dc6504e (plain) (blame)
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
:(before "End Primitive Recipe Declarations")
_BROWSE_TRACE,
:(before "End Primitive Recipe Numbers")
Recipe_ordinal["$browse-trace"] = _BROWSE_TRACE;
:(before "End Primitive Recipe Implementations")
case _BROWSE_TRACE: {
  start_trace_browser();
  break;
}

:(before "End Globals")
set<long long int> Visible;
long long int Top_of_screen = 0;
long long int Last_printed_row = 0;
map<int, long long int> Trace_index;  // screen row -> trace index

:(code)
void start_trace_browser() {
  if (!Trace_stream) return;
  cerr << "computing depth to display\n";
  long long int min_depth = 9999;
  for (long long int i = 0; i < SIZE(Trace_stream->past_lines); ++i) {
    trace_line& curr_line = Trace_stream->past_lines.at(i);
    if (curr_line.depth == 0) continue;
    if (curr_line.depth < min_depth) min_depth = curr_line.depth;
  }
  cerr << "depth is " << min_depth << '\n';
  cerr << "computing lines to display\n";
  for (long long int i = 0; i < SIZE(Trace_stream->past_lines); ++i) {
    if (Trace_stream->past_lines.at(i).depth == min_depth)
      Visible.insert(i);
  }
  tb_init();
  Display_row = Display_column = 0;
  tb_event event;
  Top_of_screen = 0;
  refresh_screen_rows();
  while (true) {
    render();
    do {
      tb_poll_event(&event);
    } while (event.type != TB_EVENT_KEY);
    long long int key = event.key ? event.key : event.ch;
    if (key == 'q' || key == 'Q') break;
    if (key == 'j' || key == TB_KEY_ARROW_DOWN) {
      // move cursor one line down
      if (Display_row < Last_printed_row) ++Display_row;
    }
    if (key == 'k' || key == TB_KEY_ARROW_UP) {
      // move cursor one line up
      if (Display_row > 0) --Display_row;
    }
    if (key == 'H') {
      // move cursor to top of screen
      Display_row = 0;
    }
    if (key == 'M') {
      // move cursor to center of screen
      Display_row = tb_height()/2;
    }
    if (key == 'L') {
      // move cursor to bottom of screen
      Display_row = tb_height()-1;
    }
    if (key == 'J' || key == TB_KEY_PGDN) {
      // page-down
      if (Trace_index.find(tb_height()-1) != Trace_index.end()) {
        Top_of_screen = Trace_index[tb_height()-1]+1;
        refresh_screen_rows();
      }
    }
    if (key == 'K' || key == TB_KEY_PGUP) {
      // page-up is more convoluted
      for (int screen_row = tb_height(); screen_row > 0 && Top_of_screen > 0; --screen_row) {
        --Top_of_screen;
        if (Top_of_screen <= 0) break;
        while (Top_of_screen > 0 && Visible.find(Top_of_screen) == Visible.end())
          --Top_of_screen;
      }
      if (Top_of_screen > 0)
        refresh_screen_rows();
    }
    if (key == 'G') {
      // go to bottom of screen; largely like page-up, interestingly
      Top_of_screen = SIZE(Trace_stream->past_lines)-1;
      for (int screen_row = tb_height(); screen_row > 0 && Top_of_screen > 0; --screen_row) {
        --Top_of_screen;
        if (Top_of_screen <= 0) break;
        while (Top_of_screen > 0 && Visible.find(Top_of_screen) == Visible.end())
          --Top_of_screen;
      }
      refresh_screen_rows();
      // move cursor to bottom
      Display_row = Last_printed_row;
      refresh_screen_rows();
    }
    if (key == TB_KEY_CARRIAGE_RETURN) {
      // expand lines under current by one level
      assert(Trace_index.find(Display_row) != Trace_index.end());
      long long int start_index = Trace_index[Display_row];
      long long int index = 0;
      // simultaneously compute end_index and min_depth
      int min_depth = 9999;
      for (index = start_index+1; index < SIZE(Trace_stream->past_lines); ++index) {
        if (Visible.find(index) != Visible.end()) break;
        trace_line& curr_line = Trace_stream->past_lines.at(index);
        if (curr_line.depth == 0) continue;
        assert(curr_line.depth > Trace_stream->past_lines.at(start_index).depth);
        if (curr_line.depth < min_depth) min_depth = curr_line.depth;
      }
      long long int end_index = index;
      // mark as visible all intervening indices at min_depth
      for (index = start_index; index < end_index; ++index) {
        trace_line& curr_line = Trace_stream->past_lines.at(index);
        if (curr_line.depth == min_depth) {
          Visible.insert(index);
        }
      }
      refresh_screen_rows();
    }
    if (key == TB_KEY_BACKSPACE || key == TB_KEY_BACKSPACE2) {
      // collapse all lines under current
      assert(Trace_index.find(Display_row) != Trace_index.end());
      long long int start_index = Trace_index[Display_row];
      long long int index = 0;
      // end_index is the next line at a depth same as or lower than start_index
      int initial_depth = Trace_stream->past_lines.at(start_index).depth;
      for (index = start_index+1; index < SIZE(Trace_stream->past_lines); ++index) {
        if (Visible.find(index) == Visible.end()) continue;
        trace_line& curr_line = Trace_stream->past_lines.at(index);
        if (curr_line.depth == 0) continue;
        if (curr_line.depth <= initial_depth) break;
      }
      long long int end_index = index;
      // mark as visible all intervening indices at min_depth
      for (index = start_index+1; index < end_index; ++index) {
        Visible.erase(index);
      }
      refresh_screen_rows();
    }
  }
  tb_shutdown();
}

// update Trace_indices for each screen_row on the basis of Top_of_screen and Visible
void refresh_screen_rows() {
  long long int screen_row = 0, index = 0;
  Trace_index.clear();
  for (screen_row = 0, index = Top_of_screen; screen_row < tb_height() && index < SIZE(Trace_stream->past_lines); ++screen_row, ++index) {
    // skip lines without depth for now
    while (Visible.find(index) == Visible.end()) {
      ++index;
      if (index >= SIZE(Trace_stream->past_lines)) goto done;
    }
    assert(index < SIZE(Trace_stream->past_lines));
    Trace_index[screen_row] = index;
  }
done:;
}

void render() {
  long long int screen_row = 0;
  for (screen_row = 0; screen_row < tb_height(); ++screen_row) {
    if (Trace_index.find(screen_row) == Trace_index.end()) break;
    trace_line& curr_line = Trace_stream->past_lines.at(Trace_index[screen_row]);
    ostringstream out;
    out << std::setw(4) << curr_line.depth << ' ' << curr_line.label << ": " << curr_line.contents;
    if (screen_row < tb_height()-1) {
      long long int delta = lines_hidden(screen_row);
      // home-brew escape sequence for red
      if (delta > 999) out << "{";
      out << " (" << lines_hidden(screen_row) << ")";
      if (delta > 999) out << "}";
    }
    render_line(screen_row, out.str());
  }
  // clear rest of screen
  Last_printed_row = screen_row-1;
  for (; screen_row < tb_height(); ++screen_row) {
    render_line(screen_row, "~");
  }
  // move cursor back to display row at the end
  tb_set_cursor(0, Display_row);
  tb_present();
}

long long int lines_hidden(long long int screen_row) {
  assert(Trace_index.find(screen_row) != Trace_index.end());
  if (Trace_index.find(screen_row+1) == Trace_index.end())
    return SIZE(Trace_stream->past_lines)-Trace_index[screen_row];
  else
    return Trace_index[screen_row+1] - Trace_index[screen_row];
}

void render_line(int screen_row, const string& s) {
  long long int col = 0;
  int color = TB_WHITE;
  for (col = 0; col < tb_width() && col < SIZE(s); ++col) {
    char c = s.at(col);  // todo: unicode
    if (c == '\n') c = ';';  // replace newlines with semi-colons
    // escapes. hack: can't start a line with them.
    if (c == '{') { color = /*red*/1; c = ' '; }
    if (c == '}') { color = TB_WHITE; c = ' '; }
    tb_change_cell(col, screen_row, c, color, TB_BLACK);
  }
  for (; col < tb_width(); ++col) {
    tb_change_cell(col, screen_row, ' ', TB_WHITE, TB_BLACK);
  }
}
e silly to type <P><PRE>(lambda (x y) (and (number? x) (number? y))) </PRE> <P>for <CODE>+</CODE>, <CODE>-</CODE>, <CODE>=</CODE>, and so on. Instead, we give this function a name: <P><PRE>(define (<A NAME="g9"></A>two-numbers? x y) (and (number? x) (number? y))) </PRE> <P>We then refer to the type predicate by name in the a-list: <P><PRE>(define *the-functions* ;; partial listing, revised (list (list '* * 2 two-numbers?) (list '+ + 2 two-numbers?) (list 'and (lambda (x y) (and x y)) 2 (lambda (x y) (and (boolean? x) (boolean? y)))) (list 'equal? equal? 2 (lambda (x y) #t)) (list 'even? even? 1 integer?) (list 'word word 2 (lambda (x y) (and (word? x) (word? y)))))) </PRE> <P>Some of the type predicates are more complicated. For example, here's the one for the <CODE>member?</CODE> and <CODE>appearances</CODE> functions: <P><PRE>(define (<A NAME="g10"></A>member-types-ok? small big) (and (word? small) (or (sentence? big) (and (word? big) (= (count small) 1))))) </PRE> <P><CODE>Item</CODE> also has a complicated domain: <P><PRE>(lambda (n stuff) (and (integer? n) (&gt; n 0) (word-or-sent? stuff) (&lt;= n (count stuff)))) </PRE> <P>This invokes <CODE>word-or-sent?</CODE>, which is itself the type predicate for the <CODE>count</CODE> procedure: <P><PRE>(define (word-or-sent? x) (or (word? x) (sentence? x))) </PRE> <P>On the other hand, some are less complicated. <CODE>Equal?</CODE> will accept any two arguments, so its type predicate is just <P><PRE>(lambda (x y) #t) </PRE> <P>The complete listing at the end of the chapter shows the details of all these procedures. Note that the <CODE>functions</CODE> program has a more restricted idea of domain than Scheme does. For example, in Scheme <P><PRE>(and 6 #t) </PRE> <P>returns <CODE>#t</CODE> and does not generate an error. But in the <CODE>functions</CODE> program the argument <CODE>6</CODE> is considered out of the domain.<A NAME="text5" HREF="functions-implement.html#ft5">[5]</A> <P>If you don't like math, just ignore the domain predicates for the mathematical primitives; they involve facts about the domains of math functions that we don't expect you to know.<A NAME="text6" HREF="functions-implement.html#ft6">[6]</A> <P><H2>Intentionally Confusing a Function with Its Name</H2> <P> Earlier we made a big deal about the difference between a procedure and its name, to make sure you wouldn't think you can apply the <EM>word</EM> <CODE>butfirst</CODE> to arguments. But the <CODE>functions</CODE> program completely hides this distinction from the user: <P><PRE>Function: count Argument: butlast The result is: 7 Function: every Argument: butlast Argument: (helter skelter) The result is: (HELTE SKELTE) </PRE> <P>When we give <CODE>butlast</CODE> as an argument to <CODE>count</CODE>, it's as if we'd said <P><PRE>(count 'butlast) </PRE> <P>In other words, it's taken as a word. But when we give <CODE>butlast</CODE> as an argument to <CODE>every</CODE>, it's as if we'd said <P><PRE>(every butlast '(helter skelter)) </PRE> <P>How can we treat some arguments as quoted and others not? The way this works is that <EM>everything</EM> is considered a word or a sentence by the <CODE>functions</CODE> program. The higher-order functions <CODE>every</CODE> and <CODE>keep</CODE> are actually represented in the <CODE>functions</CODE> implementation by Scheme procedures that take the <EM>name</EM> of a function as an argument, instead of a procedure itself as the ordinary versions do: <P><PRE>(define (<A NAME="g11"></A>named-every fn-name list) (every (scheme-procedure fn-name) list)) (define (<A NAME="g12"></A>named-keep fn-name list) (keep (scheme-procedure fn-name) list)) &gt; (every first '(another girl)) (A G) &gt; (named-every 'first '(another girl)) (A G) &gt; (every 'first '(another girl)) ERROR: ATTEMPT TO APPLY NON-PROCEDURE FIRST </PRE> <P> This illustration hides a subtle point. When we invoked <CODE>named-every</CODE> at a Scheme prompt, we had to quote the word <CODE>first</CODE> that we used as its argument. But when you run the <CODE>functions</CODE> program, you don't quote anything. The point is that <CODE>functions</CODE> provides an evaluator that uses a different notation from Scheme's notation. It may be clearer if we show an interaction with an imaginary version of <CODE>functions</CODE> that <EM>does</EM> use Scheme notation: <P><PRE>Function: first Non-Automatically-Quoted-Argument: 'datum The result is: D Function: first Non-Automatically-Quoted-Argument: datum ERROR: THE VARIABLE DATUM IS UNBOUND. </PRE> <P>We didn't want to raise the issue of quoting at that early point in the book, so we wrote <CODE>functions</CODE> so that <EM>every</EM> argument is automatically quoted. Well, if that's the case, it's true even when we're invoking <CODE>every</CODE>. If you say <P><PRE>Function: every Argument: first &hellip;</PRE> <P>then by the rules of the <CODE>functions</CODE> program, that argument is the quoted word <CODE>first</CODE>. So <CODE>named-every</CODE>, the procedure that pretends to be <CODE>every</CODE> in the <CODE>functions</CODE> world, has to &quot;un-quote&quot; that argument by looking up the corresponding procedure. <P><H2>More on Higher-Order Functions</H2> <P>One of the higher-order functions that you can use in the <CODE>functions</CODE> program is called <CODE>number-of-arguments</CODE>. It takes a procedure (actually the name of a procedure, as we've just been saying) as argument and returns the number of arguments that that procedure accepts. This example is unusual because there's no such function in Scheme. (It would be complicated to define, for one thing, because some Scheme procedures can accept a variable number of arguments. What should <CODE>number-of-arguments</CODE> return for such a procedure?) <P>The implementation of <CODE>number-of-arguments</CODE> makes use of the same a-list of functions that the <CODE>functions</CODE> evaluator itself uses. Since the <CODE>functions</CODE> program needs to know the number of arguments for every procedure anyway, it's hardly any extra effort to make that information available to the user. We just add an entry to the a-list: <P><PRE>(list '<A NAME="g13"></A>number-of-arguments arg-count 1 valid-fn-name?) </PRE> <P>The type predicate merely has to check that the argument is found in the a-list of functions: <P><PRE>(define (<A NAME="g14"></A>valid-fn-name? name) (assoc name *the-functions*)) </PRE> <P>The type checking for the arguments to <CODE>every</CODE> and <CODE>keep</CODE> is unusually complicated because what's allowed as the second argument (the collection of data) depends on which function is used as the first argument. For example, it's illegal to compute <P><PRE>(every square '(think for yourself)) </PRE> <P>even though either of those two arguments would be allowable if we changed the other one: <P><PRE>&gt; (every square '(3 4 5)) (9 16 25) &gt; (every first '(think for yourself)) (T F Y) </PRE> <P>The type-checking procedures for <CODE>every</CODE> and <CODE>keep</CODE> use a common subprocedure. The one for <CODE>every</CODE> is <P><PRE>(lambda (fn stuff) (hof-types-ok? fn stuff word-or-sent?)) </PRE> <P>and the one for <CODE>keep</CODE> is <P><PRE>(lambda (fn stuff) (hof-types-ok? fn stuff boolean?)) </PRE> <P>The third argument specifies what types of results <CODE>fn</CODE> must return when applied to the elements of <CODE>stuff</CODE>. <P><PRE>(define (hof-types-ok? fn-name stuff range-predicate) (and (valid-fn-name? fn-name) (= 1 (arg-count fn-name)) (word-or-sent? stuff) (empty? (keep (lambda (element) (not ((type-predicate fn-name) element))) stuff)) (null? (filter (lambda (element) (not (range-predicate element))) (map (scheme-procedure fn-name) (every (lambda (x) x) stuff)))))) </PRE> <P>This says that the function being used as the first argument must be a one-argument function (so you can't say, for example, <CODE>every</CODE> of <CODE>word</CODE> and something); also, <EM>each element</EM> of the second argument must be an acceptable argument to that function. (If you <CODE>keep</CODE> the unacceptable arguments, you get nothing.) Finally, each invocation of the given function on an element of <CODE>stuff</CODE> must return an object of the appropriate type: words or sentences for <CODE>every</CODE>, true or false for <CODE>keep</CODE>.<A NAME="text7" HREF="functions-implement.html#ft7">[7]</A> <P><H2>More Robustness</H2> <P>The program we've shown you so far works fine, as long as the user never makes a mistake. Because this program was written for absolute novices, we wanted to bend over backward to catch any kind of strange input they might give us. <P>Using <CODE>read</CODE> to accept user input has a number of disadvantages: <P><P><TABLE><TR><TH align="right" valign="top">&bull;<TD>&nbsp;&nbsp;&nbsp;&nbsp;<TD valign="top">If the user enters an empty line, <CODE>read</CODE> continues waiting silently for input. </TABLE><TABLE><TR><TH align="right" valign="top">&bull;<TD>&nbsp;&nbsp;&nbsp;&nbsp;<TD valign="top">If the user types an unmatched open parenthesis, <CODE>read</CODE> continues reading forever. </TABLE><TABLE><TR><TH align="right" valign="top">&bull;<TD>&nbsp;&nbsp;&nbsp;&nbsp;<TD valign="top">If the user types two expressions on a line, the second one will be taken as a response to the question the <CODE>functions</CODE> program hasn't asked yet. </TABLE><P> We solve all these problems by using <CODE>read-line</CODE> to read exactly one line, even if it's empty or ill-formed, and then checking explicitly for possible errors. <P><CODE>Read-line</CODE> treats parentheses no differently from any other character. That's an advantage if the user enters mismatched or inappropriately nested parentheses. However, if the user correctly enters a sentence as an argument to some function, <CODE>read-line</CODE> will include the initial open parenthesis as the first character of the first word, and the final close parenthesis as the last character of the last word. <CODE>Get-arg</CODE> must correct for these extra characters. <P>Similarly, <CODE>read-line</CODE> treats number signs (<CODE>#</CODE>) like any other character, so it doesn't recognize <CODE>#t</CODE> and <CODE>#f</CODE> as special values. Instead it reads them as the strings <CODE>&quot;#t&quot;</CODE> and <CODE>&quot;#f&quot;</CODE>. <CODE>Get-arg</CODE> calls <CODE>booleanize</CODE> to convert those strings into Boolean values. <P><PRE>(define (<A NAME="g15"></A>get-arg) (display &quot;Argument: &quot;) (let ((line (read-line))) (cond ((empty? line) (show &quot;Please type an argument!&quot;) (get-arg)) ((and (equal? &quot;(&quot; (first (first line))) (equal? &quot;)&quot; (last (last line)))) (let ((sent (remove-first-paren (remove-last-paren line)))) (if (any-parens? sent) (begin (show &quot;Sentences can't have parentheses inside.&quot;) (get-arg)) (map booleanize sent)))) ((any-parens? line) (show &quot;Bad parentheses&quot;) (get-arg)) ((empty? (bf line)) (booleanize (first line))) (else (show &quot;You typed more than one argument! Try again.&quot;) (get-arg))))) </PRE> <P><CODE>Get-arg</CODE> invokes <CODE>any-parens?</CODE>, <CODE>remove-first-paren</CODE>, <CODE>remove-last-paren</CODE>, and <CODE>booleanize</CODE>, whose meanings should be obvious from their names. You can look up their definitions in the complete listing at the end of this chapter. <P><CODE>Get-fn</CODE> is simpler than <CODE>get-arg</CODE>, because there's no issue about parentheses, but it's still much more complicated than the original version, because of error checking. <P> <PRE>(define (<A NAME="g16"></A>get-fn) (display &quot;Function: &quot;) (let ((line (read-line))) (cond ((empty? line) (show &quot;Please type a function!&quot;) (get-fn)) ((not (= (count line) 1)) (show &quot;You typed more than one thing! Try again.&quot;) (get-fn)) ((not (valid-fn-name? (first line))) (show &quot;Sorry, that's not a function.&quot;) (get-fn)) (else (first line))))) </PRE> <P>This version of <CODE>get-fn</CODE> uses <CODE>valid-fn-name?</CODE> (which you've already seen) to ensure that what the user types is the name of a function we know about. <P>There's a problem with using <CODE>read-line</CODE>. As we mentioned in a pitfall in Chapter 20, reading some input with <CODE>read</CODE> and then reading the next input with <CODE>read-line</CODE> results in <CODE>read-line</CODE> returning an empty line left over by <CODE>read</CODE>. Although the <CODE>functions</CODE> program doesn't use <CODE>read</CODE>, Scheme itself used <CODE>read</CODE> to read the <CODE>(functions)</CODE> expression that started the program. Therefore, <CODE>get-fn</CODE>'s first attempt to read a function name will see an empty line. To fix this problem, the <CODE>functions</CODE> procedure has an extra invocation of <CODE>read-line</CODE>: <P><PRE>(define (functions) (read-line) (show &quot;Welcome to the FUNCTIONS program.&quot;) (functions-loop)) </PRE> <P> <H2>Complete Program Listing</H2> <P><P><P><PRE> ;;; The functions program (define (functions) ;; (read-line) (show "Welcome to the FUNCTIONS program.") (functions-loop)) (define (functions-loop) (let ((fn-name (get-fn))) (if (equal? fn-name 'exit) "Thanks for using FUNCTIONS!" (let ((args (get-args (arg-count fn-name)))) (if (not (in-domain? args fn-name)) (show "Argument(s) not in domain.") (show-answer (apply (scheme-function fn-name) args))) (functions-loop))))) (define (get-fn) (display "Function: ") (let ((line (read-line))) (cond ((empty? line) (show "Please type a function!") (get-fn)) ((not (= (count line) 1)) (show "You typed more than one thing! Try again.") (get-fn)) ((not (valid-fn-name? (first line))) (show "Sorry, that's not a function.") (get-fn)) (else (first line))))) (define (get-arg) (display "Argument: ") (let ((line (read-line))) (cond ((empty? line) (show "Please type an argument!") (get-arg)) ((and (equal? "(" (first (first line))) (equal? ")" (last (last line)))) (let ((sent (remove-first-paren (remove-last-paren line)))) (if (any-parens? sent) (begin (show "Sentences can't have parentheses inside.") (get-arg)) (map booleanize sent)))) ((any-parens? line) (show "Bad parentheses") (get-arg)) ((empty? (bf line)) (booleanize (first line))) (else (show "You typed more than one argument! Try again.") (get-arg))))) (define (get-args n) (if (= n 0) '() (let ((first (get-arg))) (cons first (get-args (- n 1)))))) (define (any-parens? line) (let ((letters (accumulate word line))) (or (member? "(" letters) (member? ")" letters)))) (define (remove-first-paren line) (if (equal? (first line) "(") (bf line) (se (bf (first line)) (bf line)))) (define (remove-last-paren line) (if (equal? (last line) ")") (bl line) (se (bl line) (bl (last line))))) (define (booleanize x) (cond ((equal? x "#t") #t) ((equal? x "#f") #f) (else x))) (define (show-answer answer) (newline) (display "The result is: ") (if (not answer) (show "#F") (show answer)) (newline)) (define (scheme-function fn-name) (cadr (assoc fn-name *the-functions*))) (define (arg-count fn-name) (caddr (assoc fn-name *the-functions*))) (define (type-predicate fn-name) (cadddr (assoc fn-name *the-functions*))) (define (in-domain? args fn-name) (apply (type-predicate fn-name) args)) ;; Type predicates (define (word-or-sent? x) (or (word? x) (sentence? x))) (define (not-empty? x) (and (word-or-sent? x) (not (empty? x)))) (define (two-numbers? x y) (and (number? x) (number? y))) (define (two-reals? x y) (and (real? x) (real? y))) (define (two-integers? x y) (and (integer? x) (integer? y))) (define (can-divide? x y) (and (number? x) (number? y) (not (= y 0)))) (define (dividable-integers? x y) (and (two-integers? x y) (not (= y 0)))) (define (trig-range? x) (and (number? x) (<= (abs x) 1))) (define (hof-types-ok? fn-name stuff range-predicate) (and (valid-fn-name? fn-name) (= 1 (arg-count fn-name)) (word-or-sent? stuff) (empty? (keep (lambda (element) (not ((type-predicate fn-name) element))) stuff)) (null? (filter (lambda (element) (not (range-predicate element))) (map (scheme-function fn-name) (every (lambda (x) x) stuff)))))) (define (member-types-ok? small big) (and (word? small) (or (sentence? big) (and (word? big) (= (count small) 1))))) ;; Names of functions as functions (define (named-every fn-name list) (every (scheme-function fn-name) list)) (define (named-keep fn-name list) (keep (scheme-function fn-name) list)) (define (valid-fn-name? name) (assoc name *the-functions*)) ;; The list itself (define *the-functions* (list (list '* * 2 two-numbers?) (list '+ + 2 two-numbers?) (list '- - 2 two-numbers?) (list '/ / 2 can-divide?) (list '< < 2 two-reals?) (list '<= <= 2 two-reals?) (list '= = 2 two-numbers?) (list '> > 2 two-reals?) (list '>= >= 2 two-reals?) (list 'abs abs 1 real?) (list 'acos acos 1 trig-range?) (list 'and (lambda (x y) (and x y)) 2 (lambda (x y) (and (boolean? x) (boolean? y)))) (list 'appearances appearances 2 member-types-ok?) (list 'asin asin 1 trig-range?) (list 'atan atan 1 number?) (list 'bf bf 1 not-empty?) (list 'bl bl 1 not-empty?) (list 'butfirst butfirst 1 not-empty?) (list 'butlast butlast 1 not-empty?) (list 'ceiling ceiling 1 real?) (list 'cos cos 1 number?) (list 'count count 1 word-or-sent?) (list 'equal? equal? 2 (lambda (x y) #t)) (list 'even? even? 1 integer?) (list 'every named-every 2 (lambda (fn stuff) (hof-types-ok? fn stuff word-or-sent?))) (list 'exit '() 0 '()) ; in case user applies number-of-arguments to exit (list 'exp exp 1 number?) (list 'expt expt 2 (lambda (x y) (and (number? x) (number? y) (or (not (real? x)) (>= x 0) (integer? y))))) (list 'first first 1 not-empty?) (list 'floor floor 1 real?) (list 'gcd gcd 2 two-integers?) (list 'if (lambda (pred yes no) (if pred yes no)) 3 (lambda (pred yes no) (boolean? pred))) (list 'item item 2 (lambda (n stuff) (and (integer? n) (> n 0) (word-or-sent? stuff) (<= n (count stuff))))) (list 'keep named-keep 2 (lambda (fn stuff) (hof-types-ok? fn stuff boolean?))) (list 'last last 1 not-empty?) (list 'lcm lcm 2 two-integers?) (list 'log log 1 (lambda (x) (and (number? x) (not (= x 0))))) (list 'max max 2 two-reals?) (list 'member? member? 2 member-types-ok?) (list 'min min 2 two-reals?) (list 'modulo modulo 2 dividable-integers?) (list 'not not 1 boolean?) (list 'number-of-arguments arg-count 1 valid-fn-name?) (list 'odd? odd? 1 integer?) (list 'or (lambda (x y) (or x y)) 2 (lambda (x y) (and (boolean? x) (boolean? y)))) (list 'quotient quotient 2 dividable-integers?) (list 'random random 1 (lambda (x) (and (integer? x) (> x 0)))) (list 'remainder remainder 2 dividable-integers?) (list 'round round 1 real?) (list 'se se 2 (lambda (x y) (and (word-or-sent? x) (word-or-sent? y)))) (list 'sentence sentence 2 (lambda (x y) (and (word-or-sent? x) (word-or-sent? y)))) (list 'sentence? sentence? 1 (lambda (x) #t)) (list 'sin sin 1 number?) (list 'sqrt sqrt 1 (lambda (x) (and (real? x) (>= x 0)))) (list 'tan tan 1 number?) (list 'truncate truncate 1 real?) (list 'vowel? (lambda (x) (member? x '(a e i o u))) 1 (lambda (x) #t)) (list 'word word 2 (lambda (x y) (and (word? x) (word? y)))) (list 'word? word? 1 (lambda (x) #t)))) </PRE><P> <P><H2>Exercises</H2> <P><B>21.1</B>&nbsp;&nbsp;The <CODE>get-args</CODE> procedure has a <CODE>let</CODE> that creates the variable <CODE>first</CODE>, and then that variable is used only once inside the body of the <CODE>let</CODE>. Why doesn't it just say the following? <P><PRE>(define (get-args n) (if (= n 0) '() (cons (get-arg) (get-args (- n 1))))) </PRE> <P> <B>21.2</B>&nbsp;&nbsp;The domain-checking function for <CODE>equal?</CODE> is <P><PRE>(lambda (x y) #t) </PRE> <P>This seems silly; it's a function of two arguments that ignores both arguments and always returns <CODE>#t</CODE>. Since we know ahead of time that the answer is <CODE>#t</CODE>, why won't it work to have <CODE>equal?</CODE>'s entry in the a-list be <P><PRE>(list 'equal? equal? 2 #t) </PRE> <B>21.3</B>&nbsp;&nbsp;Every time we want to know something about a function that the user typed in, such as its number of arguments or its domain-checking predicate, we have to do an <CODE>assoc</CODE> in <CODE>*the-functions*</CODE>. That's inefficient. Instead, rewrite the program so that <CODE>get-fn</CODE> returns a function's entry from the a-list, instead of just its name. Then rename the variable <CODE>fn-name</CODE> to <CODE>fn-entry</CODE> in the <CODE>functions-loop</CODE> procedure, and rewrite the selectors <CODE>scheme-procedure</CODE>, <CODE>arg-count</CODE>, and so on, so that they don't invoke <CODE>assoc</CODE>. <P> <B>21.4</B>&nbsp;&nbsp;Currently, the program always gives the message &quot;argument(s) not in domain&quot; when you try to apply a function to bad arguments. Modify the program so that each record in <CODE>*the-functions*</CODE> also contains a specific out-of-domain message like &quot;both arguments must be numbers,&quot; then modify <CODE>functions</CODE> to look up and print this error message along with &quot;argument(s) not in domain.&quot; <P> <B>21.5</B>&nbsp;&nbsp;Modify the program so that it prompts for the arguments this way: <P><PRE>Function: if First Argument: #t Second Argument: paperback Third Argument: writer The result is: PAPERBACK </PRE> <P>but if there's only one argument, the program shouldn't say <CODE>First</CODE>: <P><PRE>Function: sqrt Argument: 36 The result is 6 </PRE> <P> <B>21.6</B>&nbsp;&nbsp;The <CODE>assoc</CODE> procedure might return <CODE>#f</CODE> instead of an a-list record. How come it's okay for <CODE>arg-count</CODE> to take the <CODE>caddr</CODE> of <CODE>assoc</CODE>'s return value if <CODE>(caddr #f)</CODE> is an error? <P> <B>21.7</B>&nbsp;&nbsp;Why is the domain-checking predicate for the <CODE>word?</CODE> function <P><PRE>(lambda (x) #t) </PRE> <P>instead of the following procedure? <P><PRE>(lambda (x) (word? x)) </PRE> <P> <B>21.8</B>&nbsp;&nbsp;What is the value of the following Scheme expression? <P><PRE>(functions) </PRE> <P> <P> <B>21.9</B>&nbsp;&nbsp;We said in the recursion chapters that every recursive procedure has to have a base case and a recursive case, and that the recursive case has to somehow reduce the size of the problem, getting closer to the base case. How does the recursive call in <CODE>get-fn</CODE> reduce the size of the problem? <P> <HR> <A NAME="ft1" HREF="functions-implement.html#text1">[1]</A> Some Scheme procedures can accept any number of arguments, but for the purposes of the <CODE>functions</CODE> program we restrict these procedures to their most usual case, such as two arguments for <CODE>+</CODE>.<P> <A NAME="ft2" HREF="functions-implement.html#text2">[2]</A> Scheme would complain all by itself, of course, but would then stop running the <CODE>functions</CODE> program. We want to catch the error before Scheme does, so that after seeing the error message you're still in <CODE>functions</CODE>. As we mentioned in Chapter 19, a program meant for beginners, such as the readers of Chapter 2, should be especially robust.<P> <A NAME="ft3" HREF="functions-implement.html#text3">[3]</A> Since <CODE>and</CODE> is a special form, we can't just say <P><PRE>(list 'and and 2 (lambda (x y) (and (boolean? x) (boolean? y)))) </PRE> <P>That's because special forms can't be elements of lists. Instead, we have to create a normal procedure that can be put in a list but computes the same function as <CODE>and</CODE>: <P><PRE>(lambda (x y) (and x y)) </PRE> <P>We can get away with this because in the <CODE>functions</CODE> program we don't care about argument evaluation, so it doesn't matter that <CODE>and</CODE> is a special form. We do the same thing for <CODE>if</CODE> and <CODE>or</CODE>.<P> <A NAME="ft4" HREF="functions-implement.html#text4">[4]</A> The domain of a procedure is a set, and sets are generally represented in programs as lists. You might think that we'd have to store, for example, a list of all the legal arguments to <CODE>butfirst</CODE>. But that would be impossible, since that list would have to be infinitely large. Instead, we can take advantage of the fact that the only use we make of this set is membership testing, that is, finding out whether a particular argument is in a function's domain.<P> <A NAME="ft5" HREF="functions-implement.html#text5">[5]</A> Why did we choose to restrict the domain? We were trying to make the point that invoking a procedure makes sense only with appropriate arguments; that point is obscured by the complicating fact that Scheme interprets any non-<CODE>#f</CODE> value as true. In the <CODE>functions</CODE> program, where composition of functions is not allowed, there's no benefit to Scheme's more permissive rule.<P> <A NAME="ft6" HREF="functions-implement.html#text6">[6]</A> A reason that we restricted the domains of some mathematical functions is to protect ourselves from the fact that some version of Scheme support complex numbers while others do not. We wanted to write one version of <CODE>functions</CODE> that would work in either case; sometimes the easiest way to avoid possible problems was to restrict some function's domain.<P> <A NAME="ft7" HREF="functions-implement.html#text7">[7]</A> That last argument to <CODE>and</CODE> is complicated. The reason we use <CODE>map</CODE> instead of <CODE>every</CODE> is that the results of the invocations of <CODE>fn</CODE> might not be words or sentences, so <CODE>every</CODE> wouldn't accept them. But <CODE>map</CODE> has its own limitation: It won't accept a word as the <CODE>stuff</CODE> argument. So we use <CODE>every</CODE> to turn <CODE>stuff</CODE> into a sentence&mdash;which, as you know, is really a list&mdash;and that's guaranteed to be acceptable to <CODE>map</CODE>. (This is an example of a situation in which respecting a data abstraction would be too horrible to contemplate.)<P> <P><A HREF="../ss-toc2.html">(back to Table of Contents)</A><P> <A HREF="../ssch20/io.html"><STRONG>BACK</STRONG></A> chapter thread <A HREF="../ssch22/files.html"><STRONG>NEXT</STRONG></A> <P> <ADDRESS> <A HREF="../index.html">Brian Harvey</A>, <CODE>bh@cs.berkeley.edu</CODE> </ADDRESS> </BODY> </HTML>