eliot@cs.qmw.ac.uk (Eliot Miranda) (03/15/91)
This is a Smalltalk-80 M.V.C. implementation of chess & draughts distributed under the Gnu Public Licence.
Share & Enjoy!
------------ Cut Here ------------
#!/bin/sh
# xshar: Shell Archiver (v1.22)
#
# Remove the header and type "sh filename" to create:
# README
# COPYING
# icons.st
# Games-ChequerBoard.st
# SelectSemaphoreIO.st
# UnixPipes.st
#
echo "x - extracting README (Text)"
sed 's/^X//' << 'SHAR_EOF' > README &&
XPreamble:
X This fileset provides a Smalltalk-80 implementation of a chess board
X and a draughts board. It should be compatible with Smalltalk-80 V2.3
X through V2.5.
X See ChequerBoard open for how to start up a view of a chess or
X draughts game. This program is (in my humble opinion) a nice
X example of the Model View Controller paradigm. One View/Controller
X pair is used to play two games (chess & draughts).
X
X On unix systems the program can use unix chess(6) or gnuchess(6)
X to play against the user. To get this to work you will have to modify
X UnixChessPlayer to use whatever your version of Smalltalk provides to
X communicate with unix pipes. The BrouHaHa version of UnixPipeStream
X and asynchronous I/O is included as an illustration.
X
X The icons used to display the pieces are taken from nchess,
X a program previously posted to the net.
X These icons MAY NOT BE USED for commercial purposes.
X I quote:
X "Any commercial use of this software is strictly prohibited,
X INCLUDING usage as a demo vehicle for Sun workstations.
X
X Enjoy!
X
X Tom Anderson, (206) 356-5895
X John Fluke Mfg. Co., Inc.,
X P.O. Box C9090 M/S 245F,
X Everett, Wa. 98206
X { hplsla, microsoft, uw-beaver, sun }!fluke!toma"
X
XFile Set:
X README
X this file
X COPYING
X the Gnu Public Licence
X icons.st
X the store string of a dictionary of chess icons taken from nchess.
X Games-ChequerBoard.st
X an MVC implementation of chess & draughts
X SelectSemaphoreIO.st
X BrouHaHa Smalltalk-80 v2.3.2t specific asynchronous I/O. On unix systems
X this is a clean interface to the select(2) system call.
X UnixPipes.st
X a stream interface to unix pipes used by UnixChessPlayer to interface
X to a chess playing program such as chess(6) or gnuchess(6).
X
XFiling In:
X You should evaluate icons.st to get a dictionary of icons. Then
X store each icon as a form file in the directory you keep images
X in. Then modify the file Games-ChequerBoard.st so that
X ChessPiece class>initialize reads in icons from this directory.
X If you have BrouHaHa Smalltalk-80 v2.3.2t file in the remaining files
X to get unix to play chess on behalf of Smalltalk.
X
X
XLicencing:
X Copyright (C) 1991 Eliot E. Miranda
X
X This program is free software; you can redistribute it and/or modify
X it under the terms of the GNU General Public License as published by
X the Free Software Foundation; either version 1, or (at your option)
X any later version.
X
X This program is distributed in the hope that it will be useful,
X but WITHOUT ANY WARRANTY; without even the implied warranty of
X MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X GNU General Public License for more details.
X
X You should have received a copy of the GNU General Public License
X along with this program; if not, write to the Free Software
X Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
X
X Eliot Miranda email: eliot@cs.qmw.ac.uk
X Dept of Computer Science Tel: 071 975 5229 (+44 71 975 5229)
X Queen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk
X Mile End Road UUCP: eliot@qmw-cs.uucp
X LONDON E1 4NS
X U.K.
X
SHAR_EOF
chmod 0644 README || echo "restore of README fails"
echo "x - extracting COPYING (Text)"
sed 's/^X//' << 'SHAR_EOF' > COPYING &&
X
X GNU GENERAL PUBLIC LICENSE
X Version 1, February 1989
X
X Copyright (C) 1989 Free Software Foundation, Inc.
X 675 Mass Ave, Cambridge, MA 02139, USA
X Everyone is permitted to copy and distribute verbatim copies
X of this license document, but changing it is not allowed.
X
X Preamble
X
X The license agreements of most software companies try to keep users
Xat the mercy of those companies. By contrast, our General Public
XLicense is intended to guarantee your freedom to share and change free
Xsoftware--to make sure the software is free for all its users. The
XGeneral Public License applies to the Free Software Foundation's
Xsoftware and to any other program whose authors commit to using it.
XYou can use it for your programs, too.
X
X When we speak of free software, we are referring to freedom, not
Xprice. Specifically, the General Public License is designed to make
Xsure that you have the freedom to give away or sell copies of free
Xsoftware, that you receive source code or can get it if you want it,
Xthat you can change the software or use pieces of it in new free
Xprograms; and that you know you can do these things.
X
X To protect your rights, we need to make restrictions that forbid
Xanyone to deny you these rights or to ask you to surrender the rights.
XThese restrictions translate to certain responsibilities for you if you
Xdistribute copies of the software, or if you modify it.
X
X For example, if you distribute copies of a such a program, whether
Xgratis or for a fee, you must give the recipients all the rights that
Xyou have. You must make sure that they, too, receive or can get the
Xsource code. And you must tell them their rights.
X
X We protect your rights with two steps: (1) copyright the software, and
X(2) offer you this license which gives you legal permission to copy,
Xdistribute and/or modify the software.
X
X Also, for each author's protection and ours, we want to make certain
Xthat everyone understands that there is no warranty for this free
Xsoftware. If the software is modified by someone else and passed on, we
Xwant its recipients to know that what they have is not the original, so
Xthat any problems introduced by others will not reflect on the original
Xauthors' reputations.
X
X The precise terms and conditions for copying, distribution and
Xmodification follow.
X
X GNU GENERAL PUBLIC LICENSE
X TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
X
X 0. This License Agreement applies to any program or other work which
Xcontains a notice placed by the copyright holder saying it may be
Xdistributed under the terms of this General Public License. The
X"Program", below, refers to any such program or work, and a "work based
Xon the Program" means either the Program or any work containing the
XProgram or a portion of it, either verbatim or with modifications. Each
Xlicensee is addressed as "you".
X
X 1. You may copy and distribute verbatim copies of the Program's source
Xcode as you receive it, in any medium, provided that you conspicuously and
Xappropriately publish on each copy an appropriate copyright notice and
Xdisclaimer of warranty; keep intact all the notices that refer to this
XGeneral Public License and to the absence of any warranty; and give any
Xother recipients of the Program a copy of this General Public License
Xalong with the Program. You may charge a fee for the physical act of
Xtransferring a copy.
X
X 2. You may modify your copy or copies of the Program or any portion of
Xit, and copy and distribute such modifications under the terms of Paragraph
X1 above, provided that you also do the following:
X
X a) cause the modified files to carry prominent notices stating that
X you changed the files and the date of any change; and
X
X b) cause the whole of any work that you distribute or publish, that
X in whole or in part contains the Program or any part thereof, either
X with or without modifications, to be licensed at no charge to all
X third parties under the terms of this General Public License (except
X that you may choose to grant warranty protection to some or all
X third parties, at your option).
X
X c) If the modified program normally reads commands interactively when
X run, you must cause it, when started running for such interactive use
X in the simplest and most usual way, to print or display an
X announcement including an appropriate copyright notice and a notice
X that there is no warranty (or else, saying that you provide a
X warranty) and that users may redistribute the program under these
X conditions, and telling the user how to view a copy of this General
X Public License.
X
X d) You may charge a fee for the physical act of transferring a
X copy, and you may at your option offer warranty protection in
X exchange for a fee.
X
XMere aggregation of another independent work with the Program (or its
Xderivative) on a volume of a storage or distribution medium does not bring
Xthe other work under the scope of these terms.
X
X 3. You may copy and distribute the Program (or a portion or derivative of
Xit, under Paragraph 2) in object code or executable form under the terms of
XParagraphs 1 and 2 above provided that you also do one of the following:
X
X a) accompany it with the complete corresponding machine-readable
X source code, which must be distributed under the terms of
X Paragraphs 1 and 2 above; or,
X
X b) accompany it with a written offer, valid for at least three
X years, to give any third party free (except for a nominal charge
X for the cost of distribution) a complete machine-readable copy of the
X corresponding source code, to be distributed under the terms of
X Paragraphs 1 and 2 above; or,
X
X c) accompany it with the information you received as to where the
X corresponding source code may be obtained. (This alternative is
X allowed only for noncommercial distribution and only if you
X received the program in object code or executable form alone.)
X
XSource code for a work means the preferred form of the work for making
Xmodifications to it. For an executable file, complete source code means
Xall the source code for all modules it contains; but, as a special
Xexception, it need not include source code for modules which are standard
Xlibraries that accompany the operating system on which the executable
Xfile runs, or for standard header files or definitions files that
Xaccompany that operating system.
X
X 4. You may not copy, modify, sublicense, distribute or transfer the
XProgram except as expressly provided under this General Public License.
XAny attempt otherwise to copy, modify, sublicense, distribute or transfer
Xthe Program is void, and will automatically terminate your rights to use
Xthe Program under this License. However, parties who have received
Xcopies, or rights to use copies, from you under this General Public
XLicense will not have their licenses terminated so long as such parties
Xremain in full compliance.
X
X 5. By copying, distributing or modifying the Program (or any work based
Xon the Program) you indicate your acceptance of this license to do so,
Xand all its terms and conditions.
X
X 6. Each time you redistribute the Program (or any work based on the
XProgram), the recipient automatically receives a license from the original
Xlicensor to copy, distribute or modify the Program subject to these
Xterms and conditions. You may not impose any further restrictions on the
Xrecipients' exercise of the rights granted herein.
X
X 7. The Free Software Foundation may publish revised and/or new versions
Xof the General Public License from time to time. Such new versions will
Xbe similar in spirit to the present version, but may differ in detail to
Xaddress new problems or concerns.
X
XEach version is given a distinguishing version number. If the Program
Xspecifies a version number of the license which applies to it and "any
Xlater version", you have the option of following the terms and conditions
Xeither of that version or of any later version published by the Free
XSoftware Foundation. If the Program does not specify a version number of
Xthe license, you may choose any version ever published by the Free Software
XFoundation.
X
X 8. If you wish to incorporate parts of the Program into other free
Xprograms whose distribution conditions are different, write to the author
Xto ask for permission. For software which is copyrighted by the Free
XSoftware Foundation, write to the Free Software Foundation; we sometimes
Xmake exceptions for this. Our decision will be guided by the two goals
Xof preserving the free status of all derivatives of our free software and
Xof promoting the sharing and reuse of software generally.
X
X NO WARRANTY
X
X 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
XFOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
XOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
XPROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
XOR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
XMERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
XTO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
XPROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
XREPAIR OR CORRECTION.
X
X 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
XWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
XREDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
XINCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
XOUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
XTO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
XYOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
XPROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
XPOSSIBILITY OF SUCH DAMAGES.
X
X END OF TERMS AND CONDITIONS
X
X Appendix: How to Apply These Terms to Your New Programs
X
X If you develop a new program, and you want it to be of the greatest
Xpossible use to humanity, the best way to achieve this is to make it
Xfree software which everyone can redistribute and change under these
Xterms.
X
X To do so, attach the following notices to the program. It is safest to
Xattach them to the start of each source file to most effectively convey
Xthe exclusion of warranty; and each file should have at least the
X"copyright" line and a pointer to where the full notice is found.
X
X <one line to give the program's name and a brief idea of what it does.>
X Copyright (C) 19yy <name of author>
X
X This program is free software; you can redistribute it and/or modify
X it under the terms of the GNU General Public License as published by
X the Free Software Foundation; either version 1, or (at your option)
X any later version.
X
X This program is distributed in the hope that it will be useful,
X but WITHOUT ANY WARRANTY; without even the implied warranty of
X MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X GNU General Public License for more details.
X
X You should have received a copy of the GNU General Public License
X along with this program; if not, write to the Free Software
X Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
XAlso add information on how to contact you by electronic and paper mail.
X
XIf the program is interactive, make it output a short notice like this
Xwhen it starts in an interactive mode:
X
X Gnomovision version 69, Copyright (C) 19xx name of author
X Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
X This is free software, and you are welcome to redistribute it
X under certain conditions; type `show c' for details.
X
XThe hypothetical commands `show w' and `show c' should show the
Xappropriate parts of the General Public License. Of course, the
Xcommands you use may be called something other than `show w' and `show
Xc'; they could even be mouse-clicks or menu items--whatever suits your
Xprogram.
X
XYou should also get your employer (if you work as a programmer) or your
Xschool, if any, to sign a "copyright disclaimer" for the program, if
Xnecessary. Here a sample; alter the names:
X
X Yoyodyne, Inc., hereby disclaims all copyright interest in the
X program `Gnomovision' (a program to direct compilers to make passes
X at assemblers) written by James Hacker.
X
X <signature of Ty Coon>, 1 April 1989
X Ty Coon, President of Vice
X
XThat's all there is to it!
SHAR_EOF
chmod 0644 COPYING || echo "restore of COPYING fails"
echo "x - extracting icons.st (Text)"
sed 's/^X//' << 'SHAR_EOF' > icons.st &&
X((Dictionary new) add: (Association basicNew instVarAt: 1 put: 'king'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 32768 0 0 1 32768 0 0 1 32768 0 0 1 32768 0 0 3 49152 0 0 3 49152 0 0 6 24576 0 0 6 24576 0 0 6 24576 0 0 3971 49648 0 0 32739 51198 0 1 65529 40959 32768 3 65533 49151 49152 7 65535 65535 57344 15 65535 65535 61440 15 65535 65535 61440 31 65535 65535 63488 31 65535 65535 63488 63 65535 65535 64512 63 64639 65087 64512 63 61455 61455 64512 127 61927 59279 65024 127 58363 57287 65024 127 59391 65511 65024 127 59391 65511 65024 127 59391 655
11 65024 127 59391 65511 65024 127 59391 65511 65024 127 58367 65479 65024 127 62463 65487 65024 127 62463 65487 65024 63 63999 65439 64512 63 63999 65439 64512 63 64767 65343 64512 31 64767 65343 63488 31 65151 65151 63488 15 65407 65279 61440 7 65471 65023 57344 3 65535 65535 49152 3 65535 65535 49152 1 65535 65535 32768 0 65535 65535 0 0 65535 65535 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 65535 65535 0 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535
32X768 1 32768 1 32768 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0 0 0 0 0)
X offset: 0@0)) shape: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 32768 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 7 57344 0 0 7 57344 0 0 15 61440 0 0 15 61440 0 0 3983 61936 0 0 32743 59390 0 1 65531 57343 32768 3 65533 49151 49152 7 65535 65535 57344 15 65535 65535 61440 31 65535 65535 63488 31 65535 65535 63488 63 65535 65535 64512 63 65535 65535 64512 127 65535 65535 65024 127 65535 65535 65024 127 65535 65535 65024 255 65535 65535 65280 255 65535 65535 65280 255 65535 65535 65280 255 65535 65535 6
5280 255 65535 65535 65280 255 65535 65535 65280 255 65535 65535 65280 255 65535 65535 65280 255 65535 65535 65280 255 65535 65535 65280 127 65535 65535 65024 127 65535 65535 65024 127 65535 65535 65024 63 65535 65535 64512 63 65535 65535 64512 31 65535 65535 63488 15 65535 65535 61440 7 65535 65535 57344 7 65535 65535 57344 3 65535 65535 49152 1 65535 65535 32768 1 65535 65535 32768 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 1 65535 65535 32768 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49
15X2 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 1 65535 65535 49152 0 65535 65535 0 0 0 0 0 0 0 0 0)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'smallknight'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 160 32768 95 43008 191 61440 383 59392 1791 64512 1535 65024 1023 65024 1535 65024 1023 65280 4095 65408 3071 65472 2047 16320 3071 960 2047 384 3071 32768 2047 49152 3071 57344 2047 57344 511 61440 255 61440 127 63488 127 64512 127 65024 255 65280 0 0 255 65280 0 0 255 65280 0 0)
X offset: 0@0)) shape: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 45 32768 127 60416 511 65024 1023 64512 1023 64512 1023 65024 4095 65280 4095 65280 8191 65280 4095 65408 2047 65472 8191 65504 4095 65504 8191 49120 4095 33760 8191 49536 4095 57344 4095 61440 4095 61440 2047 63488 511 63488 255 64512 255 65024 255 65280 511 65408 511 65408 511 65408 511 65408 511 65408 255 65280)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'smallking'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 1 32768 1 32768 1 32768 57 39936 254 32512 511 65408 1023 65472 1023 65472 995 50112 1997 47584 2015 64992 2015 64992 2015 63968 1999 64480 2031 64480 1015 63424 1023 65472 511 65408 255 65280 127 65024 127 65024 127 65024 0 0 255 65280 0 0 255 65280 0 0)
X offset: 0@0)) shape: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 1 32768 1 32768 3 49152 3 49152 59 56320 255 65280 511 65408 1023 65472 2047 65504 2047 65504 2047 65504 4095 65520 4095 65520 4095 65520 4095 65520 4095 65520 4095 65520 2047 65504 2047 65504 1023 65472 511 65408 255 65280 255 65280 255 65280 511 65408 511 65408 511 65408 511 65408 511 65408)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'smallrook'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 67 49664 195 49920 451 50048 487 59264 511 65408 511 65408 255 65280 127 65024 63 64512 63 64512 42 64512 42 64512 42 64512 42 64512 63 64512 63 64512 63 21504 63 21504 63 21504 63 21504 63 64512 63 64512 127 65024 255 65280 0 0 255 65280 0 0 255 65280 0 0)
X offset: 0@0)) shape: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 103 58880 231 59136 487 59264 999 59328 1023 65472 1023 65472 1023 65472 511 65408 255 65280 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 127 65024 255 65280 511 65408 511 65408 511 65408 511 65408 511 65408 255 65280)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'smallbishop'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 3 24576 7 40960 7 45056 15 53248 15 55296 31 60416 31 62464 62 30208 62 31232 126 31232 120 7168 126 31744 126 32256 126 32256 126 32256 62 31744 62 31744 62 31744 62 31744 31 63488 31 63488 31 63488 31 63488 255 65280 0 0 255 65280 0 0 255 65280 0 0)
X offset: 0@0)) shape: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 3 24576 7 61440 15 61440 15 63488 31 63488 31 64512 63 65024 63 65024 127 65280 127 65280 255 65280 255 65280 255 65280 255 65280 255 65280 255 65280 127 65024 127 65024 127 65024 127 65024 63 64512 63 64512 63 64512 255 65280 511 65408 511 65408 511 65408 511 65408 511 65408 255 65280)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'smallpawn'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 49152 3 57344 3 57344 3 57344 3 57344 1 49152 0 32768 0 32768 0 32768 0 32768 0 32768 0 32768 1 49152 1 49152 3 57344 3 57344 7 61440 15 63488 31 64512 127 65280 0 0 127 65280 0 0 127 65280 0 0)
X offset: 0@0)) shape: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 1 49152 3 57344 7 61440 7 61440 7 61440 7 61440 3 57344 1 49152 1 49152 1 49152 1 49152 1 49152 1 49152 3 57344 3 57344 7 61440 7 61440 15 63488 31 64512 127 65280 255 65408 255 65408 255 65408 255 65408 255 65408 127 65280)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'rook'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 31 63488 0 0 63 64512 0 0 30783 64542 0 1 63551 64543 32768 3 63551 64543 49152 7 63551 64543 57344 7 63551 64543 57344 7 63551 64543 57344 7 63999 65439 57344 7 65535 65535 57344 7 65535 65535 57344 7 65535 65535 57344 7 65535 65535 57344 7 65535 65535 57344 1 65535 65535 32768 0 32767 65534 0 0 8191 65528 0 0 4095 65520 0 0 4095 65520 0 0 4095 65520 0 0 4095 65520 0 0 2655 65520 0 0 2655 65520 0 0 2655 65520 0 0 2655 65520 0 0 2655 65520 0 0 2655 65520 0
0 2650 49136 0 0 2650 49136 0 0 4090 49136 0 0 4090 49136 0 0 4090 49136 0 0 4090 49136 0 0 4090 46448 0 0 4090 46448 0 0 4095 62832 0 0 4095 62832 0 0 4095 62832 0 0 4095 62832 0 0 4095 62832 0 0 4095 62832 0 0 4095 65520 0 0 4095 65520 0 0 4095 65520 0 0 4095 65520 0 0 8191 65528 0 0 16383 65532 0 0 32767 65534 0 0 65535 65535 0 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0 0 0 0 0)
X offset: 0@0)) shape: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 31 63488 0 0 63 64512 0 0 30847 65054 0 1 64639 65087 32768 3 64639 65087 49152 7 64639 65087 57344 15 64639 65087 61440 15 64639 65087 61440 15 65023 65471 61440 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 7 65535 65535 57344 1 65535 65535 32768 0 32767 65534 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 81
91 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 16383 65532 0 0 32767 65534 0 0 65535 65535 0 1 65535 65535 32768 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 1 65535
6X5535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'bishop'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 12 12288 0 0 12 12288 0 0 30 30720 0 0 63 31744 0 0 63 48128 0 0 127 56832 0 0 127 60928 0 0 255 61184 0 0 511 63360 0 0 511 64384 0 0 1023 64448 0 0 1023 64960 0 0 2047 65248 0 0 2047 65248 0 0 4095 65392 0 0 4092 32688 0 0 8188 32696 0 0 8188 32728 0 0 8188 32728 0 0 8188 32744 0 0 16380 32748 0 0 16380 32756 0 0 16256 1012 0 0 16256 1016 0 0 16380 32760 0 0 16380 32764 0 0 16380 32764 0 0 16380 32764 0 0 16380 32764 0 0 16380 32764 0 0 16380 32764 0 0 81
88 32760 0 0 8188 32760 0 0 8188 32760 0 0 8188 32760 0 0 8188 32760 0 0 4092 32752 0 0 4092 32752 0 0 4092 32752 0 0 2047 65504 0 0 2047 65504 0 0 2047 65504 0 0 1023 65472 0 0 1023 65472 0 0 1023 65472 0 0 1023 65472 0 0 1023 65472 0 0 1023 65472 0 0 65535 65535 0 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0 0 0 0 0)
X offset: 0@0)) shape: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 12 12288 0 0 30 30720 0 0 30 30720 0 0 63 64512 0 0 127 65024 0 0 127 65024 0 0 255 65280 0 0 255 65280 0 0 511 65408 0 0 1023 65472 0 0 1023 65472 0 0 2047 65504 0 0 2047 65504 0 0 4095 65520 0 0 4095 65520 0 0 8191 65528 0 0 8191 65528 0 0 16383 65532 0 0 16383 65532 0 0 16383 65532 0 0 16383 65532 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 327
67 65534 0 0 16383 65532 0 0 16383 65532 0 0 16383 65532 0 0 16383 65532 0 0 16383 65532 0 0 8191 65528 0 0 8191 65528 0 0 8191 65528 0 0 4095 65520 0 0 4095 65520 0 0 4095 65520 0 0 2047 65504 0 0 2047 65504 0 0 2047 65504 0 0 2047 65504 0 0 2047 65504 0 0 65535 65535 0 1 65535 65535 32768 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'queen'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 32768 0 0 1 32768 0 0 3 49152 0 0 3 49152 0 0 7 57344 0 0 7 57344 0 0 15 61440 0 0 15 61440 0 0 31 63488 0 0 31 63488 0 0 63 64512 0 0 63 64512 0 0 127 65024 0 0 127 65024 0 0 255 65280 0 32 255 65280 1024 48 511 65408 3072 56 511 65408 7168 60 1023 65472 15360 60 1023 65472 15360 30 2046 32736 30720 31 2046 32736 63488 31 36860 16369 63488 31 36860 16369 63488 15 57336 8187 61440 15 65529 40959 61440 15 65521 36863 61440 15 65523 53247 61440 7 65507 5119
9 57344 7 65511 59391 57344 7 65479 58367 57344 7 65487 62463 57344 7 65511 59391 57344 3 65511 59391 49152 3 65523 53247 49152 3 65523 53247 49152 3 65529 40959 49152 1 65529 40959 32768 1 65532 16383 32768 1 65532 16383 32768 1 65534 32767 32768 0 65534 32767 0 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 65535 65535 0 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 0 6
55X35 65535 0 0 0 0 0 0 0 0 0 0 0 0 0)
X offset: 0@0)) shape: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 1 32768 0 0 3 49152 0 0 3 49152 0 0 7 57344 0 0 7 57344 0 0 15 61440 0 0 15 61440 0 0 31 63488 0 0 31 63488 0 0 63 64512 0 0 63 64512 0 0 127 65024 0 0 127 65024 0 0 255 65280 0 64 255 65280 512 96 511 65408 1536 112 511 65408 3584 120 1023 65472 7680 124 1023 65472 15872 126 2047 65504 32256 126 2047 65504 32256 63 4095 65520 64512 63 36863 65521 64512 63 57343 65531 64512 63 57343 65531 64512 31 65535 65535 63488 31 65535 65535 63488 31 65535 65535 63488 31 65535
65535 63488 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 15 65535 65535 61440 7 65535 65535 57344 7 65535 65535 57344 7 65535 65535 57344 7 65535 65535 57344 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535 32768 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 1 65535 65535 32768 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 655
35X 65535 49152 3 65535 65535 49152 3 65535 65535 49152 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'pawn'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 32768 0 0 7 57344 0 0 15 61440 0 0 31 63488 0 0 63 64512 0 0 63 64512 0 0 63 64512 0 0 63 64512 0 0 63 64512 0 0 31 63488 0 0 15 61440 0 0 7 57344 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 3 49152 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 15 61440 0 0 15 61440 0 0 15 61440 0 0 15 61440 0 0 31 63488 0 0 31 63488 0 0 31
63488 0 0 63 64512 0 0 63 64512 0 0 127 65024 0 0 255 65280 0 0 511 65408 0 0 1023 65472 0 0 4095 65520 0 0 16383 65532 0 0 32767 65534 0 0 28672 14 0 0 32767 65534 0 0 32767 65534 0 0 32767 65534 0 0 28672 14 0 0 32767 65534 0 0 16383 65532 0 0 0 0 0 0 0 0 0 0 0 0 0)
X offset: 0@0)) shape: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 32768 0 0 7 57344 0 0 15 61440 0 0 31 63488 0 0 63 64512 0 0 127 65024 0 0 127 65024 0 0 127 65024 0 0 127 65024 0 0 127 65024 0 0 63 64512 0 0 31 63488 0 0 15 61440 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 7 57344 0 0 15 61440 0 0 15 61440 0 0 15 61440 0 0 15 61440 0 0 15 61440 0 0 31 63488 0 0 31 63488 0 0 31 63488 0 0 31 63488 0 0 63 64512 0 0
63 64512 0 0 63 64512 0 0 127 65024 0 0 127 65024 0 0 255 65280 0 0 511 65408 0 0 1023 65472 0 0 4095 65520 0 0 16383 65532 0 0 32767 65534 0 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 0 65535 65535 0 0 32767 65534 0 0 16383 65532 0 0 0 0 0 0 0 0 0)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'knight'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2778 49152 0 0 48725 32792 0 0 52731 28920 0 1 30719 56272 0 2 57343 16288 0 4 49151 65088 0 14 47103 64640 0 23 32767 64896 0 18 65535 65504 0 58 57343 65520 0 79 65535 65528 0 118 65535 65532 0 93 65535 65534 0 77 65535 65468 0 109 65535 65436 0 127 65535 65468 0 215 65535 65534 0 93 65535 65535 0 119 65519 65535 32768 213 65519 65535 49152 95 65527 65535 57344 439 65531 65535 61440 239 65533 65527 61440 119 65534 32763 63488 223 65534 8189 63488
181 65535 126 63488 223 65535 32799 30720 119 65535 32783 45056 223 65535 49159 49152 187 65535 49155 32768 175 65535 57344 0 119 65535 61440 0 223 65535 63488 0 187 65535 64512 0 239 65535 64512 0 87 65535 65024 0 53 65535 65280 0 91 65535 65280 0 46 65535 65408 0 39 32767 65408 0 29 65535 65472 0 11 32767 65504 0 10 65535 65520 0 15 49151 65520 0 2 65535 65528 0 1 16383 65532 0 0 65535 65532 0 0 65535 65535 0 1 65535 65535 32768 1 32768 1 32768 1 65535 65535 32768 1 65535 65535 32768 1 65535 65535 32768
1 X32768 1 32768 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0 0 0 0 0)
X offset: 0@0)) shape: ((Form
X extent: 64@64
X fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3510 49152 0 0 8191 57372 0 1 32767 63740 0 1 65535 64508 0 2 65535 65528 0 5 65535 65520 0 15 65535 65504 0 23 65535 65472 0 15 65535 65504 0 47 65535 65520 0 95 65535 65528 0 191 65535 65532 0 255 65535 65534 0 127 65535 65535 0 255 65535 65534 0 127 65535 65534 0 255 65535 65534 0 383 65535 65535 0 255 65535 65535 32768 511 65535 65535 49152 127 65535 65535 57344 511 65535 65535 61440 255 65535 65535 63488 511 65535 65535 63488 511 65535 65535 64512 255
65535 32767 64512 511 65535 40959 64512 511 65535 49279 64512 255 65535 49183 63488 511 65535 57359 61440 511 65535 57351 49152 255 65535 61443 32768 511 65535 63488 0 511 65535 64512 0 255 65535 65024 0 511 65535 65024 0 511 65535 65280 0 255 65535 65408 0 191 65535 65408 0 127 65535 65472 0 63 65535 65472 0 47 65535 65504 0 63 65535 65520 0 15 65535 65528 0 31 65535 65528 0 31 65535 65532 0 7 65535 65534 0 0 65535 65535 0 1 65535 65535 32768 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 6
55X35 65535 49152 3 65535 65535 49152 3 65535 65535 49152 3 65535 65535 49152 1 65535 65535 32768 0 65535 65535 0 0 0 0 0 0 0 0 0)
X offset: 0@0))); yourself); add: (Association basicNew instVarAt: 1 put: 'smallqueen'; instVarAt: 2 put: (OpaqueForm figure: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 0 0 1 32768 1 32768 3 49152 3 49152 7 57344 7 57344 1039 61472 1551 61536 542 30784 798 30912 445 48512 509 49024 505 40832 497 36736 249 40704 253 48896 253 48896 254 32512 254 32512 127 65024 127 65024 127 65024 127 65024 0 0 255 65280 0 0 255 65280 0 0)
X offset: 0@0)) shape: ((Form
X extent: 32@32
X fromArray: #( 0 0 0 0 0 0 1 32768 3 49152 3 49152 7 57344 7 57344 15 61440 3087 61488 3615 63600 3871 63728 1855 64736 1983 64992 1023 65472 1023 65472 1023 65472 1023 65472 511 65408 511 65408 511 65408 511 65408 511 65408 255 65280 255 65280 255 65280 255 65280 511 65408 511 65408 511 65408 511 65408 511 65408)
X offset: 0@0))); yourself); yourself)SHAR_EOF
chmod 0644 icons.st || echo "restore of icons.st fails"
echo "x - extracting Games-ChequerBoard.st (Text)"
sed 's/^X//' << 'SHAR_EOF' > Games-ChequerBoard.st &&
X"This goodie provides a game of chess and a draught board. To get the computer to play you will have to file in UnixPipes.st. See ChequerBoard open for how to start up a view of a chess or draughts game"!
X
XObject subclass: #ChequerBoardPiece
X instanceVariableNames: 'icon colour position '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
XChequerBoardPiece comment:
X'I am an abstract superclass for checker-board game pieces.
X
X
XInstance Variables
X icon <DisplayObject> image used to display the receiver in the
X user interface
X colour <#write|#black> colour of receiver
X position <Point> receiver''s position in some board'!
X
X
X!ChequerBoardPiece methodsFor: 'accessing'!
X
Xcolour
X "Return the piece's colour"
X ^colour!
X
Xicon
X "Return the piece's icon"
X ^icon!
X
Xposition
X "Get the position of the piece"
X ^position!
X
Xposition: aPoint
X "Set the position of the piece"
X position _ aPoint! !
X
X!ChequerBoardPiece methodsFor: 'moving'!
X
XhasLegalMovesIn: board
X "Return true if this piece has legal moves, false if none"
X board positionsDo: [:square|
X (self isLegalMoveTo: square in: board) ifTrue: [^true]].
X
X ^false!
X
XisLegalMoveTo: newPosition in: board
X "Subclasses must define this"
X ^self subclassResponsibility!
X
XlegalMovesIn: board
X "Return a collection of legal moves in a particular position"
X | moves |
X moves _ OrderedCollection new: 32.
X board positionsDo: [:square|
X (self isLegalMoveTo: square in: board) ifTrue: [
X moves addLast: square]].
X
X ^moves!
X
XmoveTo: aPosition in: board
X "Actually move the receiver"
X self position: aPosition! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XChequerBoardPiece class
X instanceVariableNames: ''!
X
X
X!ChequerBoardPiece class methodsFor: 'instance creation'!
X
Xnew: colourSymbol size: sizeSymbol
X "Return an initialized chess piece"
X ((#(white black) includes: colourSymbol)
X and: [#(large small) includes: sizeSymbol]) ifFalse: [
X self error: 'size must be #large or #small and colour must be #black or #white'].
X ^self new initialize: colourSymbol size: sizeSymbol! !
X
XObject subclass: #ChequerBoardGamePlayer
X instanceVariableNames: 'colour '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
XChequerBoardGamePlayer comment:
X'I am an abstract superclass for checquer-board game players.
XInstance Variables
X colour <#white|#black> which colour pieces the receiver is playing'!
X
X
X!ChequerBoardGamePlayer methodsFor: 'instance initialization'!
X
Xinitialize: colourSymbol
X "Initialize myself. Return self if initialization succeeds, nil otherwise"
X colour _ colourSymbol.
X ^self! !
X
X!ChequerBoardGamePlayer methodsFor: 'accessing'!
X
Xcolour
X "Return the colour of pieces this player is playing"
X ^colour!
X
Xundo
X "Try to undo up to the start of the opponent's last move.
X Return true if this was possible, false if not"
X ^false! !
X
X!ChequerBoardGamePlayer methodsFor: 'playing'!
X
XopponentPlayedFrom: oldPosition to: newPosition
X "Subclass instances may need to know what their opponent did!!"
X ^self subclassResponsibility!
X
Xplay
X "Subclasses should define this method to return a move, an association key: old position value: new position"
X ^self subclassResponsibility! !
X
XController subclass: #ChequerBoardController
X instanceVariableNames: 'player playerPlaying playersMove '
X classVariableNames: 'YellowButtonMenu '
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
XChequerBoardController comment:
X'I am a controller for a chequer-board game such as chess.
XI provide
X red-button piece moving
X red-button + left shift to indicate a piece''s legal moves
X ctrl to indicate all pieces with legal moves
X yellow button menu (reset,replay)
X
XInstance Variables
X player <ChequerBoardGamePlayer|nil> if not nil the player is the user''s opponent
X playerPlaying <Boolean> if true the player is currently making a move
X playersMove <Assocition|nil> holds the player''s move when the player makes one'!
X
X
X!ChequerBoardController methodsFor: 'intialize-release'!
X
Xrelease
X "The player may be to be released"
X player notNil ifTrue: [player release].
X ^super release! !
X
X!ChequerBoardController methodsFor: 'control activities'!
X
XcontrolActivity
X "Check for mouse buttons"
X self viewHasCursor ifTrue: [
X view setGo.
X self playersTurn ifTrue: [^self].
X sensor redButtonPressed ifTrue: [^self redButtonActivity].
X sensor yellowButtonPressed ifTrue: [^self yellowButtonActivity].
X sensor ctrlDown ifTrue: [
X view highlightPiecesWithLegalMovesWhile: [sensor ctrlDown]]].
X ^super controlActivity!
X
XplayersTurn
X "If there's a player and its the player's turn, fork a process to wait for their move.
X If the player has moved, inform the model & get the view to display that move."
X
X (player isNil or: [player colour ~= model turn]) ifTrue: [^false].
X
X "If the player is not yet playing fork a process to wait for their play"
X playerPlaying ifFalse: [
X playerPlaying _ true.
X Cursor wait show.
X [playersMove _ player play] fork.
X ^true].
X
X "Player is playing, but has not yet completed the move.
X Ensure the wait cursor is showing"
X playersMove isNil ifTrue: [
X Cursor wait show.
X ^true].
X
X "Player has supplied a move so lets update the game"
X playerPlaying _ false.
X Cursor normal show.
X (model isLegalMoveFrom: playersMove key to: playersMove value) ifFalse: [
X view topView newLabel: model label, ' opponent made an illegal move'.
X player undo ifFalse: [
X player release.
X player _ nil.
X ^false]].
X view
X animatePiece: (model pieceAt: playersMove key)
X from: playersMove key
X to: playersMove value.
X model movePieceAt: playersMove key to: playersMove value.
X playersMove _ nil.
X ^true!
X
XredButtonActivity
X "Try and pick up a piece"
X | square piece newSquare |
X square _ view squareForDisplayPoint: sensor cursorPoint.
X (square notNil and: [(piece _ model pieceAt: square) notNil]) ifTrue: [
X sensor leftShiftDown ifTrue: [
X "Display the valid moves if the shift is held down"
X (view
X highlightLegalMovesFor: piece
X while: [
X square = (view squareForDisplayPoint: sensor cursorPoint)
X and: [sensor redButtonPressed]]) ifFalse: [^self].
X sensor redButtonPressed ifFalse: [^self]].
X
X view displaySquareForMoving: square.
X piece icon
X follow: [sensor cursorPoint - (piece icon extent // 2)]
X while: [sensor redButtonPressed].
X newSquare _ view squareForDisplayPoint: sensor cursorPoint.
X ((model movePieceAt: square to: newSquare)
X and: [player notNil])
X ifTrue: [player opponentPlayedFrom: square to: newSquare].
X view displayPieceAt: square]!
X
XyellowButtonActivity
X "Pop up a menu"
X "YellowButtonMenu _ nil"
X | selection selector |
X YellowButtonMenu isNil ifTrue: [
X YellowButtonMenu _ ActionMenu
X labels: 'show last move\undo\replay\reset\play white\play black' withCRs
X lines: #(1 4)
X selectors: #(showLastMove undo replay reset playWhite playBlack)].
X selection _ YellowButtonMenu startUp.
X selection ~= 0 ifTrue: [
X self perform: (YellowButtonMenu selectorAt: selection)]! !
X
X!ChequerBoardController methodsFor: 'menu messages'!
X
XplayBlack
X "Start up a player to play the black pieces"
X self reset.
X view userPlays: #white.
X player _ model playerForColour: #black.
X player isNil ifTrue: [self notify: 'No player available']!
X
XplayWhite
X "Start up a player to play the white pieces"
X self reset.
X view userPlays: #black.
X player _ model playerForColour: #white.
X player isNil ifTrue: [self notify: 'No player available']!
X
Xreplay
X "Replay the game"
X model replay!
X
Xreset
X "Reset the game"
X player notNil ifTrue: [player release. player _ nil].
X model reset!
X
XshowLastMove
X "Show the last piece that moved"
X
X model lastMove isNil ifTrue: [^view flash].
X view
X animatePiece: (model pieceAt: model lastMove value)
X from: model lastMove key
X to: model lastMove value!
X
Xundo
X "Try and undo"
X (player notNil and: [player undo not]) ifTrue: [^view flash].
X model undo! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XChequerBoardController class
X instanceVariableNames: ''!
X
X
X!ChequerBoardController class methodsFor: 'class initialization'!
X
Xinitialize
X "Initialize my yellow button menu"
X "ChessBoardController initialize"
X YellowButtonMenu _ ActionMenu
X labels: 'undo\replay\reset\play white\play black' withCRs
X lines: #(3)
X selectors: #(undo replay reset playWhite playBlack)! !
X
XChequerBoardController initialize!
X
X
XModel subclass: #ChequerBoard
X instanceVariableNames: 'pieceSize board history turn '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
XChequerBoard comment:
X'I am an abstract superclass for chequer-board games such as chess.
X
X
XInstance Variables
X pieceSize <#large|#small> size of pieces used in user interface
X board <Array of Array of <ChequerBoardPiece|nil>> a two-dimensional array holding the state of a game
X history <OrderedCollection of Point -> Point> the sequence of moves in the current game held as square -> square
X turn <#write|#black> whose turn it is'!
X
X
X!ChequerBoard methodsFor: 'controlling'!
X
Xreplay
X "Replay the game. Implement this by replaying history!!"
X | theMoves |
X theMoves _ history copy.
X self reset.
X theMoves do: [:move|
X self reallyMovePieceAt: move key to: move value.
X self changed: #move with: move]!
X
Xreset
X "Reset my board to the initial state"
X self initialize: pieceSize.
X self changed: #board!
X
Xundo
X "Undo a move. Implement this by replaying history!!"
X | theMoves |
X theMoves _ history copyFrom: 1 to: history size - 1.
X self reset.
X theMoves do: [:move|
X self movePieceAt: move key to: move value.
X self changed: #position with: move key]! !
X
X!ChequerBoard methodsFor: 'accessing'!
X
Xextent
X "Return the board's extent"
X ^8@8!
X
Xlabel
X "Return a string for a view label"
X
X ^self class name
X copyFrom: 1
X to: (self class name
X indexOfSubCollection: 'Board'
X startingAt: 2) - 1!
X
XlastMove
X "Return the last move"
X ^history isEmpty ifFalse: [history last]!
X
XpieceAt: positionPoint
X "Return the piece at positionPoint on the board"
X ^(board at: positionPoint x) at: positionPoint y!
X
XpieceAt: positionPoint put: aPiece
X "Set the position of the piece on the board"
X (board at: positionPoint x) at: positionPoint y put: aPiece.
X aPiece notNil ifTrue: [aPiece position: positionPoint].
X ^aPiece!
X
XpieceSize
X "Return the largest extent enclosing all pieces"
X ^board inject: 0@0 into: [:extent1 :row|
X row inject: extent1 into: [:extent2 :piece|
X piece == nil ifTrue: [extent2] ifFalse: [extent2 max: piece icon extent]]]!
X
Xturn
X "Return whose turn it is"
X ^turn! !
X
X!ChequerBoard methodsFor: 'playing'!
X
XplayerForColour: colourSymbol
X "Return a player for our game or nil if one does not exist"
X ^nil! !
X
X!ChequerBoard methodsFor: 'moving'!
X
XauxiliaryMovePieceAt: oldPosition to: newPosition
X "Move a piece as an auxilliary move (e.g. in chess this is the rook move when a king castles)"
X
X | piece |
X piece _ self pieceAt: oldPosition.
X self pieceAt: oldPosition put: nil.
X piece moveTo: newPosition in: self.
X self pieceAt: newPosition put: piece.
X self changed: #position with: oldPosition.
X self changed: #position with: newPosition!
X
XisLegalMoveFrom: oldPosition to: newPosition
X "Answer whether its legal for the piece at oldPosition to move to newPosition. The piece is best qualified to answer this question!!"
X | piece |
X piece _ self pieceAt: oldPosition.
X piece isNil ifTrue: [^false].
X ^piece isLegalMoveTo: newPosition in: self!
X
XmovePieceAt: oldPosition to: newPosition
X "Try to move a piece on the board. broadcast change information."
X
X (self reallyMovePieceAt: oldPosition to: newPosition) ifTrue: [
X self changed: #position with: history last key.
X self changed: #position with: history last value.
X ^true].
X self changed: #badMove.
X ^false!
X
XreallyMovePieceAt: oldPosition to: newPosition
X "Try to move a piece on the board. Don't broadcast changes"
X
X | piece |
X piece _ self pieceAt: oldPosition.
X (piece isLegalMoveTo: newPosition in: self) ifFalse: [^false].
X
X self pieceAt: oldPosition put: nil.
X piece moveTo: newPosition in: self.
X self pieceAt: newPosition put: piece.
X
X history addLast: oldPosition -> newPosition.
X turn _ turn == #white ifTrue: [#black] ifFalse: [#white].
X ^true!
X
XremovePieceAt: position
X "Take the piece at position. e.g. in Chess this is for en passante"
X self pieceAt: position put: nil.
X self changed: #position with: position!
X
Xwith: piece movedTo: newPosition evaluate: aBlock
X "Evaluate aBlock if the piece did move to newPosition"
X | savedPosition takenPiece result |
X savedPosition _ piece position.
X takenPiece _ self pieceAt: newPosition.
X self pieceAt: newPosition put: piece.
X self pieceAt: savedPosition put: nil.
X result _ aBlock value.
X self pieceAt: newPosition put: takenPiece.
X self pieceAt: savedPosition put: piece.
X piece position: savedPosition.
X ^result! !
X
X!ChequerBoard methodsFor: 'enumerating'!
X
XpositionsDo: aBlock
X "Evaluate aBlock for all positions on a chess board"
X | x y |
X x _ 0.
X [(x _ x + 1) <= 8] whileTrue: [
X y _ 0.
X [(y _ y + 1) <= 8] whileTrue: [
X aBlock value: x@y]]! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XChequerBoard class
X instanceVariableNames: ''!
X
X
X!ChequerBoard class methodsFor: 'instance creation'!
X
XnewOfSize: sizeSymbol
X "Create a new initialized board with sizeSymbol sized pieces"
X ^self new initialize: sizeSymbol!
X
Xopen
X "Open a StandardSystemView on a chequer board game."
X ChequerBoardView
X openOn: (self newOfSize: (Display height > 600
X ifTrue: [#large]
X ifFalse: [#small]))
X
X "ChequerBoardView openOn: (ChessBoard newOfSize: #large)"
X "ChequerBoardView openOn: (ChessBoard newOfSize: #small)"
X
X "ChequerBoardView openOn: (DraughtsBoard newOfSize: #large)"
X "ChequerBoardView openOn: (DraughtsBoard newOfSize: #small)"! !
X
XView subclass: #ChequerBoardView
X instanceVariableNames: 'squareExtent userColour labelFont '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
XChequerBoardView comment:
X'I am a view onto an M by N chequer-board (e.g. an 8x8 chess board). My model is some subclass of ChequerBoard. My controller should be an instance of ChequerBoardController.
X
XInstance Variables
X squareExtent <Point> cached extent of a square computed
X whenever inset display box changes.
X userColour <#write|#black> colour of pieces the user is playing.
X This is used to determine which way to
X draw the board so that the user''s pieces
X are always at the ''bottom'' of the board.
X labelFont <StrikeFont> font used to label the border with square
X positions'!
X
X
X!ChequerBoardView methodsFor: 'instance initialization'!
X
Xinitialize
X "Initialize the user's colour which is used to determine which way up to draw the board"
X super initialize.
X userColour _ #white.
X labelFont _ self class borderLabelFont! !
X
X!ChequerBoardView methodsFor: 'displaying'!
X
XdisplayBoard
X "Display the board by displaying the top left 4 squares & copying"
X | box blitter height width |
X 1 to: 2 do: [:n|
X userColour == #white
X ifTrue: [
X self displaySquare: n@ model extent y;
X displaySquare: n@(model extent y - 1)]
X ifFalse: [
X self displaySquare: model extent x@n;
X displaySquare: model extent x - 1@n]].
X box _ self insetDisplayBox.
X width _ squareExtent x * 2.
X height _ squareExtent y * 2.
X "Now smear top corner down left-hand side"
X blitter _ BitBlt
X destForm: Display
X sourceForm: Display
X halftoneForm: nil
X combinationRule: Form over
X destOrigin: box origin + (0@height)
X sourceOrigin: box origin
X extent: width @ height
X clipRect: box.
X [blitter copyBits.
X height _ height * 2.
X blitter destOrigin: box origin + (0@height);
X height: height.
X box top + height < box bottom] whileTrue.
X
X "Now smear left-hand side across"
X [blitter
X destOrigin: box origin + (width@0);
X width: width;
X copyBits.
X width _ width * 2.
X box left + width < box right] whileTrue!
X
XdisplayBorder
X "Label the board positions in the border"
X
X | label box |
X super displayBorder.
X box _ self displayBox.
X 1 to: model extent x do: [:x | | glyph offset index |
X index _ userColour == #white ifTrue: [x] ifFalse: [model extent x - x + 1].
X glyph _ labelFont characterFormAt: (Character value: $a asciiValue - 1 + index).
X offset _ squareExtent x * (x - 0.5)@0 - (glyph extent // 2).
X glyph
X displayOn: Display
X at: self insetDisplayBox topLeft + offset + (0 @ (borderWidth top negated // 2))
X clippingBox: box
X rule: Form reverse
X mask: nil.
X glyph
X displayOn: Display
X at: self insetDisplayBox bottomLeft + offset + (0 @ (borderWidth bottom // 2))
X clippingBox: box
X rule: Form reverse
X mask: nil].
X 1 to: model extent y do: [:y | | glyph offset index |
X index _ userColour == #white ifTrue: [model extent y - y + 1] ifFalse: [y].
X glyph _ labelFont characterFormAt: (Character digitValue: index).
X offset _ 0@(squareExtent y * (y - 0.5)) - (glyph extent // 2).
X glyph
X displayOn: Display
X at: self insetDisplayBox topLeft + offset + (borderWidth left negated // 2 @0)
X clippingBox: box
X rule: Form reverse
X mask: nil.
X glyph
X displayOn: Display
X at: self insetDisplayBox topRight + offset + (borderWidth right // 2 @ 0)
X clippingBox: box
X rule: Form reverse
X mask: nil]!
X
XdisplayPieceAt: square
X "Display the piece at square if any"
X
X ^self displayPieceAt: square mask: nil!
X
XdisplayPieceAt: square mask: maskForm
X "Display the piece at square if any, with maskForm"
X
X | piece box |
X box _ self displaySquare: square.
X (piece _ model pieceAt: square) notNil ifTrue: [
X piece icon
X displayOn: Display
X at: box origin + (squareExtent - piece icon extent // 2)
X clippingBox: box
X rule: Form over
X mask: maskForm].
X ^box!
X
XdisplayPieces
X "Draw a chequer board & display the pieces therein"
X model positionsDo: [:square| | box piece |
X (piece _ model pieceAt: square) notNil ifTrue: [
X box _ self displayBoxForSquare: square.
X piece icon
X displayOn: Display
X at: box origin + (squareExtent - piece icon extent // 2)
X clippingBox: box]]!
X
XdisplaySquare: aPoint
X "Fill the square at aPoint with the relevant colour"
X | box darkSquare |
X box _ self displayBoxForSquare: aPoint.
X darkSquare _ (aPoint x + aPoint y) even.
X Display
X fill: box
X rule: (darkSquare
X ifTrue: [12 "not source"]
X ifFalse: [3 "source"])
X mask: Form veryLightGray.
X Display
X border: box
X width: 1
X mask: (darkSquare ifTrue: [Form black] ifFalse: [Form white]).
X ^box!
X
XdisplaySquareForMoving: aPoint
X "Display the square and piece at aPoint.
X Halftone the piece to indicate moving"
X ^self displayPieceAt: aPoint mask: Form gray!
X
XdisplayView
X "Draw a chequer board & display the pieces therein"
X self displayBoard.
X self displayPieces! !
X
X!ChequerBoardView methodsFor: 'highlighting'!
X
XhighlightLegalMovesFor: piece while: aBlock
X "Compute the legal moves for a piece.
X While aBlock returns true highlight the display.
X Return true if there were legal positions, false otherwise"
X | squares |
X squares _ (piece legalMovesIn: model)
X collect: [:position| self displayBoxForSquare: position].
X [squares isEmpty not and: aBlock] whileTrue: [
X 2 timesRepeat: [
X squares do: [:square| Display reverse: square].
X (Delay forMilliseconds: 100) wait]].
X
X ^squares size > 0!
X
XhighlightPiecesWithLegalMovesWhile: aBlock
X "Compute the pieces with legal moves.
X While aBlock returns true highlight the display.
X Return true if there were pieces with legal moves, false otherwise"
X | squares |
X squares _ OrderedCollection new: 32.
X model positionsDo: [:square| | piece |
X ((piece _ model pieceAt: square) notNil
X and: [piece hasLegalMovesIn: model]) ifTrue: [
X squares addLast: (self displayBoxForSquare: square)]].
X [squares isEmpty not and: aBlock] whileTrue: [
X 2 timesRepeat: [
X squares do: [:square| Display reverse: square].
X (Delay forMilliseconds: 100) wait]].
X
X ^squares size > 0! !
X
X!ChequerBoardView methodsFor: 'animation'!
X
XanimatePiece: aPiece from: oldPos to: newPos
X "Animate the move"
X | icon displayPoint delta count newBox |
X icon _ aPiece icon.
X displayPoint _ (self displaySquareForMoving: oldPos) center rounded.
X delta _ (newBox _ self displaySquare: newPos) center rounded - displayPoint.
X count _ delta r / 4.
X delta _ delta / count.
X icon
X follow: [displayPoint rounded - (icon extent // 2)]
X while: [
X displayPoint _ displayPoint + delta.
X (count _ count - 1) >= 1].
X icon
X displayOn: Display
X at: displayPoint rounded - (icon extent // 2)
X clippingBox: newBox.
X self displaySquare: oldPos! !
X
X!ChequerBoardView methodsFor: 'accessing'!
X
XdisplayBoxForSquare: aPoint
X "Return the displayBox for the square at aPoint.
X The board's coordinate space has y growing up."
X | origin transformedPoint |
X transformedPoint _ userColour == #white
X ifTrue: [aPoint x - 1 @ (model extent y - aPoint y)]
X ifFalse: [model extent x - aPoint x @ (aPoint y - 1)].
X origin _ squareExtent * transformedPoint + self insetDisplayBox origin.
X ^Rectangle origin: origin corner: origin + squareExtent!
X
XsetGo
X "Ensure that my topView's label indicates whose go it is"
X | newLabel |
X newLabel _ model label, ' (', model turn, ' to move)'.
X newLabel ~= self topView label ifTrue: [
X self topView newLabel: newLabel]!
X
XsquareForDisplayPoint: aPoint
X "Return the square corresponding to aPoint"
X | point |
X ^(self insetDisplayBox containsPoint: aPoint) ifTrue: [
X point _ aPoint - self insetDisplayBox origin // squareExtent.
X userColour == #white
X ifTrue: [point x + 1 @ (model extent y - point y)]
X ifFalse: [model extent x - point x @ (point y + 1)]]!
X
XuserPlays: colourSymbol
X "Set the colour the user plays & arrange to display the board so the user's pieces are at the bottom"
X userColour ~~ colourSymbol ifTrue: [
X userColour _ colourSymbol.
X self display]! !
X
X!ChequerBoardView methodsFor: 'controller access'!
X
XdefaultControllerClass
X "I like to be controlled by a ChequerBoardController"
X ^ChequerBoardController! !
X
X!ChequerBoardView methodsFor: 'updating'!
X
Xupdate: aParameter with: anArgument
X "Handle updates from my model"
X aParameter == #board ifTrue: [^self displayView].
X aParameter == #badMove ifTrue: [^self "flash""flash is too painful for words!!"].
X aParameter == #move ifTrue: [
X ^self animatePiece: (model pieceAt: anArgument value) from: anArgument key to: anArgument value].
X aParameter == #position ifTrue: [
X (anArgument isKindOf: Point) ifTrue: [^self displayPieceAt: anArgument]].
X ^super update: aParameter with: anArgument! !
X
X!ChequerBoardView methodsFor: 'private'!
X
XcomputeInsetDisplayBox
X "Compute the view's squareExtent whenever the insetDisplayBox is changed"
X | box |
X box _ super computeInsetDisplayBox.
X squareExtent _ box extent // model extent.
X ^box! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XChequerBoardView class
X instanceVariableNames: ''!
X
X
X!ChequerBoardView class methodsFor: 'instance creation'!
X
XopenOn: aChequerBoard
X "Open a StandardSystemView on a chequer board game"
X | borderWidth topView size |
X borderWidth _ (self borderLabelFont height * 1.2) rounded. "use border to label positions"
X size _ aChequerBoard pieceSize
X + 4 "2 pixel border each square"
X * 8 "8x8 board"
X + 2 "1 pixel top border"
X + (borderWidth * 2). "label border"
X topView _ StandardSystemView
X model: aChequerBoard
X label: aChequerBoard label
X minimumSize: size.
X "Ensure board fits on Display"
X size _ size min: ((Display width min: Display height) - topView labelDisplayBox height - 2 - (2 * borderWidth) // 8 * 8 + 2 + (2 * borderWidth)) asPoint.
X topView minimumSize: size.
X topView maximumSize: size.
X topView
X addSubView: (self new model: aChequerBoard)
X in: (0@0 corner: 1@1)
X borderWidth: borderWidth.
X topView controller open! !
X
X!ChequerBoardView class methodsFor: 'accessing'!
X
XborderLabelFont
X "Return a TextStyle to use for displaying position labels"
X
X ^(TextStyle styleNamed: #small ifAbsent: [TextStyle default]) fontAt: 2! !
X
XChequerBoardGamePlayer subclass: #UnixChessPlayer
X instanceVariableNames: 'pipeStream '
X classVariableNames: 'ChessCommand '
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!UnixChessPlayer methodsFor: 'instance initialization'!
X
Xinitialize: colourSymbol
X "Initialize myself to use Unix chess(6) to play chess"
X
X | command prompt |
X super initialize: colourSymbol.
X
X ChessCommand isNil ifTrue: [ChessCommand _ '/usr/games/chess'].
X (command _ FillInTheBlank
X request: 'Chess command?'
X initialAnswer: ChessCommand) isEmpty ifTrue: [^nil].
X
X pipeStream _ UnixPipeStream on: (ChessCommand _ command).
X (prompt _ pipeStream upTo: Character cr) ~= 'Chess' ifTrue: [
X self error: 'Chess expected!! Received ' , prompt.
X ^nil].
X colour == #white ifTrue: [
X pipeStream nextPutAll: 'first'; nextPut: Character cr; flush]! !
X
X!UnixChessPlayer methodsFor: 'initialize-release'!
X
Xrelease
X "Release the pipe stream"
X pipeStream close.
X pipeStream _ nil.
X super release! !
X
X!UnixChessPlayer methodsFor: 'playing'!
X
XopponentPlayedFrom: oldPosition to: newPosition
X "Translate the move into notation & squirt it at chess(6)"
X pipeStream
X nextPut: (Character value: $a asciiValue - 1 + oldPosition x);
X nextPut: (Character digitValue: oldPosition y);
X nextPut: (Character value: $a asciiValue - 1 + newPosition x);
X nextPut: (Character digitValue: newPosition y);
X nextPut: Character cr;
X flush.
X "Chess now prints the move, so skip it"
X Transcript show: (pipeStream upTo: Character cr); cr!
X
Xplay
X "Read a move from the playing program & return the move"
X | move |
X [move _ pipeStream upTo: Character cr.
X Transcript show: move; cr.
X move = 'Resign' ifTrue: [^nil].
X move = 'eh?' ifTrue: [self error: 'Player is confused'].
X "chess(6) will say various things as well as moving.
X Ignore them."
X move first isDigit] whileFalse.
X (move includes: $/) ifTrue: [^self parseTradMove: move].
X ^Association
X key: (move at: move size - 3) asciiValue - $a asciiValue + 1
X @ (move at: move size - 2) digitValue
X value: (move at: move size - 1) asciiValue - $a asciiValue + 1
X @ (move at: move size) digitValue! !
X
X!UnixChessPlayer methodsFor: 'private'!
X
XparseTradMove: move
X "Until Unix chess gets a move in algebraic notation it spits out yuckky traditional n/kn1-kb3 style notation. If it plays first it hasn't switched to algebraic. So we must be able to parse the first move in yuck form"
X
X | stream sx sy dx dy |
X stream _ ReadStream on: move.
X stream skipTo: $/.
X sx _ #('qr' 'qn' 'qb' 'q' 'k' 'kb' 'kn' 'kr') indexOf: (stream upToAny: '12345678').
X stream skip: -1.
X sy _ stream next digitValue.
X stream next.
X dx _ #('qr' 'qn' 'qb' 'q' 'k' 'kb' 'kn' 'kr') indexOf: (stream upToAny: '12345678').
X stream skip: -1.
X dy _ stream next digitValue.
X ^Association key: sx@sy value: dx@dy! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XUnixChessPlayer class
X instanceVariableNames: ''!
X
X
X!UnixChessPlayer class methodsFor: 'instance creation'!
X
Xcolour: colourSymbol
X "Return a chess player"
X ^super new initialize: colourSymbol! !
X
XChequerBoardPiece subclass: #ChessPiece
X instanceVariableNames: 'moved '
X classVariableNames: 'Icons '
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!ChessPiece methodsFor: 'instance initialization'!
X
Xinitialize: colourSymbol size: sizeSymbol
X "Initialize the piece"
X colour _ colourSymbol.
X icon _ self class iconOfSize: sizeSymbol colour: colourSymbol kind: self class name.
X moved _ false! !
X
X!ChessPiece methodsFor: 'accessing'!
X
Xmoved
X "Answer wether the receiver has moved"
X ^moved! !
X
X!ChessPiece methodsFor: 'moving'!
X
XisLegalMoveTo: newPosition in: board
X "A move is legal when
X a) its your turn
X b) the move wouldn't take one of your own pieces
X (this check also ensures oldPosition ~= newPosition)
X c) the move is a potential move for this piece
X d) the move wouldn't leave your king in check"
X "a" ^colour == board turn
X "b" and: [| piece |
X ((piece _ board pieceAt: newPosition) isNil
X or: [piece colour ~~ colour])
X "c" and: [(self isPotentialMoveTo: newPosition in: board)
X "d" and: [board
X with: self
X movedTo: newPosition
X evaluate: [((board kingOfColour: colour)
X inCheckIn: board) not]]]]!
X
XisPotentialMoveTo: newPosition in: board
X "This method should check if the receiver can do this move
X irrespective of uncovering check or taking the wrong colour."
X ^self subclassResponsibility!
X
XmoveTo: aPosition in: board
X "Maintain moved flag"
X moved _ true.
X super moveTo: aPosition in: board! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XChessPiece class
X instanceVariableNames: ''!
X
X
X!ChessPiece class methodsFor: 'class initialization'!
X
Xinitialize
X "Initialize the icons. Create large & small versions of the black & white pieces"
X
X "ChessPiece initialize"
X
X Icons _ Dictionary new.
X Icons at: #large put: Dictionary new.
X Icons at: #small put: Dictionary new.
X Icons do: [:dict|
X dict at: #white put: Dictionary new.
X dict at: #black put: Dictionary new].
X #(Bishop King Knight Pawn Queen Rook) do: [:piece| | icon whiteFigure |
X icon _ DisplayObject readFrom: '/official/smalltalk/BrouHaHa/images/', piece asLowercase, '.icon'.
X self iconOfSize: #large
X colour: #black
X kind: piece
X put: icon.
X whiteFigure _ icon figure deepCopy.
X icon shape displayOn: whiteFigure at: 0@0 rule: Form reverse.
X self iconOfSize: #large
X colour: #white
X kind: piece
X put: (OpaqueForm figure: whiteFigure shape: icon shape).
X icon _ DisplayObject readFrom: '/official/smalltalk/BrouHaHa/images/small', piece asLowercase, '.icon'.
X self iconOfSize: #small
X colour: #black
X kind: piece
X put: icon.
X whiteFigure _ icon figure deepCopy.
X icon shape displayOn: whiteFigure at: 0@0 rule: Form reverse.
X self iconOfSize: #small
X colour: #white
X kind: piece
X put: (OpaqueForm figure: whiteFigure shape: icon shape)]
X
X "#(large small) do: [:size|
X #(white black) do: [:colour|
X #(Bishop King Knight Pawn Queen Rook) do: [:piece|
X (self iconOfSize: size colour: colour kind: piece)
X displayAt: Sensor waitClickButton]]]"! !
X
X!ChessPiece class methodsFor: 'icon access'!
X
XiconOfSize: sizeSymbol colour: colourSymbol kind: kindSymbol
X "Get the icon for a particular piece of a size & colour"
X ^((Icons
X at: sizeSymbol
X ifAbsent: [Icons at: #large]) at: colourSymbol) at: kindSymbol!
X
XiconOfSize: sizeSymbol colour: colourSymbol kind: kindSymbol put: icon
X "Set the icon for a particular piece of a size & colour"
X ^((Icons at: sizeSymbol) at: colourSymbol) at: kindSymbol put: icon! !
X
XChessPiece initialize!
X
X
XChessPiece subclass: #Bishop
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!Bishop methodsFor: 'moving'!
X
XisPotentialMoveTo: newPosition in: board
X "I can move diagonally (+-x@+-x)"
X
X | delta absDelta unitDelta |
X
X absDelta _ (delta _ newPosition - position) abs.
X "Check move is diagonal"
X absDelta x ~= absDelta y ifTrue: [^false].
X
X "Check no other pieces in the way"
X unitDelta _ delta x sign @ delta y sign.
X (1 to: absDelta x - 1) do: [:n|
X (board pieceAt: position + (n * unitDelta)) notNil ifTrue: [^false]].
X ^true! !
X
XChequerBoard subclass: #ChessBoard
X instanceVariableNames: 'whiteKing blackKing '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!ChessBoard methodsFor: 'instance initialization'!
X
Xinitialize: sizeSymbol
X "Initialize the receiver with a correctly positioned set of pieces"
X pieceSize _ sizeSymbol.
X board _ (Array new: 8) collect: [:ea| Array new: 8].
X (1 to: 8) do: [:x|
X self pieceAt: x@2 put: (Pawn new: #white size: sizeSymbol).
X self pieceAt: x@7 put: (Pawn new: #black size: sizeSymbol)].
X #(1 8) do: [:x|
X self pieceAt: x@1 put: (Rook new: #white size: sizeSymbol).
X self pieceAt: x@8 put: (Rook new: #black size: sizeSymbol)].
X #(2 7) do: [:x|
X self pieceAt: x@1 put: (Knight new: #white size: sizeSymbol).
X self pieceAt: x@8 put: (Knight new: #black size: sizeSymbol)].
X #(3 6) do: [:x|
X self pieceAt: x@1 put: (Bishop new: #white size: sizeSymbol).
X self pieceAt: x@8 put: (Bishop new: #black size: sizeSymbol)].
X self pieceAt: 4@1 put: (Queen new: #white size: sizeSymbol).
X self pieceAt: 5@1 put: (whiteKing _ King new: #white size: sizeSymbol).
X self pieceAt: 4@8 put: (Queen new: #black size: sizeSymbol).
X self pieceAt: 5@8 put: (blackKing _ King new: #black size: sizeSymbol).
X
X history _ OrderedCollection new.
X turn _ #white! !
X
X!ChessBoard methodsFor: 'accessing'!
X
XkingOfColour: colour
X "Return the relevant king"
X
X ^colour == #white
X ifTrue: [whiteKing]
X ifFalse: [blackKing]!
X
XplayerForColour: colourSymbol
X "Get Unix to do the work and play the game!!"
X ^UnixChessPlayer colour: colourSymbol! !
X
XChequerBoardPiece subclass: #Draught
X instanceVariableNames: 'isKing '
X classVariableNames: 'LargeDot LargeInnerDot SmallDot SmallInnerDot '
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!Draught methodsFor: 'instance initialization'!
X
Xinitialize: colourSymbol size: sizeSymbol
X "Initialize the piece"
X
X | shape figure inner |
X colour _ colourSymbol.
X sizeSymbol == #large
X ifTrue: [
X shape _ LargeDot.
X inner _ LargeInnerDot]
X ifFalse: [
X shape _ SmallDot.
X inner _ SmallInnerDot].
X figure _ colour == #white
X ifTrue: [shape deepCopy]
X ifFalse: [Form extent: shape extent].
X inner displayOn: figure at: figure extent // 2 rule: Form reverse.
X icon _ OpaqueForm
X figure: figure
X shape: shape.
X isKing _ false! !
X
X!Draught methodsFor: 'testing'!
X
XcanTakeIn: board
X "Answer wether the receiver can take in its current position"
X board positionsDo: [:newPosition|
X ((newPosition - position) abs = (2@2)
X and: [self isLegalMoveTo: newPosition in: board]) ifTrue: [^true]].
X ^false! !
X
X!Draught methodsFor: 'moving'!
X
XisLegalMoveTo: newPosition in: board
X "A move is legal if
X its your turn and
X its 1 step diagonally to an empty square
X or its 2 steps diagonally over an opponent's piece"
X | delta piece |
X colour ~~ board turn ifTrue: [^false].
X (board pieceAt: newPosition) notNil ifTrue: [^false].
X delta _ newPosition - position.
X delta x abs = 1 ifTrue: [
X ^(delta y = (colour == #black ifTrue: [1] ifFalse: [-1])
X or: [isKing and: [delta y abs = 1]])
X and: [board takingPiece isNil]].
X
X delta x abs = 2 ifTrue: [
X ^(delta y = (colour == #black ifTrue: [2] ifFalse: [-2])
X or: [isKing and: [delta y abs = 2]])
X and: [(piece _ board pieceAt: position + (delta / 2)) notNil
X and: [piece colour ~~ colour
X and: [self == board takingPiece
X or: [board takingPiece isNil]]]]].
X
X "To end a sequence of takes, 'knock'. i.e. move the draught by 0"
X ^delta = (0@0) and: [self == board takingPiece]!
X
XmoveTo: aPosition in: board
X "Check for taking and kinging"
X
X | delta k |
X (delta _ aPosition - position) abs = (2 @ 2) ifTrue: [
X board removePieceAt: position + (delta / 2)].
X
X ((aPosition y = 8 or: [aPosition y = 1])
X and: [isKing not]) ifTrue: [
X isKing _ true.
X k _ (Text string: 'K' emphasis: 11) asParagraph.
X k
X displayOn: icon figure
X at: icon figure extent - k extent // 2
X rule: Form reverse].
X
X super moveTo: aPosition in: board! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XDraught class
X instanceVariableNames: ''!
X
X
X!Draught class methodsFor: 'class initialization'!
X
Xinitialize
X "Initialize the large & small dots"
X "Draught initialize"
X LargeDot _ Form dotOfSize: 64.
X LargeInnerDot _ Form dotOfSize: 60.
X SmallDot _ Form dotOfSize: 32.
X SmallInnerDot _ Form dotOfSize: 28.
X LargeDot offset: 0@0.
X SmallDot offset: 0@0! !
X
XDraught initialize!
X
X
XChessPiece subclass: #Knight
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!Knight methodsFor: 'moving'!
X
XisPotentialMoveTo: newPosition in: board
X "I can move +-2@+-1 or +-1@+-2"
X
X | delta |
X delta _ (newPosition - position) abs.
X ^delta = (2@1) or: [delta = (1@2)]! !
X
XChequerBoard subclass: #DraughtsBoard
X instanceVariableNames: 'lastTakingPiece lastMoveTookPiece '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!DraughtsBoard methodsFor: 'instance initialization'!
X
Xinitialize: sizeSymbol
X "Initialize the receiver with a correctly positioned set of pieces"
X pieceSize _ sizeSymbol.
X board _ (Array new: 8) collect: [:ea| Array new: 8].
X 1 to: 3 do: [:y|
X y + 1 \\ 2 + 1 to: 8 by: 2 do: [:x|
X self pieceAt: x@y put: (Draught new: #black size: pieceSize)]].
X 6 to: 8 do: [:y|
X y + 1 \\ 2 + 1 to: 8 by: 2 do: [:x|
X self pieceAt: x@y put: (Draught new: #white size: pieceSize)]].
X history _ OrderedCollection new.
X turn _ #black.
X lastMoveTookPiece _ false.
X lastTakingPiece _ nil! !
X
X!DraughtsBoard methodsFor: 'accessing'!
X
XtakingPiece
X "Return the piece that just took another piece"
X ^lastTakingPiece! !
X
X!DraughtsBoard methodsFor: 'moving'!
X
XmovePieceAt: oldPosition to: newPosition
X | piece |
X "Try to move a piece on the board"
X
X (super movePieceAt: oldPosition to: newPosition) ifTrue: [
X lastTakingPiece _ nil.
X lastMoveTookPiece ifTrue: [
X lastMoveTookPiece _ false.
X piece _ self pieceAt: newPosition.
X turn _ piece colour.
X (piece canTakeIn: self)
X ifTrue: [lastTakingPiece _ piece]
X ifFalse: [turn _ piece colour == #white
X ifTrue: [#black]
X ifFalse: [#white]]].
X ^true].
X ^false!
X
XremovePieceAt: aPosition
X "Remember that a piece was taken.
X If it was then the taker gets another go"
X lastMoveTookPiece _ (self pieceAt: aPosition) notNil.
X super removePieceAt: aPosition! !
X
XChessPiece subclass: #Queen
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!Queen methodsFor: 'moving'!
X
XisPotentialMoveTo: newPosition in: board
X "I can move +-x@+-x or 0@x or x@0"
X
X | delta absDelta unitDelta |
X
X absDelta _ (delta _ newPosition - position) abs.
X "Check move is diagonal or horizontal or vertical"
X (absDelta x ~= absDelta y
X and: [delta x ~= 0
X and: [delta y ~= 0]]) ifTrue: [^false].
X
X "Check no other pieces in the way"
X unitDelta _ delta x sign @ delta y sign.
X (1 to: (absDelta x max: absDelta y) - 1) do: [:n|
X (board pieceAt: position + (n * unitDelta)) notNil ifTrue: [^false]].
X ^true! !
X
XChessPiece subclass: #Rook
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!Rook methodsFor: 'moving'!
X
XisPotentialMoveTo: newPosition in: board
X "I can move x@0 or 0@x"
X
X | delta unitDelta |
X delta _ newPosition - position.
X (delta x ~= 0 and: [delta y ~= 0]) ifTrue: [^false].
X
X "Check no other pieces in the way"
X unitDelta _ delta x sign @ delta y sign.
X (1 to: (delta x + delta y) abs - 1) do: [:n|
X (board pieceAt: position + (n * unitDelta)) notNil ifTrue: [^false]].
X ^true! !
X
XChessPiece subclass: #King
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!King methodsFor: 'moving'!
X
XinCheckAt: newPosition in: board
X "Answer wether the king is in check in the current board.
X Do so by searching for a piece of the opposite colour which can
X take me"
X board positionsDo: [:square| | piece |
X ((piece _ board pieceAt: square) notNil
X and: [piece colour ~~ colour
X and: [piece isPotentialMoveTo: newPosition in: board]])
X ifTrue: [^true]].
X ^false!
X
XinCheckIn: board
X "Answer wether the king is in check in the current board."
X ^self inCheckAt: position in: board!
X
XisCastling: newPosition in: board
X "Check if the move is a castling. A Castling move is indicated by moving the king 2 to the left or right.
X I can only castle if
X a) I haven't moved
X b) My castling rook hasn't moved
X c) Castling does not cross check"
X | delta rookX rook deltaXSign |
X delta _ newPosition - position.
X rookX _ delta x > 0 ifTrue: [8] ifFalse: [1].
X rook _ board pieceAt: rookX@position y.
X
X (delta y ~= 0
X or: [delta x abs ~= 2
X or: [moved
X or: [(rook isKindOf: Rook) not
X or: [rook moved
X or: [rook colour ~~ colour]]]]]) ifTrue: [^false].
X
X deltaXSign _ delta x sign.
X position x + deltaXSign to: rookX - deltaXSign by: deltaXSign do: [:x| | pos |
X pos _ x@position y.
X ((board pieceAt: pos) notNil
X or: [self inCheckAt: pos in: board]) ifTrue: [^false]].
X
X ^true!
X
XisPotentialMoveTo: newPosition in: board
X "I can move 1 square in any direction or castle.
X When castling I cannot move across check."
X
X (newPosition - position) abs <= (1@1) ifTrue: [^true].
X
X ^self isCastling: newPosition in: board!
X
XmoveTo: newPosition in: board
X "Move the receiver.
X Check for castling"
X (self isCastling: newPosition in: board) ifTrue: [
X | deltaX |
X deltaX _ (newPosition - position) x.
X board auxiliaryMovePieceAt:
X (deltaX > 0 ifTrue: [8] ifFalse: [1]) @ position y
X to: (newPosition x - deltaX sign @ position y)].
X ^super moveTo: newPosition in: board! !
X
XChessPiece subclass: #Pawn
X instanceVariableNames: 'size movedTwo '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Games-ChequerBoard'!
X
X
X!Pawn methodsFor: 'instance initialization'!
X
Xinitialize: colourSymbol size: sizeSymbol
X "Remember my size so I can promote to a queen"
X size _ sizeSymbol.
X ^super initialize: colourSymbol size: sizeSymbol! !
X
X!Pawn methodsFor: 'moving'!
X
XisEnPassant: newPosition in: board
X "Answer wether the move to newPosition is en passant"
X | delta pawn |
X delta _ newPosition - position.
X ((colour == #white
X ifTrue: [1]
X ifFalse: [-1]) ~= delta y
X or: [delta x abs ~= 1]) ifTrue: [^false].
X
X ^(board pieceAt: newPosition) isNil
X and: [((pawn _ board pieceAt: position + (delta x@0)) isKindOf: Pawn)
X and: [pawn colour ~~ colour
X and: [pawn movedByTwo]]]!
X
XisPotentialMoveTo: newPosition in: board
X "I can move forward 1, move forward 2 if I haven't moved,
X or take 1 square diagonally, or en passant"
X
X | delta absDelta |
X absDelta _ (delta _ newPosition - position) abs.
X absDelta > (1@2) ifTrue: [^false].
X
X (board pieceAt: newPosition) notNil ifTrue: ["taking, must be diagonal"
X ^(absDelta x = 1)
X and: [delta y = (colour == #white ifTrue: [1] ifFalse: [-1])]].
X
X "not taking, must be forward or back or en passant"
X delta x = 0 ifTrue: ["forward or back"
X ^colour == #white
X ifTrue: [
X delta y = 1
X or: [delta y = 2
X and: [moved not
X and: [(board pieceAt: position + (0@1)) isNil]]]]
X ifFalse: [
X delta y = -1
X or: [delta y = -2
X and: [moved not
X and: [(board pieceAt: position - (0@1)) isNil]]]]].
X
X ^self isEnPassant: newPosition in: board!
X
XmovedByTwo
X "Answer wether the reciver has moved by two. This is used for checking en passant"
X ^moved and: [movedTwo]!
X
XmoveTo: newPosition in: board
X "Move the receiver.
X Check for taking en passante.
X Compute movedTwo (for being taken en passante).
X Check for Queening"
X (self isEnPassant: newPosition in: board) ifTrue: [
X board removePieceAt: newPosition x @ position y].
X
X movedTwo _ moved not and: [(newPosition - position) abs = (0@2)].
X
X ((newPosition y = 8 and: [colour == #white])
X or: [newPosition y = 1 and: [colour == #black]]) ifTrue: [
X self become: (Queen new: colour size: size)].
X
X ^super moveTo: newPosition in: board! !SHAR_EOF
chmod 0644 Games-ChequerBoard.st || echo "restore of Games-ChequerBoard.st fails"
echo "x - extracting SelectSemaphoreIO.st (Text)"
sed 's/^X//' << 'SHAR_EOF' > SelectSemaphoreIO.st &&
X"This goodie provides a more portable, efficient and powerful way of doing asynchronous input/output between Smalltalk and the host operating system. This goodie changes the TerminalEmulator (and BrouHaHaShellPort) to use the new scheme. The heart of this scheme is a primitive that associates a file handle with some semaphores. The semaphores are signalled when reading or writing is possible or an exceptional condition has occured on the file. On unix systems this primitive is an interface to the sele
ct(2) system call. This scheme renders the UnixSystemCall>semaphoreForSignal: method various associated stuff (e.g. UnixSemaphore) obsolete.
X
XOn unix implementations the correct functioning of the select primitive depends on the virtual machine being signalled by SIGIO whenever a read is possible or exceptional condition has occured on any of the relevant file handles. Some unix implementations are broken in this respect (i.e. fcntl(fileHandle,FSETFL,FASYNC); fcntl(fileHandle,FSETOWN,getpid()) do not cause SIGIO to be sent). So far, A/UX v 1.1.1, A/UX V2.0 & Sun OS 3.5 are known not to send SIGIO for pseudo terminals.
X
XOne way to get around this problem is to periodically poll via select(2). The -i option (see the st manual page) for the VM will set this up using an alarm timer. This goodie provides a more satisfactory solution via a new SystemCall operation pauseForMilliseconds. On unix systems this operation calls select(2) with the milliseconds argument as a timeout. The select call will either timeout or return immediately a read is possible or exceptional condition occurs. UnixSystemCall installs a background
process at systemBackgroundPriority that repeatedly invokes pauseForMilliseconds for 1000 milliseconds (1 second). To ensure that this process gets to run often this goodie modifies Controller>controlLoop, ControlManager>searchForActiveController and ScrollController>scroll to wait on a 50 millisecond delay rather than calling Processor yield. When Smalltalk is idle, spinning buisily round some controller's controlLoop the pauseForMilliseconds process can free a lot of the cpu for the rest of the unix sy
stXem.
X
X
X Eliot Miranda"
X
X'From BrouHaHa Smalltalk-80, Version 2.3.2t of 27 February 1990 on 31 January 1991 10:58:51 am'!
X
XBrouHaHaShellPort instanceCount > 0 ifTrue: [
X self notify:
X'You must close down all terminals before filing this in.
XYou must also snapshot & quit after filing in and before
Xopening any new terminals']!
X
X!ControlManager methodsFor: 'scheduling'!
X
XsearchForActiveController
X "Find a scheduled controller that wants control and give control to it. If none
X wants control, then see if the System Menu has been requested."
X
X | newController |
X activeController _ nil.
X activeControllerProcess _ Processor activeProcess.
X [(Delay forMilliseconds: 50) wait.
X newController _ scheduledControllers
X detect:
X [:aController |
X aController isControlWanted and:
X [aController ~~ screenController]]
X ifNone:
X [screenController isControlWanted
X ifTrue: [screenController]
X ifFalse: [nil]].
X newController isNil]
X whileTrue.
X self activeController: newController.
X Processor terminateActive! !
X
X!Controller methodsFor: 'basic control sequence'!
X
XcontrolLoop
X "Sent by Controller|startUp as part of the standard control sequence.
X Controller|controlLoop sends the message Controller|isControlActive to test
X for loop termination. As long as true is returned, the loop continues. When
X false is returned, the loop ends. Each time through the loop, the message
X Controller|controlActivity is sent."
X
X [self isControlActive] whileTrue: [(Delay forMilliseconds: 50) wait. self controlActivity]! !
X
X
X!ScrollController methodsFor: 'scrolling'!
X
Xscroll
X "Check to see whether the user wishes to jump, scroll up, or scroll down."
X
X | savedCursor regionPercent |
X savedCursor _ sensor currentCursor.
X [self scrollBarContainsCursor]
X whileTrue:
X [(Delay forMilliseconds: 50) wait.
X regionPercent _ 100 * (sensor cursorPoint x - scrollBar left) // scrollBar width.
X regionPercent <= 40
X ifTrue: [self scrollDown]
X ifFalse: [regionPercent >= 60
X ifTrue: [self scrollUp]
X ifFalse: [self scrollAbsolute]]].
X savedCursor show! !
X
X!TermEmulatorController methodsFor: 'basic control sequence'!
X
XcontrolInitialize
X "Save the key that interrupts the system and install a different
X one so I can have a different meaning for control c."
X
X InputState interruptKey ~= 162 ifTrue: [
X SavedInterruptKey _ InputState interruptKey.
X InputState interruptKey: 162. "L9 key"].
X ^super controlInitialize!
X
XcontrolTerminate
X "Return the interrupt key to its saved value."
X
X InputState interruptKey: SavedInterruptKey.
X ^super controlTerminate! !
XTermEmulator removeSelector: #inactive!
XTermEmulator removeSelector: #active!
X
X
X!BrouHaHaShellPort methodsFor: 'receiving'!
X
XreceiveBuffer
X
X | nread |
X [self isOpen] whileTrue: [
X receiveSemaphore wait.
X self isOpen ifTrue: [
X nread _ (SystemCall default
X read: portNumber
X into: receiveBuffer
X count: receiveBuffer size)
X valueIfError: [:errno|
X errno ~= EWOULDBLOCK ifTrue: [self changed: #externalPortError].
X 0].
X receiveStream _ ReadWriteStream on: receiveBuffer from: 1 to: nread.
X nread = receiveBuffer size ifTrue: [receiveSemaphore signal].
X nread > 0 ifTrue: [^self]]]! !
X
X!BrouHaHaShellPort methodsFor: 'access primitives'!
X
XclosePort
X (SystemCall default kill: childPid signal: SIGHUP) valueOnError: [].
X portNumber isInteger ifTrue: [
X SystemCall default select: portNumber signalOnRead: nil write: nil.
X (SystemCall default close: portNumber) valueOnError: [].
X portNumber _ nil].
X receiveSemaphore notNil ifTrue: [receiveSemaphore terminateProcess]! !
X
X!BrouHaHaShellPort methodsFor: 'private'!
X
XfileDescriptor: ttyfd childProcess: shellPid
X portNumber _ ttyfd.
X childPid _ shellPid.
X self initializePort.
X SystemCall default select: ttyfd signalOnRead: receiveSemaphore write: sendSemaphore.
X receiveStream _ ReadStream on: receiveBuffer! !
XBrouHaHaShellPort removeSelector: #inactive!
XBrouHaHaShellPort removeSelector: #active!
XBrouHaHaShellPort removeSelector: #receiveBufferPolling!
XExternalPort subclass: #BrouHaHaShellPort
X instanceVariableNames: 'childPid '
X classVariableNames: ''
X poolDictionaries: 'UnixConstants UnixErrorCodes UnixSignals '
X category: 'Interface-Terminal'!
X
X
X
X
X!ClassDescription methodsFor: 'organization'!
XselectorsInCategory: categoryName
X Symbol hasInterned: categoryName ifTrue: [:sym|
X ^self organization listAtCategoryNamed: sym].
X ^#()! !
X
X!Object methodsFor: 'message handling'!
X
XperformAllMessagesInCategory: categoryName
X | category messages |
X categoryName class == Symbol
X ifTrue: [category _ categoryName]
X ifFalse: [
X (Symbol
X hasInterned: categoryName
X ifTrue: [:categorySymbol| category _ categorySymbol. true])
X ifFalse: [^self]].
X
X messages _ Set new.
X self class withAllSuperclasses do: [:class |
X messages addAll: (class selectorsInCategory: category)].
X messages do: [:selector |
X self perform: selector]
X
X "0@0 performAllMessagesInCategory: #testing"! !
X
XSystemCall class
X instanceVariableNames: 'statusOfFileNamed statusOfFile pauseForMilliseconds '!
X
X
X!SystemCall class methodsFor: 'class initialization'!
X
XinitializeRoutineCodes
X
X "SystemCall initializeRoutineCodes"
X "SystemCall withAllSubclasses do: [:syscallClass| syscallClass initializeRoutineCodes]"
X
X statusOfFileNamed _ 1009.
X statusOfFile _ 1014.
X pauseForMilliseconds _ 1100! !
X
X!SystemCall class methodsFor: 'updating'!
Xupdate: aParameter
X "Update SystemCall, which really means update the DefaultSystemCall.
X Here we handle different system's different needs by invoking update
X messages by category name."
X
X "Invoke all methods in the DefaultSystemCall's category 'update after snapshot'
X if aParameter is finishedSnapshot or returnFromSnapshot or returnFromSnapshotAndQuit."
X
X (#(finishedSnapshot returnFromSnapshot returnFromSnapshotAndQuit) includes: aParameter) ifTrue: [
X DefaultSystemCall performAllMessagesInCategory: #'update after snapshot'].
X
X "Invoke all methods in the DefaultSystemCall's category 'update on startup'
X if aParameter is returnFromSnapshot or returnFromSnapshotAndQuit."
X
X (#(returnFromSnapshot returnFromSnapshotAndQuit) includes: aParameter) ifTrue: [
X DefaultSystemCall performAllMessagesInCategory: #'update on startup'].
X
X "Invoke all methods in the DefaultSystemCall's category 'update before startup'
X if aParameter is aboutToSnapshot or aboutToSnapshotAndQuit."
X
X (#(aboutToSnapshot aboutToSnapshotAndQuit) includes: aParameter) ifTrue: [
X DefaultSystemCall performAllMessagesInCategory: #'update before snapshot']
X
X "SystemCall update: #returnFromSnapshot"! !
X
XSystemCall variableSubclass: #UnixSystemCall
X instanceVariableNames: ''
X classVariableNames: 'SignalSemaphores UnixBackgroundProcess'
X poolDictionaries: 'UnixConstants UnixSignals UnixErrorCodes '
X category: 'System-External Interface'!
X
X!UnixSystemCall class reorganize!
X('class initialization' initialize initializeConstants initializeErrorCodes initializeRoutineCodes initializeSignals)
X('testing' isApplication:)
X('constants' createDirectoryMask createFileMask createIfAbsent readMode readWriteMode rootDirectoryName separator separatorString writeMode)
X('simple interface' canReadFile: canWriteFile: createFile:mode: currentWorkingDirectory directoryContentsFor: enumerateVolumes flushToDisk: getVolumeNames getVolumes isSymbolicLink: makeDirectory: read:into:amount: removeDirectory: shortenFile:toPosition: sizeOfFile: write:from:amount:)
X('simple tools' doCommand: getEnvironmentVariable: userName writeEnable: writeProtect:)
X('file manipulation' access:mode: chmod:mode: close: creat:mode: ioctl:request:argument: lseek:by:how: open:for:mode: read:into:count: sync unlink: write:from:count:)
X('signals' clearSemaphore:withSignalNumber: initializeSignals: select:signalOnRead:write: semaphoreForSignal:)
X('processes' getpgrp getpid kill:signal:)
X('primitives' dup2:vforkThenExec: primitiveSignal:on: primtiveSelect:signalOnRead:write:exceptionalCondition:)
X('update on startup' checkDoIt installSignals)
X('update before snapshot' terminateBackgroundProcess)
X('update after snapshot' installBackgroundProcess)
X('private' clearSignals ignoreSignal: primRealStatusOfFileNamed:into: signal:on:)
X!
X
X
X
X!UnixSystemCall class methodsFor: 'signals'!
X
Xselect: fileDescriptor signalOnRead: readSemaphore write: writeSemaphore
X "Arrange that whenever a read or write is possible on the unix descriptor fileDescriptor
X readSemaphore or writeSemaphore are signalled respectively."
X self
X primtiveSelect: fileDescriptor
X signalOnRead: readSemaphore
X write: writeSemaphore
X exceptionalCondition: nil! !
X
X!UnixSystemCall class methodsFor: 'primitives'!
X
XprimtiveSelect: fd signalOnRead: s1 write: s2 exceptionalCondition: s3
X <primitive: 146>
X ^self primitiveFailed
X
X "primtiveSelect: fd signalOnRead: s1 write: s2 exceptionalCondition: s3
X gives access to the select(2) system call. It associates each of the
X semaphores s1,s2 +s3 with readable,writeable & exceptional conditions
X on the file descriptor fd.
X
X fd is an integer file handle corresponding to an open file.
X s1 is a semaphore to be signalled when reads are possible on file fd, or nil
X to clear a previous semaphore.
X s2 is a semaphore to be signalled when writes are possible on file fd, or nil
X to clear a previous semaphore.
X s3 is a semaphore to be signalled when an exceptional condition arises on
X file fd, or nil to clear a previous semaphore.
X
X The primitive enables the FASYNC flag (see fcntl(2)) on file fd if any of the
X semaphores are not nil, and disables the FASYNC flag if all the semaphores
X are nil"! !
X
X!UnixSystemCall class methodsFor: 'update after snapshot'!
X
XinstallBackgroundProcess
X "Install a background process that tries to give some of the processor to other unix processes.
X Use the pauseForMilliseconds primitive which suspends this process (the virtual machine)
X until a signal is delivered (usually delay terminated, input occured, mouse moved) or
X one of the file descriptors given to primitiveSelect:signalOnRead:write:exceptionalCondition:
X is readable or has an exceptional condition."
X
X self terminateBackgroundProcess.
X UnixBackgroundProcess _ [
X | pauseSysCall |
X pauseSysCall _ self operation: pauseForMilliseconds with: 1000.
X [true] whileTrue: [
X pauseSysCall value]] newProcess.
X UnixBackgroundProcess priority: Processor systemBackgroundPriority.
X UnixBackgroundProcess resume
X
X "DefaultSystemCall installBackgroundProcess"! !
X
X!UnixSystemCall class methodsFor: 'update before snapshot'!
XterminateBackgroundProcess
X UnixBackgroundProcess ~~ nil ifTrue: [
X UnixBackgroundProcess terminate.
X UnixBackgroundProcess _ nil]! !
X
X
X!BSDSystemCall class methodsFor: 'terminals'!
X
XsetupTerminalDescriptor: fd
X | flags |
X flags _ (self fcntl: fd command: FGETFL argument: 0) value.
X "enable non-blocking IO for the masterfd"
X (self fcntl: fd command: FSETFL argument: (flags bitOr: FNDELAY)) valueOnError: [].
X "turn off the pty's packet mode"
X (self ioctl: fd request: TIOCPKT argument: (self integerByReference: 0)) valueOnError: []! !
XBSDSystemCall class removeSelector: #ttyIOSignalWorksFor:!
XSystemCall withAllSubclasses do: [:syscallClass| syscallClass initializeRoutineCodes]!SHAR_EOF
chmod 0644 SelectSemaphoreIO.st || echo "restore of SelectSemaphoreIO.st fails"
echo "x - extracting UnixPipes.st (Text)"
sed 's/^X//' << 'SHAR_EOF' > UnixPipes.st &&
X"This goodie provides a stream interface to unix commands. For this to work you must have filed in SelectSemaphoreIO.st"
X'From BrouHaHa Smalltalk-80, Version 2.3.2t of 27 February 1990 on 11 March 1991 4:32:31 pm'!
X
XCharacterScanner subclass: #TranslationScanner
X instanceVariableNames: 'translationTable '
X classVariableNames: ''
X poolDictionaries: 'TextConstants '
X category: 'Collections-Support'!
X
XTranslationScanner comment:
X'I am used to transliterate characters. translationTable holds the required translation for each character'!
X
X!TranslationScanner methodsFor: 'initialize-release'!
X
Xinitialize
X stopConditions _ Array new: 258.
X stopConditions at: EndOfRun put: true.
X translationTable _ Array new: 256.
X xTable _ Array new: 257 withAll: 0.
X destX _ 0! !
X
X!TranslationScanner methodsFor: 'translating'!
X
XdontTranslate: aCharacter
X "Set up the translation scanner to no longer
X transliterate occurences of aCharacter"
X
X | index |
X index _ aCharacter asciiValue + 1.
X translationTable at: index put: nil.
X stopConditions at: index put: nil!
X
Xtranslate: aCharacter to: anOtherCharacter
X "Set up the translation scanner to transliterate
X occurences of aCharacter into anOtherCharacter"
X
X | index |
X index _ aCharacter asciiValue + 1.
X translationTable at: index put: anOtherCharacter.
X stopConditions at: index put: false!
X
XtranslateFrom: start to: stop in: aString
X "Transliterate characters in aString in the range start to stop"
X lastIndex _ start.
X [self
X scanCharactersFrom: lastIndex
X to: stop
X in: aString
X rightX: 0
X stopConditions: stopConditions
X displaying: false]
X whileFalse: [
X aString at: lastIndex put: (translationTable at: (aString asciiValueAt: lastIndex) + 1).
X lastIndex _ lastIndex + 1]! !
X
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XTranslationScanner class
X instanceVariableNames: ''!
X
X!TranslationScanner class methodsFor: 'instance creation'!
X
Xnew
X ^super new initialize! !
X
X!String methodsFor: 'accessing'!
X
XasciiValueAt: index
X "Answer the ascii value of the character stored in the field of the receiver
X indexed by the argument. Fail if the index argument is not an Integer or is out of bounds. Optional, but must work given the definition of String>at: & Object>at:."
X
X <primitive: 60>
X ^super at: index! !
X
X!UnixSystemCall class methodsFor: 'file manipulation'!
X
Xpipe: array
X "Create a pipe (a read/write file descriptor pair)"
X
X self mustBeString: array ofLengthAtLeast: 8.
X ^self operation: pipe with: array! !
X
XReadWriteStream subclass: #UnixPipeStream
X instanceVariableNames: 'actualPosition command readSemaphore writeStream readfd writefd atEnd '
X classVariableNames: 'LfToCrScanner '
X poolDictionaries: 'UnixConstants UnixErrorCodes '
X category: 'Files-Streams'!
XUnixPipeStream comment:
X'I an a read/write stream to a unix command. Characters written to me (via nextPut: nextPutAll: etc) are supplied as input to my command. The output from teh command can be read via next etc.
X
X
XIinstance Variables:
X actualPosition <Integer> keeps track of actual position of reading pointer
X command <String> unix command
X readSemaphore <Semaphore> used to block until a read is possible
X writeStream <UnixPipeWriteStream>
X used to buffer data written to pipe
X readfd <Integer> file descriptor of read side of pipe
X writefd <Integer> file descriptor of write side of pipe
X atEnd <Boolean> set to true when read from pipe indicates end-of-file'!
X
X
X!UnixPipeStream methodsFor: 'accessing'!
X
XatEnd
X "Test if I'm atEnd. I may simply not have read yet"
X super atEnd ifTrue: [self read].
X ^atEnd!
X
Xcontents
X "keep reading until at the end"
X | contents |
X readLimit < 0 ifTrue: [self read].
X contents _ super contents.
X position _ readLimit.
X ^contents!
X
XcontentsOfEntireFile
X "keep reading until at the end"
X | entireContents |
X entireContents _ WriteStream on: (String new: collection size).
X [self atEnd] whileFalse: [
X entireContents nextPutAll: self contents].
X ^entireContents contents!
X
Xnext
X "If the primitive fails flush the writeStream & read into my bufer"
X
X | nread |
X <primitive: 65>
X self read.
X ^readLimit > 0 ifTrue: [super next]!
X
XnextPut: aCharacter
X "Get my writeStream to write characters. Translate carriage-returns to line-feeds"
X ^writeStream nextPut: (aCharacter == Character cr ifTrue: [Character lf] ifFalse: [aCharacter])! !
X
X!UnixPipeStream methodsFor: 'positioning'!
X
Xposition
X "My actual position will be larger than my position if characters have been flushed"
X ^position + actualPosition!
X
Xposition: positionInteger
X "My actual position will be larger than my position if characters have been flushed"
X super position: position - actualPosition!
X
Xskip: anInteger
X anInteger >= 0 ifTrue: [
X anInteger timesRepeat: [self next].
X ^self].
X anInteger negated <= position ifTrue: [
X position _ position + anInteger.
X ^self].
X self error: 'skipping to previous block not yet implemented'! !
X
X!UnixPipeStream methodsFor: 'file status'!
X
Xclose
X "close the receiver by clearing the conection to command"
X readfd notNil ifTrue: [
X SystemCall default select: readfd signalOnRead: nil write: nil.
X SystemCall closeFile: readfd].
X writefd notNil ifTrue: [
X SystemCall default select: writefd signalOnRead: nil write: nil.
X SystemCall closeFile: writefd].
X FileDirectory removeExternalReference: self.
X atEnd _ true!
X
Xflush
X "Cause my writeStream to flush"
X writeStream flush!
X
Xrelease
X "Close my pipe"
X self close.
X super release!
X
Xreopen
X "Fire up the command & pipe to it"
X | pipefds morepipefds child shell writeSemaphore bufferSize flags childwritefd childreadfd |
X self close.
X shell _ SystemCall default getEnvironmentVariable: 'SHELL'.
X shell isNil ifTrue: [shell _ '/bin/sh'].
X pipefds _ ByteArray new: 8.
X (SystemCall default pipe: pipefds) value.
X morepipefds _ ByteArray new: 8.
X (SystemCall default pipe: morepipefds) value.
X SystemCall default systemIsBigEndian
X ifTrue: [
X readfd _ pipefds at: 4.
X childwritefd _ pipefds at: 8.
X writefd _ morepipefds at: 8.
X childreadfd _ morepipefds at: 4]
X ifFalse: [
X readfd _ pipefds at: 1.
X childwritefd _ pipefds at: 5.
X writefd _ morepipefds at: 5.
X childreadfd _ morepipefds at: 1].
X child _ SystemCall default
X dup2: (Array with: childreadfd with: 0 with: childwritefd with: 1 with: childwritefd with: 2)
X vforkThenExec: (Array with: shell with: (Array with: shell with: '-c' with: 'exec ', command)).
X child < 0 ifTrue: [
X SystemCall closeFile: readfd; closeFile: writefd; closeFile: childreadfd; closeFile: childwritefd.
X self error: 'could not pipe to ', command, ' command'].
X
X SystemCall closeFile: childreadfd; closeFile: childwritefd.
X
X flags _ (SystemCall default fcntl: readfd command: FGETFL argument: 0) value.
X "enable non-blocking IO for the readfd"
X (SystemCall default fcntl: readfd command: FSETFL argument: (flags bitOr: FNDELAY)) value.
X
X FileDirectory addExternalReference: self.
X
X "Setup read/write semaphores"
X readSemaphore _ Semaphore new.
X SystemCall default select: readfd signalOnRead: readSemaphore write: nil.
X writeSemaphore _ Semaphore new.
X SystemCall default select: writefd signalOnRead: nil write: writeSemaphore.
X bufferSize _ 4096.
X writeStream _ UnixPipeWriteStream on: writefd semaphore: writeSemaphore size: bufferSize.
X actualPosition _ 0.
X self on: (String new: bufferSize) from: 1 to: bufferSize.
X readLimit _ -1.
X atEnd _ false! !
X
X!UnixPipeStream methodsFor: 'private'!
X
Xon: aUnixCommandString
X "Initialize the receiver to pipe to a unix command"
X
X command _ aUnixCommandString.
X self reopen!
X
Xread
X "Read into my buffer"
X | blocked |
X writeStream flush.
X [readSemaphore wait.
X blocked _ false.
X readLimit _ (SystemCall default
X read: readfd
X into: collection
X count: collection size) valueIfError: [:errno|
X blocked _ errno = EWOULDBLOCK.
X 0].
X blocked] whileTrue.
X readLimit = 0 ifTrue: [
X self close].
X position _ 0.
X LfToCrScanner translateFrom: 1 to: readLimit in: collection! !
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XUnixPipeStream class
X instanceVariableNames: ''!
X
X
X!UnixPipeStream class methodsFor: 'class initialization'!
X
Xinitialize
X "Initialize the scanner that converts Unixese line-feeds to Smalltalkese carriage-returns"
X "UnixPipeStream initialize"
X LfToCrScanner _ TranslationScanner new.
X LfToCrScanner translate: Character lf to: Character cr! !
X
X!UnixPipeStream class methodsFor: 'instance creation'!
X
Xon: aUnixCommandString
X "Return a stream piped to a unix command"
X ^self basicNew on: aUnixCommandString! !
X
XUnixPipeStream initialize!
X
X
XWriteStream subclass: #UnixPipeWriteStream
X instanceVariableNames: 'actualPosition writeSemaphore writefd mode '
X classVariableNames: ''
X poolDictionaries: ''
X category: 'Files-Streams'!
X
X!UnixPipeWriteStream methodsFor: 'testing'!
X
XatEnd
X "Return if I'm atEnd"
X self flush.
X ^(SystemCall statusForFile: writefd) notNil! !
X
X!UnixPipeWriteStream methodsFor: 'positioning'!
X
Xposition
X "My actual position will be larger than my position if characters have been flushed"
X ^position + actualPosition!
X
Xposition: positionInteger
X "My actual position will be larger than my position if characters have been flushed"
X super position: position - actualPosition! !
X
X!UnixPipeWriteStream methodsFor: 'file status'!
X
Xflush
X "Flush my buffer & reset my position"
X position > 0 ifTrue: [
X actualPosition _ actualPosition + position.
X writeSemaphore wait.
X SystemCall
X write: writefd
X from: collection
X amount: position.
X position _ 0]! !
X
X!UnixPipeWriteStream methodsFor: 'private'!
X
Xon: fileDescriptor semaphore: semaphore size: bufferSize
X "Initialize the receiver to write to the given pipe file descriptor"
X writefd _ fileDescriptor.
X writeSemaphore _ semaphore.
X actualPosition _ 0.
X self on: (String new: bufferSize) from: 1 to: bufferSize!
X
XpastEndPut: aCharacter
X "I've overflowed my buffer. Write it to the pipe"
X self flush.
X ^self nextPut: aCharacter! !
X
X"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
X
XUnixPipeWriteStream class
X instanceVariableNames: ''!
X
X!UnixPipeWriteStream class methodsFor: 'instance creation'!
X
Xon: writefd semaphore: writeSemaphore size: bufferSize
X "Return an initialized stream to write to the given pipe file descriptor"
X ^self basicNew on: writefd semaphore: writeSemaphore size: bufferSize! !
X
SHAR_EOF
chmod 0644 UnixPipes.st || echo "restore of UnixPipes.st fails"
exit 0
--
Eliot Miranda email: eliot@cs.qmw.ac.uk
Dept of Computer Science Tel: 071 975 5229 (+44 71 975 5229)
Queen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk
Mile End Road UUCP: eliot@qmw-cs.uucp
LONDON E1 4NS