diff options
| -rw-r--r-- | final_project/paper/bnewbold_lch_report_draft.lyx | 2159 | ||||
| -rw-r--r-- | final_project/paper/outline | 25 | ||||
| -rw-r--r-- | final_project/work/Makefile | 43 | ||||
| -rw-r--r-- | final_project/work/discovery-examples.scm | 58 | ||||
| -rw-r--r-- | final_project/work/generic-string-opers.scm | 46 | ||||
| -rw-r--r-- | final_project/work/ghelper.scm | 6 | ||||
| -rw-r--r-- | final_project/work/hello.scm | 27 | ||||
| -rw-r--r-- | final_project/work/numerolgist.scm | 46 | ||||
| -rw-r--r-- | final_project/work/prhello-const.c | 50 | ||||
| -rw-r--r-- | final_project/work/prhello-shim.c | 829 | ||||
| -rw-r--r-- | final_project/work/prhello-types.bin | bin | 0 -> 5864 bytes | |||
| -rw-r--r-- | final_project/work/prhello.cdecl | 115 | ||||
| -rw-r--r-- | final_project/work/prhello.scm | 77 |
13 files changed, 2930 insertions, 551 deletions
diff --git a/final_project/paper/bnewbold_lch_report_draft.lyx b/final_project/paper/bnewbold_lch_report_draft.lyx index d141996..c7f39b4 100644 --- a/final_project/paper/bnewbold_lch_report_draft.lyx +++ b/final_project/paper/bnewbold_lch_report_draft.lyx @@ -31,7 +31,11 @@ \begin_body \begin_layout Title -Generic Operator Discovery +Generic Operator Discovery: +\newline + +\emph on +10,000 Monkeys with 10,000 Lambdas \end_layout \begin_layout Date @@ -48,13 +52,14 @@ Laura Harris and Bryan Newbold for 6.945 \end_layout \begin_layout Abstract -We present a hardware design to convert captured images to an audio stream. - There are a wealth of real time -\emph on -software -\emph default - implementations of the Fast Fourier Transform (FFT), but we use a Field - Programable Gate Array +We have implemented a simple system which enables the discovery and exploration + of generic operators and brute force predicate satisfaction. + Our procedures build on top of existing predicate-based operator dispatch + databases; this allows existing code to be reused in useful and unexpected + ways. + In this write up we describe our code, give a few simple demonstrations + (including one with a native graphic user interface), and mention some + potential applications. \end_layout \begin_layout Standard @@ -66,663 +71,556 @@ software \end_layout \begin_layout Section -Overview +Generic Operator Discovery System \end_layout \begin_layout Standard -The Real-Time Audio Composition system allows for the conversion of visually - encoded information into audio. - A typical visual encoding program, such as Baudline, takes audio input - and produces a scrolling visualization of the fast-Fourier transform (FFT). - Our system could take one of these visualizations and produce ch serve - as the visual spectrograph to interpreted and played back through headphones - or speakers. - A PS/2 mouse allows for control of the GUI system. - Using the mouse, the user can interact with the buttons, the image itself, - and a number of other features. - An image of the GUI is shown in Figure -\begin_inset LatexCommand \ref{fig:gui_photo} +The normal purpose of a generic operator dispatch system is to allow the + programmer or user to use a single operator with many different object + types or combinations of object types. + Mature libraries and codebases may have dozens of generic operators defined + for domain-specific data structures; these generic operations often represent + the core functionality offered by the system. + For large systems, those with which the user is unfamiliar, or those with + poor documentation, it can be daunting to find the operation desired. + By using +\begin_inset Quotes eld +\end_inset +operator discovery +\begin_inset Quotes erd \end_inset -. -\begin_inset Float figure -wide false -sideways false -status collapsed + techniques, the operator dispatch system can be reverse engineered to find + all of the generic operations which can be applied to given arguments. + In addition to facilitating user exploration, these techniques can be used + to improve the robustness of computing systems, as part of automated problem + solving, as a testing tool, and for the automated generation of higher + level programs. +\end_layout \begin_layout Standard -\begin_inset Graphics - filename gui_photo.jpg - display none - width 5in - keepAspectRatio +The generic operator system we have built upon uses predicate dispatch; + for an overview of this strategy see [TODO: cite]. + The version we used for MIT/GNU Scheme was distributed by the 6.945 staff + and is included in the appendix as +\family typewriter +ghelper.scm +\family default +. + The exact same dispatch system is used in the scmutils classical mechanics + software package, which allowed us to experiment with an existing software + system. +\end_layout -\end_inset +\begin_layout Section +Implementation +\end_layout +\begin_layout Standard +For examples and demonstrations of the system, see the applications section + and the file +\family typewriter +discovery-examples.scm +\family default + in the appendix. +\end_layout +\begin_layout Subsection +Review of Predicate Dispatch \end_layout -\begin_layout Caption -A photograph of the GUI implemented in the Real Time Audio Composition system. - Each area of the screen will be explained in detail. +\begin_layout Standard +Predicate dispatch works by choosing the first \emph on - -\newline -(Source: Team Member) +handler \emph default + whose associated +\emph on +predicates +\emph default + all return true for a given set of arguments; a list of predicate/handler + pairs is stored in a tree structure for each generic operator. +\end_layout -\begin_inset LatexCommand \label{fig:gui_photo} - -\end_inset - +\begin_layout Standard +A few crucial procedures, globals, and data structures are defined in +\family typewriter +ghelper.scm: +\end_layout +\begin_layout Paragraph* +*generic-operator-table* \end_layout +\begin_layout Standard +This is the global table of generic operators. + It is an +\family typewriter +eq-hash +\family default + table which associates operator record +\emph on +keys +\emph default + (which define the arity) with predicate/handler tree +\emph on +values +\emph default +. + In addition, for +\begin_inset Quotes eld \end_inset +named +\begin_inset Quotes erd +\end_inset + operators, the symbol representing an operator is added as a second +\emph on +key +\emph default + pointing at the same predicate/handler tree +\emph on +value +\emph default +. + \end_layout -\begin_layout Standard -The GUI allows for a number of functions. - An edit function, regrettably never fully implemented due to time constraints, - would allow for the direct editing of captured images by manually selecting - an eight bit binary lved with the time domain audio data to produce the - audio signal. - The AC97 audio chip in the FPGA runs at a clock speed of 48kHz so the audio - samples must also be up-sampled to produce the final signal. +\begin_layout Paragraph* +(make-generic-operator arity default-operation #!optional name) \end_layout \begin_layout Standard -t vector with at least 1024 bins is required. - Aliever, a full wrapper module was necessary to load samples in and out - of the module, enable and disable processing, ensure sample index synchronizati -on, etc. - The ifft_wrapper module ensures that only the 12-bit real components are - written and that both the 8-bit phase and 12-bit complex components are - tied to 0 at input and ignored at output. -\end_layout - -\begin_layout Standard -\align center -\begin_inset Float table -placement h -wide false -sideways false -status collapsed - -\begin_layout Standard -\align center -\begin_inset Tabular -<lyxtabular version="3" rows="8" columns="2"> -<features> -<column alignment="center" valignment="top" width="0"> -<column alignment="center" valignment="top" width="0"> -<row bottomline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text - -\begin_layout Standard +This procedure creates a new record in the +\family typewriter +*generic-operator-table* +\family default + for the given arity; it returns an operator procedure which is usually + bound in the user's environment and when applied initiates the procedure + dispatch process. + If not null, the default-operation is bound (using assign-operation) as + an any-argument-accepting default handler. + If passed, the name (which should be a symbol) is bound as a redundant + key in the +\family typewriter +*generic-operator-table* +\family default +. -\family roman \series bold -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Setting + defhandler +\series default + is an alias for make-generic-operator. \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Paragraph* +(assign-operation operator handler . + argument-predicates) +\end_layout \begin_layout Standard - -\family roman -\series bold -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Value +This procedure adds a new predicate/handler pair to an operator's tree in + the *generic-operator-table*. + The binding is done with +\family typewriter +bind-in-tree +\family default + (see below). \end_layout -\end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text +\begin_layout Paragraph* +(bind-in-tree keys handler tree) +\end_layout \begin_layout Standard - -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Generator Version +This procedure simply adds a new handler (with the argument predicates +\emph on +keys +\emph default +) in a given generic operator's dispatch +\emph on +tree +\emph default +. + \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Subsection +Procedures +\end_layout \begin_layout Standard - -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none - Fast Fourier Transform 3.2 +The actual implementations of these procedures can be found in the appendix. \end_layout -\end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text +\begin_layout Subsubsection* +(discover:opers-for . + args) +\end_layout \begin_layout Standard - -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Input Length +This procedure returns all of the operators which can be applied to the + arguments. + The return value is a list of the keys from *generic-operator-table* which + are associated with predicate/handler trees matching the arguments. + This is the core of the discovery system. \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Subsubsection* +(discover:named-opers-for . + args) +\end_layout \begin_layout Standard +This procedure is the same as discover:opers-for except that it only returns + lookup keys which are symbols (thus the original operator record was defined + with a name symbol). + +\end_layout -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -2048 samples +\begin_layout Paragraph* +(discover:named-opers) \end_layout +\begin_layout Standard +This procedure returns a list of +\emph on +all +\emph default + the +\begin_inset Quotes eld \end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text -\begin_layout Standard +named +\begin_inset Quotes erd +\end_inset -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Processing Mode + generic operators in the +\family typewriter +*generic-operator-table* +\family default + ; it is useful to determine the size of scope of an unknown software system. \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Paragraph* +(discover:apply-name name . + args) +\end_layout \begin_layout Standard +This procedure allows +\begin_inset Quotes eld +\end_inset -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Pipelined +named +\begin_inset Quotes erd +\end_inset + + operator symbols to be treated like actual operator procedures: it initiates + the dispatch process for the predicate/handler tree associated with +\emph on +name +\emph default + for the given +\emph on +args +\emph default +. + \end_layout -\end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text +\begin_layout Paragraph* +(discover:apply-all . + args) +\end_layout \begin_layout Standard +This procedure finds all of the operators which can act on the given args, + then returns a list with the results of applying each of these operators. +\end_layout -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Sample bitwidth +\begin_layout Paragraph* +(discover:apply-all-name . + args) \end_layout +\begin_layout Standard +This is identical to +\family typewriter +discover:apply-all +\family default + except that it only applies +\begin_inset Quotes eld \end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text -\begin_layout Standard +named +\begin_inset Quotes erd +\end_inset -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -12-bit signed + operators. + \end_layout -\end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text +\begin_layout Paragraph* +(discover:satisfy pred? . + args) +\end_layout \begin_layout Standard - -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Output ordering +This procedure attempts to satisfy the given predicate by repeatedly applying + all possible operators the arguments (and the return values of these applicatio +ns recursively). + It operates as a breadth first search and returns the first matching return + value. \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Paragraph* +(discover:satisfy-sequence pred? . + args) +\end_layout \begin_layout Standard +This procedure is similar to +\family typewriter +discover:satisfy +\family default + except that it only applies +\begin_inset Quotes eld +\end_inset -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Natural -\end_layout +named +\begin_inset Quotes erd +\end_inset + operators and it maintains a record of which operators were applied to + obtain a given return value; it will also return all of the matching return + values for a given +\begin_inset Quotes eld \end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text -\begin_layout Standard +depth +\begin_inset Quotes erd +\end_inset -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Clock enable pin + of search. \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Subsection +Room for improvement +\end_layout \begin_layout Standard - -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Enabled +The code for all of these procedures is rather ugly and complicated due + to the crude data structures used: for example discover:satisfy-sequence + has an internal variable to store potential solutions as a list with the + first argument being a list of arguments (always a single element after + the first application of operators) and all subsequent operators being + a record of the operators applied to obtain those arguments. + This could almost certainly be reimplemented in a more elegant functional + style. \end_layout -\end_inset -</cell> -</row> -<row topline="true"> -<cell alignment="center" valignment="top" topline="true" leftline="true" usebox="none"> -\begin_inset Text +\begin_layout Standard +The predicate/handler tree format does not currently include a name symbol + for the given operator. + Perhaps the name symbol could also be determined by searching the environment + bindings, but this does not seem like a great idea (search would be slow?). +\end_layout \begin_layout Standard +Almost all of the implementations are ripe for trivial optimization: for + example +\family typewriter +discover:named-opers-for +\family default + just filters the results of +\family typewriter +discover:opers-for +\family default +; it could be much more efficient if it filtered out non-symbol operators + earlier in the search process. +\end_layout -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -Processing Stages +\begin_layout Section +Applications \end_layout -\end_inset -</cell> -<cell alignment="center" valignment="top" topline="true" leftline="true" rightline="true" usebox="none"> -\begin_inset Text +\begin_layout Subsection +scmutils Package +\end_layout \begin_layout Standard - -\family roman -\series medium -\shape up -\size normal -\emph off -\bar no -\noun off -\color none -3 using BRAM +hold \end_layout -\end_inset -</cell> -</row> -</lyxtabular> +\begin_layout Quotation -\end_inset +\family typewriter +(discover:named-opers) +\end_layout +\begin_layout Quotation +\family typewriter +;Value: (+ one-like cos dot-product expt one? * gcd \end_layout -\begin_layout Caption -IFFT Auto-generation Settings -\begin_inset LatexCommand \label{tab:ifft_settings} +\begin_layout Quotation -\end_inset +\family typewriter +partial-derivative acos exp atan2 cosh imag-part one = conjugate +\end_layout +\begin_layout Quotation +\family typewriter +zero? / zero-like abs sinh identity? sin asin derivative angle \end_layout -\end_inset +\begin_layout Quotation +\family typewriter +magnitude inexact? type apply identity make-polar arity real-part - +\end_layout + +\begin_layout Quotation +\family typewriter +invert negate identity-like trace determinant sqrt zero log square \end_layout -\begin_layout Standard -onversion is implemented by using each time-domain sample twice, then low - pass filtering the output to remove the high frequency artifacts introduced. - This low pass filter also conveniently filters out any noise or aliasing - occurring in the frequencies above the 720 or so lowest frequencies actually - specified by image data. - Note that the up-sampling process also effectively halves the frequency - corresponding to each bin in our frequency-domain spectral vectors, giving - better frequency resolution in the lower, more human discernible regime. +\begin_layout Quotation + +\family typewriter +make-rectangular type-predicate atan1) \end_layout \begin_layout Standard -The low pass filter is implemented almost exactly like in Lab 3, using 31 - tap filters generated in matlab using the command: +hold \end_layout -\begin_layout Verse +\begin_layout Quotation \family typewriter -round(fir1(30,.5)*(2^13)) +(discover:named-opers-for \end_layout -\begin_layout Standard -Each tap is 14-bits signed, thus the scaling by -\begin_inset Formula $2^{13}$ -\end_inset +\begin_layout Quotation -. - The parameter -\begin_inset Formula $W_{n}=0.5$ -\end_inset +\family typewriter +\InsetSpace ~ +\InsetSpace ~ +\InsetSpace ~ +(matrix-by-rows '(1 0 0) '(0 1 0) '(0 0 1))) +\end_layout + +\begin_layout Quotation - specifies a cutoff frequency +\family typewriter +;Value: (one-like cos exp conjugate zero? zero-like identity? sin \end_layout -\begin_layout Standard -entire packet length is filled (128 values in our case), the IFFT is computed. - Natural order refers to the ordering of bits on the output. - Reverse ordering of bits is the natural mode of the IFFT, and since timing - is not a huge concern at this stage, producing natural order bits is worth - the time. - The different stages of the IFFT input and output are controlled by an - FSM as shown in Figure +\begin_layout Quotation + +\family typewriter +inexact? type arity invert negate identity-like trace determinant \end_layout -\begin_layout Standard -Unless just reset, at which the FSM is immediately clock enabled and put - in the setup state so the time domain taps can be initialized, the FSM - naturally idles in the wait state. - With the edge detection of a button press release within the bode plot, - the FSM enters the setup state since it can be assumed that a value within - the bode plot has changed. - As soon as the ready for data flag is set high, the FSM enters the write - state. - The values from the bode array are fed into the IFFT, lagging behind three - cycles as designated by the datasheet. - After all data has been entered, the FSM enters the read state. - The resulting tap indices and values are completely synchronous at this - point and can be fed directly into the tap manager which will hold the - resultant values. +\begin_layout Quotation + +\family typewriter +type-predicate) \end_layout \begin_layout Standard -Memory Management +hold \end_layout -\begin_layout Address +\begin_layout Quotation -\emph on -Author: Dimitri Turbiner +\family typewriter +(discover:named-opers-for 'a) \end_layout -\begin_layout Standard -The memory control module uses four interface modules to communicate with - the Camera, GUI, and IFFT subsystems and two interface modules to control - the physical SRAM chips on the LabKit. - The camera_to_zbt interface module, keeps track of the sync signals coming - from the Camera subsystem in order to compute the memory destination address. - Incomming pixels are buffered and packed together into groups of four. - When such a group of four is ready, the memory controller is signalled - by camera_we. - The input signals are all synchronized to the clock in the Camera subsystem - -- 27mHz, while the output signals have to be synchronized at the memory - clock -- 65mHz. - Thus, the camera_to_zbt module has to perform clock resynchronization between - the two subsystems it connects. - The zbt_to_display, zbt_to_ifft, edit_to_zbt, modules all compute the memory - destination address based on the requested pixel horizontal and vertical - index (hcount and vcount), and when signalled by the memory controller - that data is valid, pack or unpack four 8bit pixels to/from the 36 bit - data bus. - +\begin_layout Quotation + +\family typewriter +;Value: (one-like cos acos exp cosh imag-part conjugate zero-like \end_layout -\begin_layout Standard -The memory controller controls the two zbt ram access modules depending - on which memory IO operations have been requested by the subsystems. - The controller supports latching the various subsystem's data and address - busses in order to guarantee minimum hold delays and to resolve simultaneous - memory access requests. - The latches control logic is built around a memory access priority hierarchy: - +\begin_layout Quotation + +\family typewriter +sinh sin asin angle magnitude inexact? type arity real-part invert \end_layout \begin_layout Quotation \family typewriter -assign main_addr = camera_capture_request ? camera_addr : +negate identity-like sqrt log type-predicate atan1) +\end_layout + +\begin_layout Standard +hold \end_layout \begin_layout Quotation \family typewriter -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -(display_read_request ? display_addr : +(discover:named-opers-for (compose sin cos)) \end_layout \begin_layout Quotation \family typewriter -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -(ifft_read_request ? ifft_addr : +;Value: (one-like cos acos exp cosh imag-part zero-like abs sinh \end_layout \begin_layout Quotation \family typewriter -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -\InsetSpace ~ -(edit_write_request ? edit_addr :0))); +sin asin angle magnitude inexact? type arity real-part invert \end_layout -\begin_layout Standard -problem was also noticed after this implementation. - When the pixel itself was updated by multiplying the stored bode value - by the incoming pixel data, a great deal of scattering across the boundaries - of the image was noticed. - By pipelining the data within the clocked region, this problem was removed - and smooth fading occurred. - (Note: the unimplemented edit mode code uses only slightly different math - than the bode plot draw function, and should theoretically work, but was - never tested). +\begin_layout Quotation + +\family typewriter +negate identity-like sqrt log square type-predicate atan1) \end_layout \begin_layout Subsection -Audio Pipeline +Other Applications \end_layout -\begin_layout Standard -A number of external tools were crucial for the development and debugging - of the audio processing pipeline. - An entire separate labkit module with a parameterized dummy sample generator - replacing the camera and memory management and no GUI output. - This allowed for debugging with consistent, simple, noise free spectral - input. - This labkit module was also wired to make full use of the hex display (to - show bode tap index and both horizontal and vertical memory indexes) and - the logic analyzer connections (all 4 16-bit connectors were used!). - For instance, Figure shows the IFFT module output of a simple sine wave; - the clock-like ticks of channels above and below the sine waveform show - the request and ready signals of the various other stages of the audio - pipeline. - Note that this section of the spectral waveform shows the all zero padding - from the windowing module; the single non-zero sample_value is off screen - to the left, and the dummy ram module request/ready pins are not toggled. +\begin_layout Section +A GUI Interface \end_layout -\begin_layout Standard -A few other buttons and switches came in useful for debugging: Switch #7 - disables the regular audio output +\begin_layout Subsection +FFI \end_layout -\begin_layout Standard -Conclusion +\begin_layout Subsection +Gtk Bindings \end_layout -\begin_layout Address +\begin_layout Subsection +Procedures +\end_layout -\emph on -Author: Tyler Hutchison +\begin_layout Paragraph* +(discover:thunklist-for . + args) \end_layout \begin_layout Standard -The implementation of a real time audio composition system has been described. - Using the GUI interface, coupled with complex memory interactions, and - robust audio output, one can use visual information to encode +This is a special purpose function +\end_layout + +\begin_layout Subsection +Screenshots \end_layout \begin_layout Section @@ -740,32 +638,31 @@ ghelper.scm \end_layout \begin_layout LyX-Code -//////////////////////////////////////////////////////////////////////////////// -/ +;;; From 6.945 Staff, with minor edit by bnewbold (May 2009): \end_layout \begin_layout LyX-Code -// +;;; the optional name argument is handled in the style of \end_layout \begin_layout LyX-Code -// 6.111 FPGA Labkit -- Template Toplevel Module +;;; the scmutils implementation \end_layout \begin_layout LyX-Code -// + \end_layout \begin_layout LyX-Code -// Author: Nathan Ickes +;;;; Most General Generic-Operator Dispatch \end_layout \begin_layout LyX-Code -// + \end_layout \begin_layout LyX-Code -// Edited: Nov 4, 2008, FTW +(declare (usual-integrations)) \end_layout \begin_layout LyX-Code @@ -773,6 +670,394 @@ ghelper.scm \end_layout \begin_layout LyX-Code +;;; Generic-operator dispatch is implemented here by a discrimination +\end_layout + +\begin_layout LyX-Code +;;; list, where the arguments passed to the operator are examined by +\end_layout + +\begin_layout LyX-Code +;;; predicates that are supplied at the point of attachment of a +\end_layout + +\begin_layout LyX-Code +;;; handler (by ASSIGN-OPERATION). +\end_layout + +\begin_layout LyX-Code +;;; To be the correct branch all arguments must be accepted by +\end_layout + +\begin_layout LyX-Code +;;; the branch predicates, so this makes it necessary to +\end_layout + +\begin_layout LyX-Code +;;; backtrack to find another branch where the first argument +\end_layout + +\begin_layout LyX-Code +;;; is accepted if the second argument is rejected. + Here +\end_layout + +\begin_layout LyX-Code +;;; backtracking is implemented by OR. +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +(define (make-generic-operator arity default-operation #!optional name) +\end_layout + +\begin_layout LyX-Code + (let ((record (make-operator-record arity))) +\end_layout + +\begin_layout LyX-Code + (define (operator . + arguments) +\end_layout + +\begin_layout LyX-Code + (if (not (= (length arguments) arity)) +\end_layout + +\begin_layout LyX-Code + (error:wrong-number-of-arguments operator arity arguments)) +\end_layout + +\begin_layout LyX-Code + (let ((succeed +\end_layout + +\begin_layout LyX-Code + (lambda (handler) +\end_layout + +\begin_layout LyX-Code + (apply handler arguments)))) +\end_layout + +\begin_layout LyX-Code + (let per-arg +\end_layout + +\begin_layout LyX-Code + ((tree (operator-record-tree record)) +\end_layout + +\begin_layout LyX-Code + (args arguments) +\end_layout + +\begin_layout LyX-Code + (fail +\end_layout + +\begin_layout LyX-Code + (lambda () +\end_layout + +\begin_layout LyX-Code + (error:no-applicable-methods operator arguments)))) +\end_layout + +\begin_layout LyX-Code + (let per-pred ((tree tree) (fail fail)) +\end_layout + +\begin_layout LyX-Code + (cond ((pair? tree) +\end_layout + +\begin_layout LyX-Code + (if ((caar tree) (car args)) +\end_layout + +\begin_layout LyX-Code + (if (pair? (cdr args)) +\end_layout + +\begin_layout LyX-Code + (per-arg (cdar tree) +\end_layout + +\begin_layout LyX-Code + (cdr args) +\end_layout + +\begin_layout LyX-Code + (lambda () +\end_layout + +\begin_layout LyX-Code + (per-pred (cdr tree) fail))) +\end_layout + +\begin_layout LyX-Code + (succeed (cdar tree))) +\end_layout + +\begin_layout LyX-Code + (per-pred (cdr tree) fail))) +\end_layout + +\begin_layout LyX-Code + ((null? tree) +\end_layout + +\begin_layout LyX-Code + (fail)) +\end_layout + +\begin_layout LyX-Code + (else +\end_layout + +\begin_layout LyX-Code + (succeed tree))))))) +\end_layout + +\begin_layout LyX-Code + (hash-table/put! *generic-operator-table* operator record) +\end_layout + +\begin_layout LyX-Code + (if default-operation +\end_layout + +\begin_layout LyX-Code + (assign-operation operator default-operation)) +\end_layout + +\begin_layout LyX-Code + (if (not (default-object? name)) +\end_layout + +\begin_layout LyX-Code + (hash-table/put! *generic-operator-table* name record)) +\end_layout + +\begin_layout LyX-Code + operator)) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +(define *generic-operator-table* +\end_layout + +\begin_layout LyX-Code + (make-eq-hash-table)) +\end_layout + +\begin_layout LyX-Code +(define (make-operator-record arity) (cons arity '())) +\end_layout + +\begin_layout LyX-Code +(define (operator-record-arity record) (car record)) +\end_layout + +\begin_layout LyX-Code +(define (operator-record-tree record) (cdr record)) +\end_layout + +\begin_layout LyX-Code +(define (set-operator-record-tree! record tree) (set-cdr! record tree)) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +(define (assign-operation operator handler . + argument-predicates) +\end_layout + +\begin_layout LyX-Code + (let ((record +\end_layout + +\begin_layout LyX-Code + (let ((record (hash-table/get *generic-operator-table* operator + #f)) +\end_layout + +\begin_layout LyX-Code + (arity (length argument-predicates))) +\end_layout + +\begin_layout LyX-Code + (if record +\end_layout + +\begin_layout LyX-Code + (begin +\end_layout + +\begin_layout LyX-Code + (if (not (<= arity (operator-record-arity record))) +\end_layout + +\begin_layout LyX-Code + (error "Incorrect operator arity:" operator)) +\end_layout + +\begin_layout LyX-Code + record) +\end_layout + +\begin_layout LyX-Code + (let ((record (make-operator-record arity))) +\end_layout + +\begin_layout LyX-Code + (hash-table/put! *generic-operator-table* operator record) +\end_layout + +\begin_layout LyX-Code + record))))) +\end_layout + +\begin_layout LyX-Code + (set-operator-record-tree! record +\end_layout + +\begin_layout LyX-Code + (bind-in-tree argument-predicates +\end_layout + +\begin_layout LyX-Code + handler +\end_layout + +\begin_layout LyX-Code + (operator-record-tree record)))) +\end_layout + +\begin_layout LyX-Code + operator) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +(define defhandler assign-operation) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +(define (bind-in-tree keys handler tree) +\end_layout + +\begin_layout LyX-Code + (let loop ((keys keys) (tree tree)) +\end_layout + +\begin_layout LyX-Code + (if (pair? keys) +\end_layout + +\begin_layout LyX-Code + (let find-key ((tree* tree)) +\end_layout + +\begin_layout LyX-Code + (if (pair? tree*) +\end_layout + +\begin_layout LyX-Code + (if (eq? (caar tree*) (car keys)) +\end_layout + +\begin_layout LyX-Code + (begin +\end_layout + +\begin_layout LyX-Code + (set-cdr! (car tree*) +\end_layout + +\begin_layout LyX-Code + (loop (cdr keys) (cdar tree*))) +\end_layout + +\begin_layout LyX-Code + tree) +\end_layout + +\begin_layout LyX-Code + (find-key (cdr tree*))) +\end_layout + +\begin_layout LyX-Code + (cons (cons (car keys) +\end_layout + +\begin_layout LyX-Code + (loop (cdr keys) '())) +\end_layout + +\begin_layout LyX-Code + tree))) +\end_layout + +\begin_layout LyX-Code + (if (pair? tree) +\end_layout + +\begin_layout LyX-Code + (let ((p (last-pair tree))) +\end_layout + +\begin_layout LyX-Code + (if (not (null? (cdr p))) +\end_layout + +\begin_layout LyX-Code + (warn "Replacing a handler:" (cdr p) handler)) +\end_layout + +\begin_layout LyX-Code + (set-cdr! p handler) +\end_layout + +\begin_layout LyX-Code + tree) +\end_layout + +\begin_layout LyX-Code + (begin +\end_layout + +\begin_layout LyX-Code + (if (not (null? tree)) +\end_layout + +\begin_layout LyX-Code + (warn "Replacing top-level handler:" tree handler)) +\end_layout + +\begin_layout LyX-Code + handler))))) +\end_layout + +\begin_layout LyX-Code \end_layout @@ -781,38 +1066,892 @@ discovery.scm \end_layout \begin_layout LyX-Code -//Dima Turbiner +; discovery.scm \end_layout \begin_layout LyX-Code -module zbt_to_ifft(input clk, reset, input [9:0]hcount, input [8:0]vcount, - +; author: bnewbold @ mit (with lch @ mit) +\end_layout + +\begin_layout LyX-Code +; for 6.945 +\end_layout + +\begin_layout LyX-Code +; circa 04/2009 +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; For speed? +\end_layout + +\begin_layout LyX-Code +;(declare (usual-integrations)) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; If it isn't already.... +\end_layout + +\begin_layout LyX-Code +;(load "ghelper") +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; takes two lists: the first is a set of predicates and the second a set +\end_layout + +\begin_layout LyX-Code +; of arguments; if any of the predicates are #t for the args, win, else + fail +\end_layout + +\begin_layout LyX-Code +(define (for-any? preds args) +\end_layout + +\begin_layout LyX-Code + (cond ((null? preds) #f) +\end_layout + +\begin_layout LyX-Code + ((null? (car preds)) #f) +\end_layout + +\begin_layout LyX-Code + ((apply (car preds) args) #t) +\end_layout + +\begin_layout LyX-Code + (else (for-any? (cdr preds) args)))) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; Test +\end_layout + +\begin_layout LyX-Code +(for-any? (list list? null? vector?) '(5)) +\end_layout + +\begin_layout LyX-Code +; #f +\end_layout + +\begin_layout LyX-Code +(for-any? (list list? null? vector?) '('(1 2 3))) +\end_layout + +\begin_layout LyX-Code +; #t +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; finds all the operators which can be applied to the args; returns a list +\end_layout + +\begin_layout LyX-Code +; of operators (not the actual procedures; will include duplicate symbols + and +\end_layout + +\begin_layout LyX-Code +; operator stubs for named operators) +\end_layout + +\begin_layout LyX-Code +(define (discover:opers-for . + args) +\end_layout + +\begin_layout LyX-Code + (let* ((arity (length args)) +\end_layout + +\begin_layout LyX-Code + (opers (hash-table->alist *generic-operator-table*)) +\end_layout + +\begin_layout LyX-Code + (check +\end_layout + +\begin_layout LyX-Code + (lambda (op) +\end_layout + +\begin_layout LyX-Code + (if (not (eq? arity (cadr op))) +\end_layout + +\begin_layout LyX-Code + #f +\end_layout + +\begin_layout LyX-Code + (let per-arg ((tree (operator-record-tree (cdr op))) +\end_layout + +\begin_layout LyX-Code + (args args) +\end_layout + +\begin_layout LyX-Code + (fail (lambda () #f))) +\end_layout + +\begin_layout LyX-Code + (let per-pred ((tree tree) (fail fail)) +\end_layout + +\begin_layout LyX-Code + (cond ((pair? tree) +\end_layout + +\begin_layout LyX-Code + (if ((caar tree) (car args)) +\end_layout + +\begin_layout LyX-Code + (if (pair? (cdr args)) +\end_layout + +\begin_layout LyX-Code + (per-arg (cdar tree) +\end_layout + +\begin_layout LyX-Code + (cdr args) +\end_layout + +\begin_layout LyX-Code + (lambda () +\end_layout + +\begin_layout LyX-Code + (per-pred (cdr tree) fail))) +\end_layout + +\begin_layout LyX-Code + #t) +\end_layout + +\begin_layout LyX-Code + (per-pred (cdr tree) fail))) +\end_layout + +\begin_layout LyX-Code + ((null? tree) (fail)) +\end_layout + +\begin_layout LyX-Code + (else #t)))))))) +\end_layout + +\begin_layout LyX-Code + (map car (filter check opers)))) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; same as the above but only grabs the symboled ones +\end_layout + +\begin_layout LyX-Code +(define (discover:named-opers-for . + args) +\end_layout + +\begin_layout LyX-Code + (filter symbol? (apply discover:opers-for args))) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; returns a list of +\end_layout + +\begin_layout LyX-Code +(define (discover:named-opers) +\end_layout + +\begin_layout LyX-Code + (let ((check (lambda (x) (cond ((null? x) '()) +\end_layout + +\begin_layout LyX-Code + ((symbol? x) x) +\end_layout + +\begin_layout LyX-Code + (else '()))))) +\end_layout + +\begin_layout LyX-Code + (filter (lambda (x) (not (null? x))) +\end_layout + +\begin_layout LyX-Code + (map check (hash-table-keys *generic-operator-table*))))) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; this is just what operators do +\end_layout + +\begin_layout LyX-Code +(define (discover:apply-name name . + args) +\end_layout + +\begin_layout LyX-Code + (let ((record (hash-table/get *generic-operator-table* name #f))) +\end_layout + +\begin_layout LyX-Code + (let ((succeed +\end_layout + +\begin_layout LyX-Code + (lambda (handler) +\end_layout + +\begin_layout LyX-Code + (apply handler args)))) +\end_layout + +\begin_layout LyX-Code + (let per-arg +\end_layout + +\begin_layout LyX-Code + ((tree (operator-record-tree record)) +\end_layout + +\begin_layout LyX-Code + (args args) +\end_layout + +\begin_layout LyX-Code + (fail +\end_layout + +\begin_layout LyX-Code + (lambda () +\end_layout + +\begin_layout LyX-Code + (error:no-applicable-methods operator args)))) +\end_layout + +\begin_layout LyX-Code + (let per-pred ((tree tree) (fail fail)) +\end_layout + +\begin_layout LyX-Code + (cond ((pair? tree) +\end_layout + +\begin_layout LyX-Code + (if ((caar tree) (car args)) +\end_layout + +\begin_layout LyX-Code + (if (pair? (cdr args)) +\end_layout + +\begin_layout LyX-Code + (per-arg (cdar tree) +\end_layout + +\begin_layout LyX-Code + (cdr args) +\end_layout + +\begin_layout LyX-Code + (lambda () +\end_layout + +\begin_layout LyX-Code + (per-pred (cdr tree) fail))) +\end_layout + +\begin_layout LyX-Code + (succeed (cdar tree))) +\end_layout + +\begin_layout LyX-Code + (per-pred (cdr tree) fail))) +\end_layout + +\begin_layout LyX-Code + ((null? tree) +\end_layout + +\begin_layout LyX-Code + (fail)) +\end_layout + +\begin_layout LyX-Code + (else +\end_layout + +\begin_layout LyX-Code + (succeed tree)))))))) +\end_layout + +\begin_layout LyX-Code +(define (discover:thunklist-for . + args) +\end_layout + +\begin_layout LyX-Code + (let ((names (apply discover:named-opers-for args))) +\end_layout + +\begin_layout LyX-Code + (cons args +\end_layout + +\begin_layout LyX-Code + (map (lambda (x) +\end_layout + +\begin_layout LyX-Code + (list x +\end_layout + +\begin_layout LyX-Code + (lambda () +\end_layout + +\begin_layout LyX-Code + (apply discover:apply-name (cons x args))))) +\end_layout + +\begin_layout LyX-Code + names)))) +\end_layout + +\begin_layout LyX-Code +(define (discover:apply-all . + args) +\end_layout + +\begin_layout LyX-Code + (let ((names (apply discover:named-opers-for args))) +\end_layout + +\begin_layout LyX-Code + (map (lambda (x) +\end_layout + +\begin_layout LyX-Code + (apply discover:apply-name (cons x args))) +\end_layout + +\begin_layout LyX-Code + names))) +\end_layout + +\begin_layout LyX-Code +(define (discover:apply-all-name . + args) +\end_layout + +\begin_layout LyX-Code + (let ((names (apply discover:named-opers-for args))) +\end_layout + +\begin_layout LyX-Code + (map (lambda (x) +\end_layout + +\begin_layout LyX-Code + (list (apply discover:apply-name (cons x args)) x)) +\end_layout + +\begin_layout LyX-Code + names))) +\end_layout + +\begin_layout LyX-Code +(define (discover:satisfy pred? . + args) +\end_layout + +\begin_layout LyX-Code + (let try ((objs (list args))) +\end_layout + +\begin_layout LyX-Code + (let ((goodies (filter (lambda (x) (apply pred? x)) objs))) +\end_layout + +\begin_layout LyX-Code + (if (not (null? goodies)) +\end_layout + +\begin_layout LyX-Code + (car goodies) +\end_layout + +\begin_layout LyX-Code + (try (fold-right append +\end_layout + +\begin_layout LyX-Code + '() +\end_layout + +\begin_layout LyX-Code + (map (lambda (x) +\end_layout + +\begin_layout LyX-Code + (map list +\end_layout + +\begin_layout LyX-Code + (apply discover:apply-all x))) +\end_layout + +\begin_layout LyX-Code + objs))))))) +\end_layout + +\begin_layout LyX-Code +(define (discover:satisfy-sequence pred? . + args) +\end_layout + +\begin_layout LyX-Code + (let try ((objs (list (list args)))) +\end_layout + +\begin_layout LyX-Code + (let ((goodies (filter (lambda (x) (apply pred? (car x))) objs))) +\end_layout + +\begin_layout LyX-Code + (if (not (null? goodies)) +\end_layout + +\begin_layout LyX-Code + goodies +\end_layout + +\begin_layout LyX-Code + (try (fold-right append +\end_layout + +\begin_layout LyX-Code + '() +\end_layout + +\begin_layout LyX-Code + (map (lambda (x) +\end_layout + +\begin_layout LyX-Code + (map (lambda (y) +\end_layout + +\begin_layout LyX-Code + (cons (list (car y)) (cons (cadr + y) +\end_layout + +\begin_layout LyX-Code + (cdr + x)))) +\end_layout + +\begin_layout LyX-Code + (apply discover:apply-all-name (car + x)))) +\end_layout + +\begin_layout LyX-Code + objs))))))) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +; see discovery-examples.scm for testing and examples +\end_layout + +\begin_layout Subsection +discovery-examples.scm +\end_layout + +\begin_layout LyX-Code +(load "ghelper") +\end_layout + +\begin_layout LyX-Code +(load "discovery") +\end_layout + +\begin_layout LyX-Code +(define inverse +\end_layout + +\begin_layout LyX-Code + (make-generic-operator 1 #f 'inverse)) +\end_layout + +\begin_layout LyX-Code +(define plus +\end_layout + +\begin_layout LyX-Code + (make-generic-operator 2 #f 'plus)) +\end_layout + +\begin_layout LyX-Code +(define minus +\end_layout + +\begin_layout LyX-Code + (make-generic-operator 2 #f 'minus)) +\end_layout + +\begin_layout LyX-Code + +\end_layout + +\begin_layout LyX-Code +(assign-operation inverse +\end_layout + +\begin_layout LyX-Code + (lambda (x) (/ 1 x)) +\end_layout + +\begin_layout LyX-Code + (lambda (x) (and (number? x) +\end_layout + +\begin_layout LyX-Code + (not (integer? x))))) +\end_layout + +\begin_layout LyX-Code +; actually a transpose, but meh +\end_layout + +\begin_layout LyX-Code +(assign-operation inverse +\end_layout + +\begin_layout LyX-Code + (lambda (x) (apply zip x)) +\end_layout + +\begin_layout LyX-Code + (lambda (x) +\end_layout + +\begin_layout LyX-Code + (and (list? x) +\end_layout + +\begin_layout LyX-Code + (for-all? x list?)))) +\end_layout + +\begin_layout LyX-Code +(define any? (lambda (x) #t)) +\end_layout + +\begin_layout LyX-Code +(assign-operation minus - any? any?) +\end_layout + +\begin_layout LyX-Code +(assign-operation plus + any? any?) +\end_layout + +\begin_layout LyX-Code +(plus 1 2) +\end_layout + +\begin_layout LyX-Code +; 3 +\end_layout + +\begin_layout LyX-Code +;(minus 3) +\end_layout + +\begin_layout LyX-Code +; ERROR +\end_layout + +\begin_layout LyX-Code +(inverse 6.5) +\end_layout + +\begin_layout LyX-Code +;Value: .15384615384615385 +\end_layout + +\begin_layout LyX-Code +(discover:opers-for 6.5) +\end_layout + +\begin_layout LyX-Code +;Value 52: (inverse #[compound-procedure 49 operator]) +\end_layout + +\begin_layout LyX-Code +(discover:named-opers-for 6.5) +\end_layout + +\begin_layout LyX-Code +;Value 53: (inverse) +\end_layout + +\begin_layout LyX-Code +(discover:named-opers-for 1 2) +\end_layout + +\begin_layout LyX-Code +;Value 54: (plus minus) +\end_layout + +\begin_layout LyX-Code +(environment-lookup (the-environment) 'inverse) +\end_layout + +\begin_layout LyX-Code +;Value 49: #[compound-procedure 49 operator] +\end_layout + +\begin_layout LyX-Code +(hash-table/get *generic-operator-table* inverse #f) +\end_layout + +\begin_layout LyX-Code +;Value 59: (1 (#[compound-procedure 57] . + #[compound-procedure 60]) (#[compound-procedure 61] . + #[compound-procedure 62])) +\end_layout + +\begin_layout LyX-Code +(hash-table/get *generic-operator-table* minus #f) +\end_layout + +\begin_layout LyX-Code +;Value 63: (2 (#[compound-procedure 56 any?] (#[compound-procedure 56 any?] + . + #[arity-dispatched-procedure 28]))) +\end_layout + +\begin_layout LyX-Code +(hash-table-size *generic-operator-table*) +\end_layout + +\begin_layout LyX-Code +;Value: 6 ; for this file +\end_layout + +\begin_layout LyX-Code +;Value: 92 ; for scmutils +\end_layout + +\begin_layout LyX-Code +;this prints all keys line by line +\end_layout + +\begin_layout LyX-Code +(for-each +\end_layout + +\begin_layout LyX-Code + (lambda (x) (newline) +\end_layout + +\begin_layout LyX-Code + (display x)) +\end_layout + +\begin_layout LyX-Code + (hash-table/key-list *generic-operator-table*)) +\end_layout + +\begin_layout LyX-Code +(define add1 (make-generic-operator 1 #f 'add1)) +\end_layout + +\begin_layout LyX-Code +(define sub1 (make-generic-operator 1 #f 'sub1)) +\end_layout + +\begin_layout LyX-Code +(define double (make-generic-operator 1 #f 'double)) +\end_layout + +\begin_layout LyX-Code +(define square (make-generic-operator 1 #f 'square)) +\end_layout + +\begin_layout LyX-Code +(define inverse (make-generic-operator 1 #f 'inverse)) +\end_layout + +\begin_layout LyX-Code +(defhandler add1 (lambda (x) (+ x 1)) number?) +\end_layout + +\begin_layout LyX-Code +(defhandler sub1 (lambda (x) (- x 1)) number?) +\end_layout + +\begin_layout LyX-Code +(defhandler double (lambda (x) (* 2 x)) number?) +\end_layout + +\begin_layout LyX-Code +(defhandler square (lambda (x) (* x x)) number?) +\end_layout + +\begin_layout LyX-Code +(defhandler inverse (lambda (x) (/ 1 x)) (lambda (n) +\end_layout + +\begin_layout LyX-Code + (and (number? n) +\end_layout + +\begin_layout LyX-Code + (not (zero? n))))) +\end_layout + +\begin_layout LyX-Code +(discover:apply-all 3) +\end_layout + +\begin_layout LyX-Code +;Value 89: (1/3 4 9 2 6) +\end_layout + +\begin_layout LyX-Code +(discover:satisfy (lambda (x) (eq? x 9)) (/ 1 2)) +\end_layout + +\begin_layout LyX-Code +;Value 35: (9) +\end_layout + +\begin_layout LyX-Code +(discover:satisfy-sequence (lambda (x) (eq? x 9)) (/ 1 2)) +\end_layout + +\begin_layout LyX-Code +;Value 36: (((9) square double add1) ((9) square add1 inverse)) +\end_layout + +\begin_layout LyX-Code +(discover:satisfy-sequence (lambda (x) (eq? x 49)) (/ 5 6)) +\end_layout + +\begin_layout LyX-Code +;Value 37: (((49) square sub1 inverse sub1)) +\end_layout + +\begin_layout LyX-Code +(define (prime? n) +\end_layout + +\begin_layout LyX-Code + (cond ((null? n) #f) +\end_layout + +\begin_layout LyX-Code + ((not (integer? n)) #f) +\end_layout + +\begin_layout LyX-Code + ((> 0 n) #f) +\end_layout + +\begin_layout LyX-Code + (else (let lp ((m 2)) +\end_layout + +\begin_layout LyX-Code + (cond ((> m (sqrt n)) #t) +\end_layout + +\begin_layout LyX-Code + ((integer? (/ n m)) #f) +\end_layout + +\begin_layout LyX-Code + (else (lp (+ m 1)))))))) +\end_layout + +\begin_layout LyX-Code +(prime? 47) \end_layout \begin_layout LyX-Code - input [35:0]data_main, input - [35:0]data_overlay, +; #t \end_layout \begin_layout LyX-Code - output reg [7:0]main_pixel, - output reg [7:0]overlay_pixel, output [18:0]addr); +(discover:satisfy-sequence prime? (/ 5 6)) \end_layout \begin_layout LyX-Code - //**** CHECK THIS ADDRESSING +;Value 39: (((5) inverse sub1 inverse)) \end_layout \begin_layout LyX-Code - assign addr = {2'b0, vcount, hcount[9:2]}; +(discover:satisfy-sequence prime? 923) \end_layout \begin_layout LyX-Code - +;Value 44: (((1847) add1 double)) \end_layout \begin_layout LyX-Code - wire [1:0] hc4 = hcount[1:0]; +(discover:named-opers) \end_layout \begin_layout LyX-Code diff --git a/final_project/paper/outline b/final_project/paper/outline index 84443d2..ca04e74 100644 --- a/final_project/paper/outline +++ b/final_project/paper/outline @@ -4,8 +4,8 @@ Title: Generic Operator Discovery Abstract: Predicate dispatch for generic operators [blah blah] -Generic Discovery System ------------------------- +Generic Operator Discovery System +--------------------------------- Conceptual Description - review of predicate dispatch @@ -13,27 +13,22 @@ Generic Discovery System Implementation - list of procedures + - areas for improvement Applications - examples from mechanics - examples of searching - Areas for improvement -GTK and Foreign Function Interface ----------------------------------- - - Description of FFI - - cite what's his name - - how it works (briefly?) - - GTK Bindings - - brief - - Description of Object Discovery Implementation - - procedures? + GUI Interface + - description of FFI (cite what's his name) + - how it works + - gtk bindings + - procedures? description of our interface - screenshots! + + Code Appendix ------------- discovery.scm diff --git a/final_project/work/Makefile b/final_project/work/Makefile new file mode 100644 index 0000000..f8e8f97 --- /dev/null +++ b/final_project/work/Makefile @@ -0,0 +1,43 @@ +all: + rm -f prhello-shim.{c,o} prhello-const.{c,o} *.bin *.so + make install-example + mit-scheme --batch-mode --load prhello.scm + +run: + rm -f prhello-shim.{c,o} prhello-const.{c,o} *.bin *.so + make install-example + mit-scheme --load prhello.scm + + +install-example: build-example + sudo cp -a prhello-types.bin /usr/local/lib/mit-scheme/lib/. + sudo cp -a prhello-const.bin /usr/local/lib/mit-scheme/lib/. + sudo cp -a prhello-shim.so /usr/local/lib/mit-scheme/lib/. + +build-example: prhello-shim.so prhello-types.bin prhello-const.bin + +prhello-shim.so: prhello-shim.o + $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-shim.o: prhello-shim.c + $(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $< + +prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl + (echo "(load-option 'FFI)"; \ + echo '(C-generate "prhello" "#include <gtk/gtk.h>")') \ + | mit-scheme --batch-mode + +prhello-const.bin: prhello-const.scm + echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode + +prhello-const.scm: prhello-const + ./prhello-const + +prhello-const: prhello-const.o + @rm -f $@ + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-const.o: prhello-const.c + $(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $< + + diff --git a/final_project/work/discovery-examples.scm b/final_project/work/discovery-examples.scm index 45ae2ea..e525252 100644 --- a/final_project/work/discovery-examples.scm +++ b/final_project/work/discovery-examples.scm @@ -35,34 +35,26 @@ ;Value: .15384615384615385 (discover:opers-for 6.5) -;Value 57: (#[compound-procedure 38 operator] thingaling) +;Value 52: (inverse #[compound-procedure 49 operator]) (discover:named-opers-for 6.5) -;Value 58: (thingaling) +;Value 53: (inverse) (discover:named-opers-for 1 2) -;Value 81: (plus minus) - -;;; this stuff is just play crap - -(car (hash-table->alist *generic-operator-table*)) - -(caadr (hash-table/get *generic-operator-table* inverse #f)) - -(environment-bound-names (the-environment)) +;Value 54: (plus minus) (environment-lookup (the-environment) 'inverse) - - -(inverse '( (1 2 3) - (0 1 2) - (0 0 1))) +;Value 49: #[compound-procedure 49 operator] (hash-table/get *generic-operator-table* inverse #f) +;Value 59: (1 (#[compound-procedure 57] . #[compound-procedure 60]) (#[compound-procedure 61] . #[compound-procedure 62])) + (hash-table/get *generic-operator-table* minus #f) +;Value 63: (2 (#[compound-procedure 56 any?] (#[compound-procedure 56 any?] . #[arity-dispatched-procedure 28]))) (hash-table-size *generic-operator-table*) -;Value: 92 ;this is for mechanics +;Value: 6 ; for this file +;Value: 92 ; for scmutils ;this prints all keys line by line (for-each @@ -70,7 +62,6 @@ (display x)) (hash-table/key-list *generic-operator-table*)) - (define add1 (make-generic-operator 1 #f 'add1)) (define sub1 (make-generic-operator 1 #f 'sub1)) (define double (make-generic-operator 1 #f 'double)) @@ -84,17 +75,36 @@ (and (number? n) (not (zero? n))))) -(add1 4) -;(sub1 'b) - (discover:apply-all 3) +;Value 89: (1/3 4 9 2 6) (discover:satisfy (lambda (x) (eq? x 9)) (/ 1 2)) +;Value 35: (9) + (discover:satisfy-sequence (lambda (x) (eq? x 9)) (/ 1 2)) +;Value 36: (((9) square double add1) ((9) square add1 inverse)) + (discover:satisfy-sequence (lambda (x) (eq? x 49)) (/ 5 6)) +;Value 37: (((49) square sub1 inverse sub1)) + +(define (prime? n) + (cond ((null? n) #f) + ((not (integer? n)) #f) + ((> 0 n) #f) + (else (let lp ((m 2)) + (cond ((> m (sqrt n)) #t) + ((integer? (/ n m)) #f) + (else (lp (+ m 1)))))))) + +(prime? 47) +; #t + +(discover:satisfy-sequence prime? (/ 5 6)) +;Value 39: (((5) inverse sub1 inverse)) + +(discover:satisfy-sequence prime? 923) +;Value 44: (((1847) add1 double)) -(square (sqrt 2)) -(sqrt 2) -(square 3) +(discover:named-opers) diff --git a/final_project/work/generic-string-opers.scm b/final_project/work/generic-string-opers.scm new file mode 100644 index 0000000..9855793 --- /dev/null +++ b/final_project/work/generic-string-opers.scm @@ -0,0 +1,46 @@ + +; STRING +(define capitalize (make-generic-operator 1 #f 'capitalize)) +(define downcase (make-generic-operator 1 #f 'downcase)) +(define upcase (make-generic-operator 1 #f 'upcase)) +(define string-length (make-generic-operator 1 #f 'length)) +(defhandler capitalize (lambda (x) (string-capitalize x)) string?) +(defhandler downcase (lambda (x) (string-downcase x)) string?) +(defhandler upcase (lambda (x) (string-upcase x)) string?) +(defhandler string-length (lambda (x) (string-length x)) string?) + +; STRING STRING +(define search-forward (make-generic-operator 2 #f 'search-forward)) +(define search-backward (make-generic-operator 2 #f 'search-backward)) +(define search-all (make-generic-operator 2 #f 'search-all)) +(define is-substring (make-generic-operator 2 #f 'substring?)) +(define match (make-generic-operator 2 #f 'match)) +(defhandler match (lambda (x y) (string-match-forward x y)) string? string?) +(defhandler search-forward (lambda (x y) (string-search-forward x y)) string? string?) +(defhandler search-all (lambda (x y) (string-search-all x y)) string? string?) +(defhandler search-backward (lambda (x y) (string-search-backward x y)) string? string?) +(defhandler is-substring (lambda (x y) (substring? x y)) string? string?) + +; NUMBER NUMBER +(define plus (make-generic-operator 2 #f '+)) +(define subtract (make-generic-operator 2 #f '-)) +(define mul (make-generic-operator 2 #f '*)) +(define divide (make-generic-operator 2 #f '/)) +(define are-equal (make-generic-operator 2 #f '=?)) +(defhandler plus (lambda (x y) (+ x y)) number? number?) +(defhandler subtract (lambda (x y) (- x y)) number? number?) +(defhandler mul (lambda (x y) (* x y)) number? number?) +(defhandler divide (lambda (x y) (/ x y)) number? number?) +(defhandler are-equal (lambda (x y) (= x y)) number? number?) + +; LIST +(define length2 (make-generic-operator 1 #f 'length)) +(define reverse1 (make-generic-operator 1 #f 'reverse)) +(define sort1 (make-generic-operator 1 #f 'sort)) +(defhandler length2 (lambda (x) (length x)) list?) +(defhandler reverse1 (lambda (x) (reverse x)) list?) +(defhandler sort1 (lambda (x) (sort x <)) list?) + +; BOOLEAN +(define not1 (make-generic-operator 1 #f 'not)) +(defhandler not1 (lambda (x) (not x)) boolean?) diff --git a/final_project/work/ghelper.scm b/final_project/work/ghelper.scm index 4e39cbe..c74426b 100644 --- a/final_project/work/ghelper.scm +++ b/final_project/work/ghelper.scm @@ -1,4 +1,6 @@ -;;; From 6.945 Staff, with minor edit by bnewbold (May 2009) +;;; From 6.945 Staff, with minor edit by bnewbold (May 2009): +;;; the optional name argument is handled in the style of +;;; the scmutils implementation ;;;; Most General Generic-Operator Dispatch @@ -103,4 +105,4 @@ (begin (if (not (null? tree)) (warn "Replacing top-level handler:" tree handler)) - handler)))))
\ No newline at end of file + handler))))) diff --git a/final_project/work/hello.scm b/final_project/work/hello.scm new file mode 100644 index 0000000..d28154f --- /dev/null +++ b/final_project/work/hello.scm @@ -0,0 +1,27 @@ +(define (hello) + (let ((window (gtk-window-new 'toplevel)) + (button (gtk-button-new)) + (label (gtk-label-new "Hello, World!"))) + (gtk-container-add button label) + (gtk-container-add window button) + (gtk-window-set-title window "Hello") + (gtk-container-set-border-width button 10) + (let ((counter 0)) + (g-signal-connect window (C-callback "delete_event") + (lambda (w e) + (outf-console ";Delete me "(- 2 counter)" times.\n") + (set! counter (1+ counter)) + ;; Three or more is the charm. + (if (> counter 2) 0 1))) + (g-signal-connect button (C-callback "clicked") + (lambda (w) + (if (= counter 1) + (begin + (outf-console "\n;Erroring in "(current-thread)"...\n") + (error "Testing error handling."))) + (let ((text (gtk-label-get-text label))) + (gtk-label-set-text + label (list->string (reverse! (string->list text))))) + unspecific))) + (gtk-widget-show-all window) + window))
\ No newline at end of file diff --git a/final_project/work/numerolgist.scm b/final_project/work/numerolgist.scm new file mode 100644 index 0000000..6553232 --- /dev/null +++ b/final_project/work/numerolgist.scm @@ -0,0 +1,46 @@ + + +; frac objects are like (number 'numerator 'denominator) + +; the classics; just yanked from wikipedia w/o errors or citation +(define cgs-units-constants + (list + (list (* 2.998 (expt 10 10)) 'c) ; speed of light + (list (* 6.626 (expt 10 -27)) 'h) ; plank + (list (* 4.803 (expt 10 -10)) 'e) ; electron charge (esu) +; (list 3.14159268 'pi) ; pi! + )) + +(define (make-ordered-fracs primatives) + (sort (append primatives + (map (lambda (x) + (list (/ 1 (car x)) (quasiquote '(/ 1 ,(cadr x))))) + primatives)) + (lambda (a b) (< (car a) (car b))))) + +(make-ordered-fracs cgs-units-constants) + +(define (good-approximation x primatives eta) + (define (closest-term y ordered) + (cond ((null? ordered) (error "need at least one thing to check!")) + ((null? (cdr ordered)) (car ordered)) + ((< (abs (- y (caar ordered))) + (abs (- y (caar (cdr ordered))))) + (car ordered)) + (else (closest-term y (cdr ordered))))) + (define (iterate-term y ordered eta) + (if (< (abs y) (abs eta)) + (begin + (display y) + (newline) + (display (- y eta)) + '()) + (begin + (display "x: ") (display y) (newline) + (let ((best (closest-term y ordered))) + (cons (cadr best) + (iterate-term (/ y (car best)) ordered eta)))))) + (iterate-term x (make-ordered-fracs primatives) eta)) + +(good-approximation 876259081724391234.0 cgs-units-constants 200.) + diff --git a/final_project/work/prhello-const.c b/final_project/work/prhello-const.c new file mode 100644 index 0000000..4d5f3f5 --- /dev/null +++ b/final_project/work/prhello-const.c @@ -0,0 +1,50 @@ +/* -*-C-*- */ + +/* Prefix */ +#include <gtk/gtk.h> +/* End Prefix */ + +void +grovel_basics (FILE * out) +{ + fprintf (out, " ((sizeof char) . %d)\n", sizeof (char)); + fprintf (out, " ((sizeof uchar) . %d)\n", sizeof (unsigned char)); + fprintf (out, " ((sizeof short) . %d)\n", sizeof (short)); + fprintf (out, " ((sizeof ushort) . %d)\n", sizeof (unsigned short)); + fprintf (out, " ((sizeof int) . %d)\n", sizeof (int)); + fprintf (out, " ((sizeof uint) . %d)\n", sizeof (unsigned int)); + fprintf (out, " ((sizeof long) . %d)\n", sizeof (long)); + fprintf (out, " ((sizeof ulong) . %d)\n", sizeof (unsigned long)); + fprintf (out, " ((sizeof float) . %d)\n", sizeof (float)); + fprintf (out, " ((sizeof double) . %d)\n", sizeof (double)); + fprintf (out, " ((sizeof *) . %d)\n", sizeof (void*)); +} + +void +grovel_enums (FILE * out) +{ + fprintf (out, " (|GTK_WINDOW_POPUP| . %ld)\n", ((long)GTK_WINDOW_POPUP)); + fprintf (out, " (|GTK_WINDOW_TOPLEVEL| . %ld)\n", ((long)GTK_WINDOW_TOPLEVEL)); +} + +int +main (void) +{ + FILE * out = fopen ("prhello-const.scm", "w"); + if (out == NULL) { + perror ("could not open prhello-const.scm"); + return 1; + } + fprintf (out, "'( ;; prhello constants\n"); + fprintf (out, " ( ;; enum member values\n"); + grovel_enums(out); + fprintf (out, " )\n"); + fprintf (out, " ( ;; struct values\n"); + grovel_basics(out); + fprintf (out, " ))\n"); + if (fclose (out)) { + perror ("could not close prhello-const.scm"); + return 1; + } + return 0; +} diff --git a/final_project/work/prhello-shim.c b/final_project/work/prhello-shim.c new file mode 100644 index 0000000..f8b2c7d --- /dev/null +++ b/final_project/work/prhello-shim.c @@ -0,0 +1,829 @@ +/* -*-C-*- */ + +#include <mit-scheme.h> + +/* Prefix */ +#include <gtk/gtk.h> +/* End Prefix */ + +SCM +Scm_continue_gtk_init (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_init); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_init (void) +{ + /* Declare. */ + int * argc; + char * * * argv; + + /* Init. */ + check_number_of_args (3); + argc = (int *) arg_pointer (2); + argv = (char * * *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_init); + gtk_init (argc, argv); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_init); + + callout_continue (&Scm_continue_gtk_init); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_window_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_window_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_window_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + GtkWindowType type; + + /* Init. */ + check_number_of_args (3); + type = arg_long (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_window_new); + ret0 = gtk_window_new (type); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_window_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_window_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_button_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_button_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_button_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + + /* Init. */ + check_number_of_args (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_button_new); + ret0 = gtk_button_new (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_button_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_button_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_combo_box_new_text (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_combo_box_new_text); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_combo_box_new_text (void) +{ + /* Declare. */ + GtkWidget * ret0; + + /* Init. */ + check_number_of_args (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_combo_box_new_text); + ret0 = gtk_combo_box_new_text (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_combo_box_new_text); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_combo_box_new_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_combo_box_append_text (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_combo_box_append_text); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_combo_box_append_text (void) +{ + /* Declare. */ + GtkComboBox * combo; + const char * str; + + /* Init. */ + check_number_of_args (3); + combo = (GtkComboBox *) arg_pointer (2); + str = (const char *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_combo_box_append_text); + gtk_combo_box_append_text (combo, str); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_combo_box_append_text); + + callout_continue (&Scm_continue_gtk_combo_box_append_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_combo_box_get_active (void) +{ + /* Declare. */ + char * tos0; + gint ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_combo_box_get_active); + CSTACK_LPOP (gint, ret0, tos0); + + /* Return. */ + ret0s = long_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_combo_box_get_active (void) +{ + /* Declare. */ + gint ret0; + GtkComboBox * combo; + + /* Init. */ + check_number_of_args (2); + combo = (GtkComboBox *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_combo_box_get_active); + ret0 = gtk_combo_box_get_active (combo); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_combo_box_get_active); + CSTACK_PUSH (gint, ret0); + + callout_continue (&Scm_continue_gtk_combo_box_get_active); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_label_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_label_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_label_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + const char * str; + + /* Init. */ + check_number_of_args (3); + str = (const char *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_label_new); + ret0 = gtk_label_new (str); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_label_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_label_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_hbox_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_hbox_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_hbox_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + gboolean homogeneous; + gint spacing; + + /* Init. */ + check_number_of_args (4); + homogeneous = arg_long (3); + spacing = arg_long (4); + + /* Call. */ + callout_seal (&Scm_continue_gtk_hbox_new); + ret0 = gtk_hbox_new (homogeneous, spacing); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_hbox_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_hbox_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_container_add (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_container_add); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_container_add (void) +{ + /* Declare. */ + GtkContainer * container; + GtkWidget * widget; + + /* Init. */ + check_number_of_args (3); + container = (GtkContainer *) arg_pointer (2); + widget = (GtkWidget *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_container_add); + gtk_container_add (container, widget); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_container_add); + + callout_continue (&Scm_continue_gtk_container_add); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_window_set_title (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_window_set_title); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_window_set_title (void) +{ + /* Declare. */ + GtkWindow * window; + const gchar * title; + + /* Init. */ + check_number_of_args (3); + window = (GtkWindow *) arg_pointer (2); + title = (const gchar *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_window_set_title); + gtk_window_set_title (window, title); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_window_set_title); + + callout_continue (&Scm_continue_gtk_window_set_title); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_container_set_border_width (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_container_set_border_width); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_container_set_border_width (void) +{ + /* Declare. */ + GtkContainer * container; + guint border_width; + + /* Init. */ + check_number_of_args (3); + container = (GtkContainer *) arg_pointer (2); + border_width = arg_ulong (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_container_set_border_width); + gtk_container_set_border_width (container, border_width); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_container_set_border_width); + + callout_continue (&Scm_continue_gtk_container_set_border_width); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_window_resize (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_window_resize); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_window_resize (void) +{ + /* Declare. */ + GtkWindow * window; + gint width; + gint height; + + /* Init. */ + check_number_of_args (4); + window = (GtkWindow *) arg_pointer (2); + width = arg_long (3); + height = arg_long (4); + + /* Call. */ + callout_seal (&Scm_continue_gtk_window_resize); + gtk_window_resize (window, width, height); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_window_resize); + + callout_continue (&Scm_continue_gtk_window_resize); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_widget_show_all (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_widget_show_all); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_widget_show_all (void) +{ + /* Declare. */ + GtkWidget * widget; + + /* Init. */ + check_number_of_args (2); + widget = (GtkWidget *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_widget_show_all); + gtk_widget_show_all (widget); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_widget_show_all); + + callout_continue (&Scm_continue_gtk_widget_show_all); + /* NOTREACHED */ +} + +SCM +Scm_continue_g_signal_connect (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_g_signal_connect); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_g_signal_connect (void) +{ + /* Declare. */ + GtkObject * object; + gchar * name; + GtkSignalFunc CALLBACK; + gpointer ID; + + /* Init. */ + check_number_of_args (5); + object = (GtkObject *) arg_pointer (2); + name = (gchar *) arg_pointer (3); + CALLBACK = (GtkSignalFunc) arg_alien_entry (4); + ID = (gpointer) arg_long (5); + + /* Call. */ + callout_seal (&Scm_continue_g_signal_connect); + g_signal_connect (object, name, CALLBACK, ID); + + /* Save. */ + callout_unseal (&Scm_continue_g_signal_connect); + + callout_continue (&Scm_continue_g_signal_connect); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_widget_destroy (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_widget_destroy); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_widget_destroy (void) +{ + /* Declare. */ + GtkWidget * widget; + + /* Init. */ + check_number_of_args (2); + widget = (GtkWidget *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_widget_destroy); + gtk_widget_destroy (widget); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_widget_destroy); + + callout_continue (&Scm_continue_gtk_widget_destroy); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_label_get_text (void) +{ + /* Declare. */ + char * tos0; + const gchar * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_label_get_text); + CSTACK_LPOP (const gchar *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_label_get_text (void) +{ + /* Declare. */ + const gchar * ret0; + GtkLabel * label; + + /* Init. */ + check_number_of_args (3); + label = (GtkLabel *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_label_get_text); + ret0 = gtk_label_get_text (label); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_label_get_text); + CSTACK_PUSH (const gchar *, ret0); + + callout_continue (&Scm_continue_gtk_label_get_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_label_set_text (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_label_set_text); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_label_set_text (void) +{ + /* Declare. */ + GtkLabel * label; + const char * str; + + /* Init. */ + check_number_of_args (3); + label = (GtkLabel *) arg_pointer (2); + str = (const char *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_label_set_text); + gtk_label_set_text (label, str); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_label_set_text); + + callout_continue (&Scm_continue_gtk_label_set_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_main (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_main); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_main (void) +{ + /* Declare. */ + + /* Init. */ + check_number_of_args (1); + + /* Call. */ + callout_seal (&Scm_continue_gtk_main); + gtk_main (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_main); + + callout_continue (&Scm_continue_gtk_main); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_main_quit (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_main_quit); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_main_quit (void) +{ + /* Declare. */ + + /* Init. */ + check_number_of_args (1); + + /* Call. */ + callout_seal (&Scm_continue_gtk_main_quit); + gtk_main_quit (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_main_quit); + + callout_continue (&Scm_continue_gtk_main_quit); + /* NOTREACHED */ +} + +static void +Scm_kernel_delete_event (void) +{ + /* Declare. */ + GtkWidget * window; + GdkEventAny * event; + gpointer ID; + SCM arglist0; + char * tos0; + + /* Init. */ + tos0 = callback_lunseal (&Scm_kernel_delete_event); + CSTACK_LPOP (GtkWidget *, window, tos0); + CSTACK_LPOP (GdkEventAny *, event, tos0); + CSTACK_LPOP (gpointer, ID, tos0); + + /* Construct. */ + arglist0 = empty_list(); + arglist0 = cons (cons_alien((void*)event), arglist0); + arglist0 = cons (cons_alien((void*)window), arglist0); + callback_run_handler ((int)ID, arglist0); + + callback_return (tos0); +} +gboolean +Scm_delete_event (GtkWidget * window, GdkEventAny * event, gpointer ID) +{ + CSTACK_PUSH (gpointer, ID); + CSTACK_PUSH (GdkEventAny *, event); + CSTACK_PUSH (GtkWidget *, window); + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_delete_event); + return (long_value ()); +} + +static void +Scm_kernel_changed (void) +{ + /* Declare. */ + GtkComboBox * widget; + gpointer ID; + SCM arglist0; + char * tos0; + + /* Init. */ + tos0 = callback_lunseal (&Scm_kernel_changed); + CSTACK_LPOP (GtkComboBox *, widget, tos0); + CSTACK_LPOP (gpointer, ID, tos0); + + /* Construct. */ + arglist0 = empty_list(); + arglist0 = cons (cons_alien((void*)widget), arglist0); + callback_run_handler ((int)ID, arglist0); + + callback_return (tos0); +} +void +Scm_changed (GtkComboBox * widget, gpointer ID) +{ + CSTACK_PUSH (gpointer, ID); + CSTACK_PUSH (GtkComboBox *, widget); + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_changed); + return; +} + +static void +Scm_kernel_clicked (void) +{ + /* Declare. */ + GtkWidget * widget; + gpointer ID; + SCM arglist0; + char * tos0; + + /* Init. */ + tos0 = callback_lunseal (&Scm_kernel_clicked); + CSTACK_LPOP (GtkWidget *, widget, tos0); + CSTACK_LPOP (gpointer, ID, tos0); + + /* Construct. */ + arglist0 = empty_list(); + arglist0 = cons (cons_alien((void*)widget), arglist0); + callback_run_handler ((int)ID, arglist0); + + callback_return (tos0); +} +void +Scm_clicked (GtkWidget * widget, gpointer ID) +{ + CSTACK_PUSH (gpointer, ID); + CSTACK_PUSH (GtkWidget *, widget); + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_clicked); + return; +} diff --git a/final_project/work/prhello-types.bin b/final_project/work/prhello-types.bin Binary files differnew file mode 100644 index 0000000..4bfc808 --- /dev/null +++ b/final_project/work/prhello-types.bin diff --git a/final_project/work/prhello.cdecl b/final_project/work/prhello.cdecl new file mode 100644 index 0000000..26b8882 --- /dev/null +++ b/final_project/work/prhello.cdecl @@ -0,0 +1,115 @@ + #| -*-Scheme-*- + + C declarations for prhello.scm. |# + + + (typedef gint int) + (typedef guint uint) + (typedef gchar char) + (typedef gboolean gint) + (typedef gpointer (* mumble)) + + (extern void + gtk_init + (argc (* int)) + (argv (* (* (* char))))) + + (extern (* GtkWidget) + gtk_window_new + (type GtkWindowType)) + + (typedef GtkWindowType + (enum + (GTK_WINDOW_TOPLEVEL) + (GTK_WINDOW_POPUP))) + + (extern (* GtkWidget) + gtk_button_new) + + (extern (* GtkWidget) + gtk_combo_box_new_text) + + (extern void + gtk_combo_box_append_text + (combo (* GtkComboBox)) + (str (* (const char)))) + + (extern gint + gtk_combo_box_get_active + (combo (* GtkComboBox))) + + (extern (* GtkWidget) + gtk_label_new + (str (* (const char)))) + + (extern (* GtkWidget) + gtk_hbox_new + (homogeneous gboolean) + (spacing gint)) + + + (extern void + gtk_container_add + (container (* GtkContainer)) + (widget (* GtkWidget))) + + (extern void + gtk_window_set_title + (window (* GtkWindow)) + (title (* (const gchar)))) + + (extern void + gtk_container_set_border_width + (container (* GtkContainer)) + (border_width guint)) + + (extern void + gtk_window_resize + (window (* GtkWindow)) + (width gint) + (height gint)) + + (extern void + gtk_widget_show_all + (widget (* GtkWidget))) + + (extern void + g_signal_connect + (object (* GtkObject)) + (name (* gchar)) + (CALLBACK GtkSignalFunc) + (ID gpointer)) + + (typedef GtkSignalFunc (* mumble)) + + (callback gboolean + delete_event + (window (* GtkWidget)) + (event (* GdkEventAny)) + (ID gpointer)) + + (callback void + changed + (widget (* GtkComboBox)) + (ID gpointer)) + + (callback void + clicked + (widget (* GtkWidget)) + (ID gpointer)) + + (extern void + gtk_widget_destroy + (widget (* GtkWidget))) + + (extern (* (const gchar)) + gtk_label_get_text + (label (* GtkLabel))) + + (extern void + gtk_label_set_text + (label (* GtkLabel)) + (str (* (const char)))) + + (extern void gtk_main) + (extern void gtk_main_quit) diff --git a/final_project/work/prhello.scm b/final_project/work/prhello.scm new file mode 100644 index 0000000..c57f6f9 --- /dev/null +++ b/final_project/work/prhello.scm @@ -0,0 +1,77 @@ + #| -*-Scheme-*- + + $Id: $ + |# + + (declare (usual-integrations)) + + + (load "ghelper.scm") + (load "discovery.scm") + (load-option 'FFI) + (C-include "prhello") +(load "generic-string-opers.scm") + +(define get-vals car) +(define (get-proc-symbols input) (map car (cdr input))) +(define (apply-ith-thunk input i) ((cadr (list-ref (cdr input) i)))) + + +(define (thing-to-string thing) + (let ((buff (open-output-string))) + (display thing buff) + (get-output-string buff))) + +(define (discover-gui . input) + ;(display (discover:named-opers-for 1)) + (C-call "gtk_init" 0 null-alien) + (let* ((discovered-opers (apply discover:thunklist-for input)) + (window (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_window_new" alien + (C-enum "GTK_WINDOW_TOPLEVEL")) + (if (alien-null? alien) (error "Could not create window.")) + alien)) + (hbox (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_hbox_new" alien 0 20) + (if (alien-null? alien) (error "Could not create hbox.")) + alien)) + (combo (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_combo_box_new_text" alien) + (if (alien-null? alien) (error "Could not create combo.")) + alien)) + (labels (map (lambda (val) + (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_label_new" alien (thing-to-string val)) + (if (alien-null? alien) (error "Could not create label.")) + alien)) + (get-vals discovered-opers)))) + (for-each (lambda (proc-symbol) + (C-call "gtk_combo_box_append_text" combo (thing-to-string proc-symbol))) + (get-proc-symbols discovered-opers)) + + (for-each (lambda (label) (C-call "gtk_container_add" hbox label)) labels) + (C-call "gtk_container_add" hbox combo) + (C-call "gtk_container_add" window hbox) + (C-call "gtk_window_set_title" window "Generic Operator Discovery") + (C-call "gtk_container_set_border_width" window 10) + (C-call "gtk_window_resize" window 250 20) + (C-call "g_signal_connect" combo "changed" + (C-callback "changed") ;trampoline + (C-callback ;callback ID + (lambda (w) + (let ((i (C-call "gtk_combo_box_get_active" combo))) + (discover-gui (apply-ith-thunk discovered-opers i)))))) + + (C-call "g_signal_connect" window "delete_event" + (C-callback "delete_event") ;trampoline + (C-callback ;callback ID + (lambda (w e) + (begin + (C-call "gtk_main_quit") + 0)))) + (C-call "gtk_widget_show_all" window) + (C-call "gtk_main") + window)) + + + |