(defpackage #:polygonizer (:use #:cl #:lispbuilder-sdl #:infix) (:export #:run)) (in-package #:polygonizer) (declaim (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0))) (defconstant +colors+ '(("snow" #xfffafa) ("GhostWhite" #xf8f8ff) ("WhiteSmoke" #xf5f5f5) ("gainsboro" #xdcdcdc) ("FloralWhite" #xfffaf0) ("OldLace" #xfdf5e6) ("linen" #xfaf0e6) ("AntiqueWhite" #xfaebd7) ("PapayaWhip" #xffefd5) ("BlanchedAlmond" #xffebcd) ("bisque" #xffe4c4) ("PeachPuff" #xffdab9) ("NavajoWhite" #xffdead) ("moccasin" #xffe4b5) ("cornsilk" #xfff8dc) ("ivory" #xfffff0) ("LemonChiffon" #xfffacd) ("seashell" #xfff5ee) ("honeydew" #xf0fff0) ("MintCream" #xf5fffa) ("azure" #xf0ffff) ("AliceBlue" #xf0f8ff) ("lavender" #xe6e6fa) ("LavenderBlush" #xfff0f5) ("MistyRose" #xffe4e1) ("white" #xffffff) ("black" #x000000) ("DarkSlateGray" #x2f4f4f) ("DarkSlateGrey" #x2f4f4f) ("DimGray" #x696969) ("DimGrey" #x696969) ("SlateGray" #x708090) ("SlateGrey" #x708090) ("LightSlateGray" #x778899) ("LightSlateGrey" #x778899) ("gray" #xc0c0c0) ("grey" #xc0c0c0) ("LightGrey" #xd3d3d3) ("LightGray" #xd3d3d3) ("MidnightBlue" #x191970) ("navy" #x000080) ("NavyBlue" #x000080) ("CornflowerBlue" #x6495ed) ("DarkSlateBlue" #x483d8b) ("SlateBlue" #x6a5acd) ("MediumSlateBlue" #x7b68ee) ("LightSlateBlue" #x8470ff) ("MediumBlue" #x0000cd) ("RoyalBlue" #x4169e1) ("blue" #x0000ff) ("DodgerBlue" #x1e90ff) ("DeepSkyBlue" #x00bfff) ("SkyBlue" #x87ceeb) ("LightSkyBlue" #x87cefa) ("SteelBlue" #x4682b4) ("LightSteelBlue" #xb0c4de) ("LightBlue" #xadd8e6) ("PowderBlue" #xb0e0e6) ("PaleTurquoise" #xafeeee) ("DarkTurquoise" #x00ced1) ("MediumTurquoise" #x48d1cc) ("turquoise" #x40e0d0) ("cyan" #x00ffff) ("LightCyan" #xe0ffff) ("CadetBlue" #x5f9ea0) ("MediumAquamarine" #x66cdaa) ("aquamarine" #x7fffd4) ("DarkGreen" #x006400) ("DarkOliveGreen" #x556b2f) ("DarkSeaGreen" #x8fbc8f) ("SeaGreen" #x2e8b57) ("MediumSeaGreen" #x3cb371) ("LightSeaGreen" #x20b2aa) ("PaleGreen" #x98fb98) ("SpringGreen" #x00ff7f) ("LawnGreen" #x7cfc00) ("green" #x00ff00) ("chartreuse" #x7fff00) ("MediumSpringGreen" #x00fa9a) ("GreenYellow" #xadff2f) ("LimeGreen" #x32cd32) ("YellowGreen" #x9acd32) ("ForestGreen" #x228b22) ("OliveDrab" #x6b8e23) ("DarkKhaki" #xbdb76b) ("khaki" #xf0e68c) ("PaleGoldenrod" #xeee8aa) ("LightGoldenrodYellow" #xfafad2) ("LightYellow" #xffffe0) ("yellow" #xffff00) ("gold" #xffd700) ("LightGoldenrod" #xeedd82) ("goldenrod" #xdaa520) ("DarkGoldenrod" #xb8860b) ("RosyBrown" #xbc8f8f) ("IndianRed" #xcd5c5c) ("SaddleBrown" #x8b4513) ("sienna" #xa0522d) ("peru" #xcd853f) ("burlywood" #xdeb887) ("beige" #xf5f5dc) ("wheat" #xf5deb3) ("SandyBrown" #xf4a460) ("tan" #xd2b48c) ("chocolate" #xd2691e) ("firebrick" #xb22222) ("brown" #xa52a2a) ("DarkSalmon" #xe9967a) ("salmon" #xfa8072) ("LightSalmon" #xffa07a) ("orange" #xffa500) ("DarkOrange" #xff8c00) ("coral" #xff7f50) ("LightCoral" #xf08080) ("tomato" #xff6347) ("OrangeRed" #xff4500) ("red" #xff0000) ("HotPink" #xff69b4) ("DeepPink" #xff1493) ("pink" #xffc0cb) ("LightPink" #xffb6c1) ("PaleVioletRed" #xdb7093) ("maroon" #xb03060) ("MediumVioletRed" #xc71585) ("VioletRed" #xd02090) ("magenta" #xff00ff) ("violet" #xee82ee) ("plum" #xdda0dd) ("orchid" #xda70d6) ("MediumOrchid" #xba55d3) ("DarkOrchid" #x9932cc) ("DarkViolet" #x9400d3) ("BlueViolet" #x8a2be2) ("purple" #xa020f0) ("MediumPurple" #x9370db) ("thistle" #xd8bfd8) ("snow1" #xfffafa) ("snow2" #xeee9e9) ("snow3" #xcdc9c9) ("snow4" #x8b8989) ("seashell1" #xfff5ee) ("seashell2" #xeee5de) ("seashell3" #xcdc5bf) ("seashell4" #x8b8682) ("AntiqueWhite1" #xffefdb) ("AntiqueWhite2" #xeedfcc) ("AntiqueWhite3" #xcdc0b0) ("AntiqueWhite4" #x8b8378) ("bisque1" #xffe4c4) ("bisque2" #xeed5b7) ("bisque3" #xcdb79e) ("bisque4" #x8b7d6b) ("PeachPuff1" #xffdab9) ("PeachPuff2" #xeecbad) ("PeachPuff3" #xcdaf95) ("PeachPuff4" #x8b7765) ("NavajoWhite1" #xffdead) ("NavajoWhite2" #xeecfa1) ("NavajoWhite3" #xcdb38b) ("NavajoWhite4" #x8b795e) ("LemonChiffon1" #xfffacd) ("LemonChiffon2" #xeee9bf) ("LemonChiffon3" #xcdc9a5) ("LemonChiffon4" #x8b8970) ("cornsilk1" #xfff8dc) ("cornsilk2" #xeee8cd) ("cornsilk3" #xcdc8b1) ("cornsilk4" #x8b8878) ("ivory1" #xfffff0) ("ivory2" #xeeeee0) ("ivory3" #xcdcdc1) ("ivory4" #x8b8b83) ("honeydew1" #xf0fff0) ("honeydew2" #xe0eee0) ("honeydew3" #xc1cdc1) ("honeydew4" #x838b83) ("LavenderBlush1" #xfff0f5) ("LavenderBlush2" #xeee0e5) ("LavenderBlush3" #xcdc1c5) ("LavenderBlush4" #x8b8386) ("MistyRose1" #xffe4e1) ("MistyRose2" #xeed5d2) ("MistyRose3" #xcdb7b5) ("MistyRose4" #x8b7d7b) ("azure1" #xf0ffff) ("azure2" #xe0eeee) ("azure3" #xc1cdcd) ("azure4" #x838b8b) ("SlateBlue1" #x836fff) ("SlateBlue2" #x7a67ee) ("SlateBlue3" #x6959cd) ("SlateBlue4" #x473c8b) ("RoyalBlue1" #x4876ff) ("RoyalBlue2" #x436eee) ("RoyalBlue3" #x3a5fcd) ("RoyalBlue4" #x27408b) ("blue1" #x0000ff) ("blue2" #x0000ee) ("blue3" #x0000cd) ("blue4" #x00008b) ("DodgerBlue1" #x1e90ff) ("DodgerBlue2" #x1c86ee) ("DodgerBlue3" #x1874cd) ("DodgerBlue4" #x104e8b) ("SteelBlue1" #x63b8ff) ("SteelBlue2" #x5cacee) ("SteelBlue3" #x4f94cd) ("SteelBlue4" #x36648b) ("DeepSkyBlue1" #x00bfff) ("DeepSkyBlue2" #x00b2ee) ("DeepSkyBlue3" #x009acd) ("DeepSkyBlue4" #x00688b) ("SkyBlue1" #x87ceff) ("SkyBlue2" #x7ec0ee) ("SkyBlue3" #x6ca6cd) ("SkyBlue4" #x4a708b) ("LightSkyBlue1" #xb0e2ff) ("LightSkyBlue2" #xa4d3ee) ("LightSkyBlue3" #x8db6cd) ("LightSkyBlue4" #x607b8b) ("SlateGray1" #xc6e2ff) ("SlateGray2" #xb9d3ee) ("SlateGray3" #x9fb6cd) ("SlateGray4" #x6c7b8b) ("LightSteelBlue1" #xcae1ff) ("LightSteelBlue2" #xbcd2ee) ("LightSteelBlue3" #xa2b5cd) ("LightSteelBlue4" #x6e7b8b) ("LightBlue1" #xbfefff) ("LightBlue2" #xb2dfee) ("LightBlue3" #x9ac0cd) ("LightBlue4" #x68838b) ("LightCyan1" #xe0ffff) ("LightCyan2" #xd1eeee) ("LightCyan3" #xb4cdcd) ("LightCyan4" #x7a8b8b) ("PaleTurquoise1" #xbbffff) ("PaleTurquoise2" #xaeeeee) ("PaleTurquoise3" #x96cdcd) ("PaleTurquoise4" #x668b8b) ("CadetBlue1" #x98f5ff) ("CadetBlue2" #x8ee5ee) ("CadetBlue3" #x7ac5cd) ("CadetBlue4" #x53868b) ("turquoise1" #x00f5ff) ("turquoise2" #x00e5ee) ("turquoise3" #x00c5cd) ("turquoise4" #x00868b) ("cyan1" #x00ffff) ("cyan2" #x00eeee) ("cyan3" #x00cdcd) ("cyan4" #x008b8b) ("DarkSlateGray1" #x97ffff) ("DarkSlateGray2" #x8deeee) ("DarkSlateGray3" #x79cdcd) ("DarkSlateGray4" #x528b8b) ("aquamarine1" #x7fffd4) ("aquamarine2" #x76eec6) ("aquamarine3" #x66cdaa) ("aquamarine4" #x458b74) ("DarkSeaGreen1" #xc1ffc1) ("DarkSeaGreen2" #xb4eeb4) ("DarkSeaGreen3" #x9bcd9b) ("DarkSeaGreen4" #x698b69) ("SeaGreen1" #x54ff9f) ("SeaGreen2" #x4eee94) ("SeaGreen3" #x43cd80) ("SeaGreen4" #x2e8b57) ("PaleGreen1" #x9aff9a) ("PaleGreen2" #x90ee90) ("PaleGreen3" #x7ccd7c) ("PaleGreen4" #x548b54) ("SpringGreen1" #x00ff7f) ("SpringGreen2" #x00ee76) ("SpringGreen3" #x00cd66) ("SpringGreen4" #x008b45) ("green1" #x00ff00) ("green2" #x00ee00) ("green3" #x00cd00) ("green4" #x008b00) ("chartreuse1" #x7fff00) ("chartreuse2" #x76ee00) ("chartreuse3" #x66cd00) ("chartreuse4" #x458b00) ("OliveDrab1" #xc0ff3e) ("OliveDrab2" #xb3ee3a) ("OliveDrab3" #x9acd32) ("OliveDrab4" #x698b22) ("DarkOliveGreen1" #xcaff70) ("DarkOliveGreen2" #xbcee68) ("DarkOliveGreen3" #xa2cd5a) ("DarkOliveGreen4" #x6e8b3d) ("khaki1" #xfff68f) ("khaki2" #xeee685) ("khaki3" #xcdc673) ("khaki4" #x8b864e) ("LightGoldenrod1" #xffec8b) ("LightGoldenrod2" #xeedc82) ("LightGoldenrod3" #xcdbe70) ("LightGoldenrod4" #x8b814c) ("LightYellow1" #xffffe0) ("LightYellow2" #xeeeed1) ("LightYellow3" #xcdcdb4) ("LightYellow4" #x8b8b7a) ("yellow1" #xffff00) ("yellow2" #xeeee00) ("yellow3" #xcdcd00) ("yellow4" #x8b8b00) ("gold1" #xffd700) ("gold2" #xeec900) ("gold3" #xcdad00) ("gold4" #x8b7500) ("goldenrod1" #xffc125) ("goldenrod2" #xeeb422) ("goldenrod3" #xcd9b1d) ("goldenrod4" #x8b6914) ("DarkGoldenrod1" #xffb90f) ("DarkGoldenrod2" #xeead0e) ("DarkGoldenrod3" #xcd950c) ("DarkGoldenrod4" #x8b6508) ("RosyBrown1" #xffc1c1) ("RosyBrown2" #xeeb4b4) ("RosyBrown3" #xcd9b9b) ("RosyBrown4" #x8b6969) ("IndianRed1" #xff6a6a) ("IndianRed2" #xee6363) ("IndianRed3" #xcd5555) ("IndianRed4" #x8b3a3a) ("sienna1" #xff8247) ("sienna2" #xee7942) ("sienna3" #xcd6839) ("sienna4" #x8b4726) ("burlywood1" #xffd39b) ("burlywood2" #xeec591) ("burlywood3" #xcdaa7d) ("burlywood4" #x8b7355) ("wheat1" #xffe7ba) ("wheat2" #xeed8ae) ("wheat3" #xcdba96) ("wheat4" #x8b7e66) ("tan1" #xffa54f) ("tan2" #xee9a49) ("tan3" #xcd853f) ("tan4" #x8b5a2b) ("chocolate1" #xff7f24) ("chocolate2" #xee7621) ("chocolate3" #xcd661d) ("chocolate4" #x8b4513) ("firebrick1" #xff3030) ("firebrick2" #xee2c2c) ("firebrick3" #xcd2626) ("firebrick4" #x8b1a1a) ("brown1" #xff4040) ("brown2" #xee3b3b) ("brown3" #xcd3333) ("brown4" #x8b2323) ("salmon1" #xff8c69) ("salmon2" #xee8262) ("salmon3" #xcd7054) ("salmon4" #x8b4c39) ("LightSalmon1" #xffa07a) ("LightSalmon2" #xee9572) ("LightSalmon3" #xcd8162) ("LightSalmon4" #x8b5742) ("orange1" #xffa500) ("orange2" #xee9a00) ("orange3" #xcd8500) ("orange4" #x8b5a00) ("DarkOrange1" #xff7f00) ("DarkOrange2" #xee7600) ("DarkOrange3" #xcd6600) ("DarkOrange4" #x8b4500) ("coral1" #xff7256) ("coral2" #xee6a50) ("coral3" #xcd5b45) ("coral4" #x8b3e2f) ("tomato1" #xff6347) ("tomato2" #xee5c42) ("tomato3" #xcd4f39) ("tomato4" #x8b3626) ("OrangeRed1" #xff4500) ("OrangeRed2" #xee4000) ("OrangeRed3" #xcd3700) ("OrangeRed4" #x8b2500) ("red1" #xff0000) ("red2" #xee0000) ("red3" #xcd0000) ("red4" #x8b0000) ("DeepPink1" #xff1493) ("DeepPink2" #xee1289) ("DeepPink3" #xcd1076) ("DeepPink4" #x8b0a50) ("HotPink1" #xff6eb4) ("HotPink2" #xee6aa7) ("HotPink3" #xcd6090) ("HotPink4" #x8b3a62) ("pink1" #xffb5c5) ("pink2" #xeea9b8) ("pink3" #xcd919e) ("pink4" #x8b636c) ("LightPink1" #xffaeb9) ("LightPink2" #xeea2ad) ("LightPink3" #xcd8c95) ("LightPink4" #x8b5f65) ("PaleVioletRed1" #xff82ab) ("PaleVioletRed2" #xee799f) ("PaleVioletRed3" #xcd6889) ("PaleVioletRed4" #x8b475d) ("maroon1" #xff34b3) ("maroon2" #xee30a7) ("maroon3" #xcd2990) ("maroon4" #x8b1c62) ("VioletRed1" #xff3e96) ("VioletRed2" #xee3a8c) ("VioletRed3" #xcd3278) ("VioletRed4" #x8b2252) ("magenta1" #xff00ff) ("magenta2" #xee00ee) ("magenta3" #xcd00cd) ("magenta4" #x8b008b) ("orchid1" #xff83fa) ("orchid2" #xee7ae9) ("orchid3" #xcd69c9) ("orchid4" #x8b4789) ("plum1" #xffbbff) ("plum2" #xeeaeee) ("plum3" #xcd96cd) ("plum4" #x8b668b) ("MediumOrchid1" #xe066ff) ("MediumOrchid2" #xd15fee) ("MediumOrchid3" #xb452cd) ("MediumOrchid4" #x7a378b) ("DarkOrchid1" #xbf3eff) ("DarkOrchid2" #xb23aee) ("DarkOrchid3" #x9a32cd) ("DarkOrchid4" #x68228b) ("purple1" #x9b30ff) ("purple2" #x912cee) ("purple3" #x7d26cd) ("purple4" #x551a8b) ("MediumPurple1" #xab82ff) ("MediumPurple2" #x9f79ee) ("MediumPurple3" #x8968cd) ("MediumPurple4" #x5d478b) ("thistle1" #xffe1ff) ("thistle2" #xeed2ee) ("thistle3" #xcdb5cd) ("thistle4" #x8b7b8b) ("gray0" #x000000) ("grey0" #x000000) ("gray1" #x030303) ("grey1" #x030303) ("gray2" #x050505) ("grey2" #x050505) ("gray3" #x080808) ("grey3" #x080808) ("gray4" #x0a0a0a) ("grey4" #x0a0a0a) ("gray5" #x0d0d0d) ("grey5" #x0d0d0d) ("gray6" #x0f0f0f) ("grey6" #x0f0f0f) ("gray7" #x121212) ("grey7" #x121212) ("gray8" #x141414) ("grey8" #x141414) ("gray9" #x171717) ("grey9" #x171717) ("gray10" #x1a1a1a) ("grey10" #x1a1a1a) ("gray11" #x1c1c1c) ("grey11" #x1c1c1c) ("gray12" #x1f1f1f) ("grey12" #x1f1f1f) ("gray13" #x212121) ("grey13" #x212121) ("gray14" #x242424) ("grey14" #x242424) ("gray15" #x262626) ("grey15" #x262626) ("gray16" #x292929) ("grey16" #x292929) ("gray17" #x2b2b2b) ("grey17" #x2b2b2b) ("gray18" #x2e2e2e) ("grey18" #x2e2e2e) ("gray19" #x303030) ("grey19" #x303030) ("gray20" #x333333) ("grey20" #x333333) ("gray21" #x363636) ("grey21" #x363636) ("gray22" #x383838) ("grey22" #x383838) ("gray23" #x3b3b3b) ("grey23" #x3b3b3b) ("gray24" #x3d3d3d) ("grey24" #x3d3d3d) ("gray25" #x404040) ("grey25" #x404040) ("gray26" #x424242) ("grey26" #x424242) ("gray27" #x454545) ("grey27" #x454545) ("gray28" #x474747) ("grey28" #x474747) ("gray29" #x4a4a4a) ("grey29" #x4a4a4a) ("gray30" #x4d4d4d) ("grey30" #x4d4d4d) ("gray31" #x4f4f4f) ("grey31" #x4f4f4f) ("gray32" #x525252) ("grey32" #x525252) ("gray33" #x545454) ("grey33" #x545454) ("gray34" #x575757) ("grey34" #x575757) ("gray35" #x595959) ("grey35" #x595959) ("gray36" #x5c5c5c) ("grey36" #x5c5c5c) ("gray37" #x5e5e5e) ("grey37" #x5e5e5e) ("gray38" #x616161) ("grey38" #x616161) ("gray39" #x636363) ("grey39" #x636363) ("gray40" #x666666) ("grey40" #x666666) ("gray41" #x696969) ("grey41" #x696969) ("gray42" #x6b6b6b) ("grey42" #x6b6b6b) ("gray43" #x6e6e6e) ("grey43" #x6e6e6e) ("gray44" #x707070) ("grey44" #x707070) ("gray45" #x737373) ("grey45" #x737373) ("gray46" #x757575) ("grey46" #x757575) ("gray47" #x787878) ("grey47" #x787878) ("gray48" #x7a7a7a) ("grey48" #x7a7a7a) ("gray49" #x7d7d7d) ("grey49" #x7d7d7d) ("gray50" #x7f7f7f) ("grey50" #x7f7f7f) ("gray51" #x828282) ("grey51" #x828282) ("gray52" #x858585) ("grey52" #x858585) ("gray53" #x878787) ("grey53" #x878787) ("gray54" #x8a8a8a) ("grey54" #x8a8a8a) ("gray55" #x8c8c8c) ("grey55" #x8c8c8c) ("gray56" #x8f8f8f) ("grey56" #x8f8f8f) ("gray57" #x919191) ("grey57" #x919191) ("gray58" #x949494) ("grey58" #x949494) ("gray59" #x969696) ("grey59" #x969696) ("gray60" #x999999) ("grey60" #x999999) ("gray61" #x9c9c9c) ("grey61" #x9c9c9c) ("gray62" #x9e9e9e) ("grey62" #x9e9e9e) ("gray63" #xa1a1a1) ("grey63" #xa1a1a1) ("gray64" #xa3a3a3) ("grey64" #xa3a3a3) ("gray65" #xa6a6a6) ("grey65" #xa6a6a6) ("gray66" #xa8a8a8) ("grey66" #xa8a8a8) ("gray67" #xababab) ("grey67" #xababab) ("gray68" #xadadad) ("grey68" #xadadad) ("gray69" #xb0b0b0) ("grey69" #xb0b0b0) ("gray70" #xb3b3b3) ("grey70" #xb3b3b3) ("gray71" #xb5b5b5) ("grey71" #xb5b5b5) ("gray72" #xb8b8b8) ("grey72" #xb8b8b8) ("gray73" #xbababa) ("grey73" #xbababa) ("gray74" #xbdbdbd) ("grey74" #xbdbdbd) ("gray75" #xbfbfbf) ("grey75" #xbfbfbf) ("gray76" #xc2c2c2) ("grey76" #xc2c2c2) ("gray77" #xc4c4c4) ("grey77" #xc4c4c4) ("gray78" #xc7c7c7) ("grey78" #xc7c7c7) ("gray79" #xc9c9c9) ("grey79" #xc9c9c9) ("gray80" #xcccccc) ("grey80" #xcccccc) ("gray81" #xcfcfcf) ("grey81" #xcfcfcf) ("gray82" #xd1d1d1) ("grey82" #xd1d1d1) ("gray83" #xd4d4d4) ("grey83" #xd4d4d4) ("gray84" #xd6d6d6) ("grey84" #xd6d6d6) ("gray85" #xd9d9d9) ("grey85" #xd9d9d9) ("gray86" #xdbdbdb) ("grey86" #xdbdbdb) ("gray87" #xdedede) ("grey87" #xdedede) ("gray88" #xe0e0e0) ("grey88" #xe0e0e0) ("gray89" #xe3e3e3) ("grey89" #xe3e3e3) ("gray90" #xe5e5e5) ("grey90" #xe5e5e5) ("gray91" #xe8e8e8) ("grey91" #xe8e8e8) ("gray92" #xebebeb) ("grey92" #xebebeb) ("gray93" #xededed) ("grey93" #xededed) ("gray94" #xf0f0f0) ("grey94" #xf0f0f0) ("gray95" #xf2f2f2) ("grey95" #xf2f2f2) ("gray96" #xf5f5f5) ("grey96" #xf5f5f5) ("gray97" #xf7f7f7) ("grey97" #xf7f7f7) ("gray98" #xfafafa) ("grey98" #xfafafa) ("gray99" #xfcfcfc) ("grey99" #xfcfcfc) ("gray100" #xffffff) ("grey100" #xffffff) ("Indigo" #x4b0082) ("Crimson" #xdc143c))) (defmacro create-colors () `(progn ,@(loop for (name rgb) in +colors+ collect `(defconstant ,(intern (string-upcase name)) ,rgb)))) (eval-when (:compile-toplevel :load-toplevel :execute) (create-colors)) (defun print-html-color-table () (format t "Colors~%") (format t "~%") (loop for (name rgb) in +colors+ do (let ((hex (format nil "~6,'0X" rgb))) (format t "~%" name hex hex))) (format t "
NameRGBAppearance
~a~a 
~%")) ;;; ;;; surface polygonizer code ;;; #| an implicit surface polygonizer, translated from Mesa applications should call polygonize() Authored by Jules Bloomenthal, Xerox PARC. Copyright (c) Xerox Corporation, 1991. All rights reserved. Permission is granted to reproduce, use and distribute this code for any and all purposes, provided that this notice appears in all copies. Ported to Common Lisp by Frank Buss see http://www.unchainedgeometry.com/jbloom/pdf/polygonizer.pdf for the C source |# (defconstant TET 0) (defconstant NOTET 1) ; no tetrahedral decomposition (defconstant RES 10) ; number of converge iterations (defconstant LEFT 0) ; left direction: -x, -i (defconstant RIGHT 1) ; right direction: +x, +i (defconstant BOTTOM 2) ; bottom direction: -y, -j */ (defconstant TOP 3) ; top direction: +y, +j (defconstant NEAR 4) ; near direction: -z, -k (defconstant FAR 5) ; far direction: +z, +k (defconstant LBN 0) ; left bottom near corner (defconstant LBF 1) ; left bottom far corner (defconstant LTN 2) ; left top near corner (defconstant LTF 3) ; left top far corner (defconstant RBN 4) ; right bottom near corner (defconstant RBF 5) ; right bottom far corner (defconstant RTN 6) ; right top near corner (defconstant RTF 7) ; right top far corner ; the LBN corner of cube (i, j, k), corresponds with location ; (start.x+(i-.5)*size, start.y+(j-.5)*size, start.z+(k-.5)*size) (defconstant HASHBIT 5) (defconstant HASHSIZE #.(ash 1 (* 3 HASHBIT))) ; hash table size (32768) (defconstant MASK #.(1- (ash 1 HASHBIT))) (defun HASH (i j k) (logior (ash (logior (ash (logand i MASK) HASHBIT) (logand j MASK)) HASHBIT) (logand k MASK))) (defun BIT-TEST (i bit) (if (logbitp bit i) 1 0)) (defun FLIP (i bit) (logxor i (ash 1 bit))) (defstruct point (x 0.0) (y 0.0) (z 0.0)) (defstruct test ;; location of test (point (make-point) :type point) ;; function value at p (value 0.0) ;; if value is of correct sign (ok nil)) ;; surface vertex (defstruct vertex (position (make-point) :type point) (normal (make-point) :type point)) ;; corner of a cube (defstruct corner ;; (i, j, k) is index within lattice (i 0) (j 0) (k 0) ;;location and function value (x 0.0) (y 0.0) (z 0.0) (value 0.0)) ;; partitioning cell (cube) (defstruct cube ;; lattice location of cube (i 0) (j 0) (k 0) ;; eight corners (corners (let ((corners (make-array 8))) (loop for i from 0 below 8 do (setf (aref corners i) (make-corner))) corners))) ;; cube location (defstruct center ;; cube location (i 0) (j 0) (k 0)) ;; edge (defstruct edge ;; edge corner ids (i1 0) (j1 0) (k1 0) (i2 0) (j2 0) (k2 0) ;; vertex id (vid 0)) ;; parameters, function, storage (defstruct process ;; implicit surface function (parameters: x, y, z; returns a number) (function nil) ;; triangle output function (triproc nil) ;; cube size, normal delta (size 0.0) (delta 0.0) ;; cube range within lattice (bounds 0) ;; start point on surface (start (make-point) :type point) ;; active cubes (cubes '()) ;; surface vertices (vertices (make-array 0 :element-type 'vertex :adjustable t :fill-pointer t)) ;; cube center hash table (centers nil) ;; corner value hash table (corners nil) ;; edge and vertex id hash table (edges nil)) (defconstant LB 0) ;; left bottom edge (defconstant LT 1) ;; left top edge (defconstant LN 2) ;; left near edge (defconstant LF 3) ;; left far edge (defconstant RB 4) ;; right bottom edge (defconstant RT 5) ;; right top edge (defconstant RN 6) ;; right near edge (defconstant RF 7) ;; right far edge (defconstant BN 8) ;; bottom near edge (defconstant BF 9) ;; bottom far edge (defconstant TN 10) ;; top near edge (defconstant TF 11) ;; top far edge (defparameter cubetable (make-array 256 :initial-element nil)) ;; edge: LB, LT, LN, LF, RB, RT, RN, RF, BN, BF, TN, TF (defconstant corner1 (make-array 12 :initial-contents (list LBN LTN LBN LBF RBN RTN RBN RBF LBN LBF LTN LTF))) (defconstant corner2 (make-array 12 :initial-contents (list LBF LTF LTN LTF RBF RTF RTN RTF RBN RBF RTN RTF))) ;; face on left when going corner1 to corner2 (defconstant leftface (make-array 12 :initial-contents (list BOTTOM LEFT LEFT FAR RIGHT TOP NEAR RIGHT NEAR BOTTOM TOP FAR))) ;; face on left when going corner1 to corner2 (defconstant rightface (make-array 12 :initial-contents (list LEFT TOP NEAR LEFT BOTTOM RIGHT RIGHT FAR BOTTOM FAR NEAR TOP))) (defun nextcwedge (edge face) "return next clockwise edge from given edge around given face" (case edge (#.LB (if (= face LEFT) LF BN)) (#.LT (if (= face LEFT) LN TF)) (#.LN (if (= face LEFT) LB TN)) (#.LF (if (= face LEFT) LT BF)) (#.RB (if (= face RIGHT) RN BF)) (#.RT (if (= face RIGHT) RF TN)) (#.RN (if (= face RIGHT) RT BN)) (#.RF (if (= face RIGHT) RB TF)) (#.BN (if (= face BOTTOM) RB LN)) (#.BF (if (= face BOTTOM) LB RF)) (#.TN (if (= face TOP) LT RN)) (#.TF (if (= face TOP) RT LF)))) (defun otherface (edge face) "return face adjoining edge that is not the given face" (let ((other (aref leftface edge))) (if (= face other) (aref rightface edge) other))) (defun makecubetable () "create the 256 entry table for cubical polygonization" (loop for i from 0 below 256 with pos = (make-array 8) do (loop for c from 0 below 8 do (setf (aref pos c) (BIT-TEST i c))) (loop for e from 0 below 12 with done = (make-array 12 :initial-element nil) do (unless (or (aref done e) (= (aref pos (aref corner1 e)) (aref pos (aref corner2 e)))) (loop with ints ='() with start = e and edge = e ;; get face that is to right of edge from pos to neg corner with face = (if (> (aref pos (aref corner1 e)) 0) (aref rightface e) (aref leftface e)) finally (push ints (aref cubetable i)) do (setf edge (nextcwedge edge face)) (setf (aref done edge) t) (unless (= (aref pos (aref corner1 edge)) (aref pos (aref corner2 edge))) (push edge ints) (when (= edge start) (loop-finish)) (setf face (otherface edge face)))))))) (defun setcenter (table i j k) "set (i,j,k) entry of table[]" "return t if already set; otherwise, set and return nil" (let* ((index (HASH i j k)) (centers (aref table index))) (loop for center in centers do (when (and (= (center-i center) i) (= (center-j center) j) (= (center-k center) k)) (return-from setcenter t))) (push (make-center :i i :j j :k k) centers) (setf (aref table index) centers) nil)) (defun setedge (table i1 j1 k1 i2 j2 k2 vid) "set vertex id for edge" (when (or (> i1 i2) (and (= i1 i2) (or (> j1 j2) (and (= j1 j2) (> k1 k2))))) (rotatef i1 i2) (rotatef j1 j2) (rotatef k1 k2)) (let ((index (+ (hash i1 j1 k1) (hash i2 j2 k2)))) (push (make-edge :i1 i1 :j1 j1 :k1 k1 :i2 i2 :j2 j2 :k2 k2 :vid vid) (aref table index)))) (defun getedge (table i1 j1 k1 i2 j2 k2) "return vertex id for edge; return nil if not set" (when (or (> i1 i2) (and (= i1 i2) (or (> j1 j2) (and (= j1 j2) (> k1 k2))))) (rotatef i1 i2) (rotatef j1 j2) (rotatef k1 k2)) (let ((index (+ (hash i1 j1 k1) (hash i2 j2 k2)))) (loop for edge in (aref table index) do (when (and (= (edge-i1 edge) i1) (= (edge-j1 edge) j1) (= (edge-k1 edge) k1) (= (edge-i2 edge) i2) (= (edge-j2 edge) j2) (= (edge-k2 edge) k2)) (return-from getedge (edge-vid edge)))))) (defun converge (p1 p2 v function p) "from two points of differing sign, converge to zero crossing" (let ((pos (make-point :x (point-x p1) :y (point-y p1) :z (point-z p1))) (neg (make-point :x (point-x p2) :y (point-y p2) :z (point-z p2)))) (when (< v 0) (rotatef pos neg)) (loop for i from 0 to RES do (setf (point-x p) (* 0.5 (+ (point-x pos) (point-x neg))) (point-y p) (* 0.5 (+ (point-y pos) (point-y neg))) (point-z p) (* 0.5 (+ (point-z pos) (point-z neg)))) (if (> (funcall function (point-x p) (point-y p) (point-z p)) 0.0) (setf (point-x pos) (point-x p) (point-y pos) (point-y p) (point-z pos) (point-z p)) (setf (point-x neg) (point-x p) (point-y neg) (point-y p) (point-z neg) (point-z p)))))) (defun vector-length (point) (sqrt (+ (* (point-x point) (point-x point)) (* (point-y point) (point-y point)) (* (point-z point) (point-z point))))) (defun vnormal (point p v) "compute unit length surface normal at point" (let* ((function (process-function p)) (f (funcall function (point-x point) (point-y point) (point-z point)))) (setf (point-x v) (- (funcall function (+ (point-x point) (process-delta p)) (point-y point) (point-z point)) f) (point-y v) (- (funcall function (point-x point) (+ (point-y point) (process-delta p)) (point-z point)) f) (point-z v) (- (funcall function (point-x point) (point-y point) (+ (point-z point) (process-delta p))) f) f (vector-length v)) (when (/= 0 f) (setf (point-x v) (/ (point-x v) f)) (setf (point-y v) (/ (point-y v) f)) (setf (point-z v) (/ (point-z v) f))))) (defun vertid (c1 c2 p) "return index for vertex on edge:" "c1->value and c2->value are presumed of different sign" "return saved index if any; else compute vertex and save" (let ((vid (getedge (process-edges p) (corner-i c1) (corner-j c1) (corner-k c1) (corner-i c2) (corner-j c2) (corner-k c2)))) ;; compute only, if not previously computed (unless vid (let ((a (make-point :x (corner-x c1) :y (corner-y c1) :z (corner-z c1))) (b (make-point :x (corner-x c2) :y (corner-y c2) :z (corner-z c2))) (v (make-vertex))) ;; calculate position (converge a b (corner-value c1) (process-function p) (vertex-position v)) ;; calculate normal (vnormal (vertex-position v) p (vertex-normal v)) ;; save vertex (setf vid (length (process-vertices p))) (vector-push-extend v (process-vertices p)) (setedge (process-edges p) (corner-i c1) (corner-j c1) (corner-k c1) (corner-i c2) (corner-j c2) (corner-k c2) vid))) vid)) (defun call-triproc (i1 i2 i3 p) (let ((v1 (aref (process-vertices p) i1)) (v2 (aref (process-vertices p) i2)) (v3 (aref (process-vertices p) i3))) (funcall (process-triproc p) (vertex-position v1) (vertex-position v2) (vertex-position v3) (vertex-normal v1) (vertex-normal v2) (vertex-normal v3)))) (defun docube (cube p) "triangulate the cube directly, without decomposition" "return t, if aborted, nil otherwise" (let ((index 0)) (loop for i from 0 below 8 do (when (> (corner-value (aref (cube-corners cube) i)) 0.0) (incf index (ash 1 i)))) (loop for poly in (aref cubetable index) do (loop for edge in poly with a = -1 and b = -1 and count = 0 do (let ((c1 (aref (cube-corners cube) (aref corner1 edge))) (c2 (aref (cube-corners cube) (aref corner2 edge)))) (let ((c (vertid c1 c2 p))) (when (and (> (incf count) 2) (call-triproc a b c p)) (return-from docube t)) (when (< count 3) (setf a b)) (setf b c))))))) (defun setcorner (p i j k) "return corner with the given lattice location" "set (and cache) its function value" (let* ((index (HASH i j k)) (corners (aref (process-corners p) index)) (cache (make-corner :i i :j j :k k :x (+ (point-x (process-start p)) (* (- i 0.5) (process-size p))) :y (+ (point-y (process-start p)) (* (- j 0.5) (process-size p))) :z (+ (point-z (process-start p)) (* (- k 0.5) (process-size p)))))) (loop for corner in corners do (when (and (= (corner-i corner) i) (= (corner-j corner) j) (= (corner-k corner) k)) (setf (corner-value cache) (corner-value corner)) (return-from setcorner cache))) (setf (corner-i cache) i (corner-j cache) j (corner-k cache) k (corner-value cache) (funcall (process-function p) (corner-x cache) (corner-y cache) (corner-z cache))) (push cache corners) (setf (aref (process-corners p) index) corners) cache)) (defun find-point (sign p x y z) "search for point with value of given sign (0: neg, 1: pos)" (let ((test (make-test :ok t)) (range (process-size p))) (loop for i from 0 below 10000 do (setf (point-x (test-point test)) (+ x (* range (- (random 1.0) 0.5))) (point-y (test-point test)) (+ y (* range (- (random 1.0) 0.5))) (point-z (test-point test)) (+ z (* range (- (random 1.0) 0.5))) (test-value test) (funcall (process-function p) (point-x (test-point test)) (point-y (test-point test)) (point-z (test-point test)))) (when (eql sign (> (test-value test) 0.0)) (return-from find-point test)) ;; slowly expand search outwards (setf range (* range 1.0005))) (setf (test-ok test) nil) test)) (defun dotet (cube c1 c2 c3 c4 p) "triangulate the tetrahedron" "b, c, d should appear clockwise when viewed from a" "return t if client aborts, nil otherwise" (let* ((a (aref (cube-corners cube) c1)) (b (aref (cube-corners cube) c2)) (c (aref (cube-corners cube) c3)) (d (aref (cube-corners cube) c4)) (index 0) (apos (> (corner-value a) 0.0)) (bpos (> (corner-value b) 0.0)) (cpos (> (corner-value c) 0.0)) (dpos (> (corner-value d) 0.0)) (e1 0) (e2 0) (e3 0) (e4 0) (e5 0) (e6 0)) (when apos (incf index 8)) (when bpos (incf index 4)) (when cpos (incf index 2)) (when dpos (incf index 1)) ;; index is now 4-bit number representing one of the 16 possible cases (unless (eql apos bpos) (setf e1 (vertid a b p))) (unless (eql apos cpos) (setf e2 (vertid a c p))) (unless (eql apos dpos) (setf e3 (vertid a d p))) (unless (eql bpos cpos) (setf e4 (vertid b c p))) (unless (eql bpos dpos) (setf e5 (vertid b d p))) (unless (eql cpos dpos) (setf e6 (vertid c d p))) ;; 14 productive tetrahedral cases (0000 and 1111 do not yield polygons (case index (1 (call-triproc e5 e6 e3 p)) (2 (call-triproc e2 e6 e4 p)) (3 (or (call-triproc e3 e5 e4 p) (call-triproc e3 e4 e2 p))) (4 (call-triproc e1 e4 e5 p)) (5 (or (call-triproc e3 e1 e4 p) (call-triproc e3 e4 e6 p))) (6 (or (call-triproc e1 e2 e6 p) (call-triproc e1 e6 e5 p))) (7 (call-triproc e1 e2 e3 p)) (8 (call-triproc e1 e3 e2 p)) (9 (or (call-triproc e1 e5 e6 p) (call-triproc e1 e6 e2 p))) (10 (or (call-triproc e1 e3 e6 p) (call-triproc e1 e6 e4 p))) (11 (call-triproc e1 e5 e4 p)) (12 (or (call-triproc e3 e2 e4 p) (call-triproc e3 e4 e5 p))) (13 (call-triproc e6 e2 e4 p)) (14 (call-triproc e5 e3 e6 p))))) (defconstant facebit #(2 2 1 1 0 0)) (defun testface (i j k old face c1 c2 c3 c4 p) "given cube at lattice (i, j, k), and four corners of face," "if surface crosses face, compute other four corners of adjacent cube" "and add new cube to cube stack" (let ((pos (> (corner-value (aref (cube-corners old) c1)) 0.0)) (bit (aref facebit face))) ;; test if no surface crossing, cube out of bounds, or already visited: (when (or (and (eql (> (corner-value (aref (cube-corners old) c2)) 0.0) pos) (eql (> (corner-value (aref (cube-corners old) c3)) 0.0) pos) (eql (> (corner-value (aref (cube-corners old) c4)) 0.0) pos)) (or (> (abs i) (process-bounds p)) (> (abs j) (process-bounds p)) (> (abs k) (process-bounds p))) (setcenter (process-centers p) i j k)) (return-from testface)) ;; create new cube: (let ((cube (make-cube :i i :j j :k k :corners (make-array 8 :initial-element nil :element-type 'corner)))) (setf (aref (cube-corners cube) (FLIP c1 bit)) (copy-structure (aref (cube-corners old) c1)) (aref (cube-corners cube) (FLIP c2 bit)) (copy-structure (aref (cube-corners old) c2)) (aref (cube-corners cube) (FLIP c3 bit)) (copy-structure (aref (cube-corners old) c3)) (aref (cube-corners cube) (FLIP c4 bit)) (copy-structure (aref (cube-corners old) c4))) (loop for n from 0 below 8 do (unless (aref (cube-corners cube) n) (setf (aref (cube-corners cube) n) (setcorner p (+ i (BIT-TEST n 2)) (+ j (BIT-TEST n 1)) (+ k (BIT-TEST n 0)))))) ;; add cube to top of stack: (push cube (process-cubes p))))) (defun polygonize (function size bounds x y z triproc mode) "polygonize the implicit surface function" "arguments are:" "double function (x, y, z)" "double x, y, z (an arbitrary 3D point)" "the implicit surface function" "return negative for inside, positive for outside" "double size" "width of the partitioning cube" "int bounds" "max. range of cubes (+/- on the three axes) from first" "cube" "double x, y, z" "coordinates of a starting point on or near the surface" "may be defaulted to 0., 0., 0." "int triproc (i1, i2, i3, vertices)" "int i1, i2, i3 (indices into the vertex array)" "VERTICES vertices (the vertex array, indexed from 0)" "called for each triangle" "the triangle coordinates are (for i = i1, i2, i3):" "vertices.ptr[i].position.x, .y, and .z" "vertices are ccw when viewed from the out (positive) side" "in a left-handed coordinate system" "vertex normals point outwards" "return 1 to continue, 0 to abort" "int mode" "TET: decompose cube and polygonize six tetrahedra" "NOTET: polygonize cube directly" "returns error or NULL" (let ((p (make-process :function function :triproc triproc :size size :bounds bounds :delta (/ size (* RES RES)) :centers (make-array HASHSIZE :initial-element '()) :corners (make-array HASHSIZE :initial-element '()) :edges (make-array (* 2 HASHSIZE) :initial-element '())))) (makecubetable) (let ((in (find-point t p x y z)) (out (find-point nil p x y z))) (unless (or in out) (return-from polygonize "can't find starting point")) (converge (test-point in) (test-point out) (test-value in) (process-function p) (process-start p)) ;; push initial cube on stack: (let ((cube (make-cube))) (push cube (process-cubes p)) ;; set corners of initial cube: (loop for n from 0 below 8 do (setf (aref (cube-corners cube) n) (setcorner p (BIT-TEST n 2) (BIT-TEST n 1) (BIT-TEST n 0)))) (setcenter (process-centers p) 0 0 0) (loop while (process-cubes p) do (let* ((c (pop (process-cubes p))) (abort (if (= mode TET) ;; either decompose into tetrahedra and polygonize: (or (dotet c LBN LTN RBN LBF p) (dotet c RTN LTN LBF RBN p) (dotet c RTN LTN LTF LBF p) (dotet c RTN RBN LBF RBF p) (dotet c RTN LBF LTF RBF p) (dotet c RTN LTF RTF RBF p)) ;; or polygonize the cube directly: (docube c p)))) (when abort (return-from polygonize "aborted")) ;; test six face directions, maybe add to stack: (testface (1- (cube-i c)) (cube-j c) (cube-k c) c LEFT LBN LBF LTN LTF p) (testface (1+ (cube-i c)) (cube-j c) (cube-k c) c RIGHT RBN RBF RTN RTF p) (testface (cube-i c) (1- (cube-j c)) (cube-k c) c BOTTOM LBN LBF RBN RBF p) (testface (cube-i c) (1+ (cube-j c)) (cube-k c) c TOP LTN LTF RTN RTF p) (testface (cube-i c) (cube-j c) (1- (cube-k c)) c NEAR LBN LTN RBN RTN p) (testface (cube-i c) (cube-j c) (1+ (cube-k c)) c FAR LBF LTF RBF RTF p))))))) ;;; ;;; OpenGL specific code ;;; (defparameter *screen-width* 640) (defparameter *screen-height* 480) (defparameter *view-rotx* 20.0) (defparameter *view-roty* 30.0) (defparameter *view-rotz* 0.0) (defparameter *seashell* nil) (defparameter *angle* 0.0) (defun draw () (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:with-pushed-matrix (gl:translate -3 0 0) (gl:rotate *view-rotx* 1 0 0) (gl:rotate *view-roty* 0 1 0) (gl:rotate *view-rotz* 0 0 1) (gl:call-list 1)) (sdl::SDL_GL_SwapBuffers)) (defun idle () (incf *angle* 1.0)) (defun reshape (width height) (gl:viewport 0 0 width height) (gl:matrix-mode :projection) (gl:load-identity) (glu:perspective 55 1 0.5 30) (gl:matrix-mode :modelview) (gl:load-identity) (glu:look-at 5.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 -1.0)) (defun torus (x y z) "a torus" (let* ((major 2.5) (minor 1.2) (x2 (* x x)) (y2 (* y y)) (z2 (* z z)) (a (+ x2 y2 z2 (* major major) (- (* minor minor))))) (- (* a a) (* 4.0 (* major major) (+ y2 z2))))) (defun jack (x y z) #I"(1/(x^^2/9+4*y^^2+4*z^^2)^^4 +1/(y^^2/9+4*x^^2+4*z^^2)^^4 +1/(z^^2/9+4*y^^2+4*x^^2)^^4 +1/((4*x/3-4)^^2+16*y^^2/9+16*z^^2/9)^^4 +1/((4*x/3+4)^^2+16*y^^2/9+16*z^^2/9)^^4 +1/((4*y/3-4)^^2+16*x^^2/9+16*z^^2/9)^^4 +1/((4*y/3+4)^^2+16*x^^2/9+16*z^^2/9)^^4)^^(-1/4)-1") (defparameter *triangle-count* 0) (defun triangle (p1 p2 p3 n1 n2 n3) (incf *triangle-count*) (gl:begin :triangles) (gl:normal (point-x n1) (point-y n1) (point-z n1)) (gl:vertex (point-x p1) (point-y p1) (point-z p1)) (gl:normal (point-x n2) (point-y n2) (point-z n2)) (gl:vertex (point-x p2) (point-y p2) (point-z p2)) (gl:normal (point-x n3) (point-y n3) (point-z n3)) (gl:vertex (point-x p3) (point-y p3) (point-z p3)) (gl:end)) (defun clear-color-rgb (rgb) (gl:clear-color (/ (logand (ash rgb -16) #xff) 256.0) (/ (logand (ash rgb -8) #xff) 256.0) (/ (logand rgb #xff) 256.0) 1.0)) (defun color-rgb (rgb) (gl:color (/ (logand (ash rgb -16) #xff) 256.0) (/ (logand (ash rgb -8) #xff) 256.0) (/ (logand rgb #xff) 256.0) 1.0)) (defun init () (gl:new-list 1 :compile) (setf *triangle-count* 0) (format t "~a~%" (polygonize #'jack 0.15 50 0.0 0.0 0.0 #'triangle TET)) ; (format t "~a~%" (polygonize #'torus 0.10 100 0.0 0.0 0.0 #'triangle TET)) (format t "number of triangles: ~a~%" *triangle-count*) (gl:end-list) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :color-material :lighting :light0 :depth-test :normalize) (gl:color-material :front-and-back :ambient-and-diffuse) (color-rgb LawnGreen) (clear-color-rgb LightSkyBlue) (gl:shade-model :smooth)) (defun run () (sdl::with-init () (let ((display (sdl::set-window *screen-width* *screen-height* :flags sdl::SDL_OPENGL))) (sdl::SDL_WM_SetCaption "Polygonizer" "Polygonizer") (init) (reshape *screen-width* *screen-height*) (sdl::with-events (:quit t) (:keydown (state scancode key mod unicode) (if (sdl::is-key key :SDLK_ESCAPE) (sdl::push-quitevent))) (:mousemotion (state x y xrel yrel) (when (= state 1) (incf *view-rotz* xrel) (incf *view-rotx* xrel) (incf *view-roty* yrel ))) (:idle (draw) (idle))))))