'From Squeak3.7alpha of ''11 September 2003'' [latest update: #5623] on 3 January 2004 at 5:17:08 pm'! "Change Set: PSFixes-nk Date: 15 January 2003 Author: Ned Konz 15 January: * removed IndentingListItemMorphWithIcon fixes (part of another package) 4 January: * better DSC compatibility * include DocumentFonts: at end A number of fixes to the Postscript output routines: * fix the bounding box and offset problems * make the EPS output closer to valid * use the right file extension * make Bezier curve drawing more robust * SimpleBorders are rendered more cleanly * Move font mapping to the class side of PostscriptCanvas * Render list item morphs with icons better I tried to get the filled curves (Polygons, Beziers) to account for the difference in the Postscript imaging model, but couldn't get it to look right by clipping in the center of the borderline. So these filled curves are going to be too large by half their border width. Rectangles have their border drawing compensated for this effect. Font mapping is still not very good, but you can edit the table if you want now. There is not yet any API for doing this, but you can open an Inspector on PostscriptCanvas fontMap to edit the map. "! Canvas subclass: #PostscriptCanvas instanceVariableNames: 'origin clipRect currentColor currentFont morphLevel gstateStack fontMap usedFonts psBounds topLevelMorph initialScale savedMorphExtent currentTransformation printSpecs pages ' classVariableNames: 'FontMap ' poolDictionaries: '' category: 'Morphic-Postscript Canvases'! !ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:01'! nextPut: encodedObject "pass through for stream compatibility" ^target nextPut: encodedObject. ! ! !ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:00'! nextPutAll: encodedObject "pass through for stream compatibility" ^target nextPutAll: encodedObject. ! ! !Canvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'! isPostscriptCanvas ^false! ! !Collection methodsFor: '*connectors-truncation and round-off' stamp: 'nk 12/30/2003 15:47'! roundTo: quantum ^self collect: [ :ea | ea roundTo: quantum ]! ! !Form methodsFor: 'fileIn/Out' stamp: 'nk 12/31/2003 16:06'! store15To24HexBitsOn:aStream | buf i lineWidth | "write data for 16-bit form, optimized for encoders writing directly to files to do one single file write rather than 12. I'm not sure I understand the significance of the shifting pattern, but I think I faithfully translated it from the original" lineWidth _ 0. buf _ String new: 12. bits do: [:word | i _ 0. "upper pixel" buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -32) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -17) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 8) asHexDigit. "lower pixel" buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -16) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -1) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 8) asHexDigit. aStream nextPutAll: buf. lineWidth _ lineWidth + 12. lineWidth > 100 ifTrue: [ aStream cr. lineWidth _ 0 ]. "#( 31 26 21 15 10 5 ) do:[:startBit | ]" ].! ! !Form methodsFor: '*morphic-Postscript Canvases' stamp: 'nk 12/31/2003 15:46'! printPostscript: aStream operator: operator aStream preserveStateDuring: [:inner | inner rectclip: (0 @ 0 extent: width @ height). self setColorspaceOn: inner. inner print: '[ '; cr; print: '/ImageType 1'; cr; print: '/ImageMatrix [1 0 0 1 0 0]'; cr; print: '/MultipleDataSources false'; cr; print: '/DataSource level1 { { currentfile '; write: self bytesPerRow; print: ' string readhexstring pop }} bind { currentfile /ASCIIHexDecode filter } ifelse'; cr; print: '/Width '; write: self paddedWidth; cr; print: '/Height '; write: self height; cr; print: '/Decode '; print: self decodeArray; cr; print: '/BitsPerComponent '; write: self bitsPerComponent; cr; print: 'makeDict '; print: operator; cr. self storePostscriptHexOn: inner. inner print: $>; cr. inner cr]. aStream cr! ! !Form methodsFor: '*morphic-Postscript Canvases' stamp: 'nk 12/31/2003 15:46'! storePostscriptHexOn: inner self depth <= 8 ifTrue: [self storeHexBitsOn: inner]. self depth = 16 ifTrue: [self store15To24HexBitsOn: inner]. self depth = 32 ifTrue: [self store32To24HexBitsOn: inner]! ! !Morph methodsFor: 'menus' stamp: 'nk 12/29/2003 13:18'! printPSToFileNamed: aString "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag psCanvasType psExtension | fileName := aString asFileName. psCanvasType _ PostscriptCanvas defaultCanvasType. psExtension _ psCanvasType defaultExtension. fileName := FillInTheBlank request: (String streamContents: [ :s | s nextPutAll: 'File name? ("' translated; nextPutAll: psExtension; nextPutAll: '" will be added to end)' translated ]) initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: psExtension) ifFalse: [fileName := fileName , psExtension]. rotateFlag := ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName) nextPutAll: (psCanvasType morphAsPostscript: self rotated: rotateFlag); close! ! !Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'nk 12/29/2003 10:55'! printPSToFile self printPSToFileNamed: self externalName! ! !BookMorph methodsFor: 'printing' stamp: 'nk 12/30/2003 16:40'! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ ('MyBook') translated asFileName. fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close. ! ! !PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 12/28/2003 17:42'! deferred: ignored! ! !PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 1/2/2004 01:12'! drawGeneralBezierShape: shapeArray color: color borderWidth: borderWidth borderColor: borderColor "shapeArray is an array of: arrays of points, each of which must have a multiple of 3 points in it. This method tries to sort the provided triplets so that curves that start and end at the same point are together." | where triplets groups g2 | shapeArray isEmpty ifTrue: [^ self]. where := nil. groups := OrderedCollection new. triplets := OrderedCollection new. shapeArray do: [ :arr | arr groupsOf: 3 atATimeDo: [ :bez | | rounded | rounded := bez roundTo: 0.001. (where isNil or: [ where = rounded first ]) ifFalse: [ groups addLast: triplets. triplets := OrderedCollection new ]. triplets addLast: rounded. where := rounded last. ]]. groups addLast: triplets. triplets := OrderedCollection new. "now try to merge stray groups" groups copy do: [ :g1 | g1 first first = g1 last last ifFalse: [ "not closed" g2 := groups detect: [ :g | g ~~ g1 and: [ g1 last last = g first first ] ] ifNone: [ ]. g2 ifNotNil: [ groups remove: g2. groups add: g2 after: g1 ]] ]. groups do: [ :g | triplets addAll: g ]. where := nil. self preserveStateDuring: [:cvs | target definePathProcIn: [ :tgt | triplets do: [ :shape | where ~= shape first ifTrue: [where ifNotNil: [target closepath]. cvs moveto: shape first]. where := cvs outlineQuadraticBezierShape: shape]. target closepath ] during: [ :tgt | "target executePathProc. target clip." target executePathProc. cvs setLinewidth: borderWidth "* 2"; fill: color andStroke: borderColor]]! ! !PostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:47'! fullDraw: aMorph self comment: 'start morph: ' with: aMorph. self comment: 'level: ' with: morphLevel. self comment: 'bounds: ' with: aMorph bounds. self comment: 'corner: ' with: aMorph bounds corner. morphLevel := morphLevel + 1. self setupGStateForMorph: aMorph. aMorph fullDrawPostscriptOn: self. self endGStateForMorph: aMorph. morphLevel := morphLevel - 1. self comment: 'end morph: ' with: aMorph. self comment: 'level: ' with: morphLevel. ! ! !PostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:00'! fullDrawBookMorph:aBookMorph ^aBookMorph fullDrawOn:self. ! ! !PostscriptCanvas methodsFor: 'drawing-polygons' stamp: 'nk 12/29/2003 20:06'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc self preserveStateDuring: [:pc | pc outlinePolygon: vertices; setLinewidth: bw; fill: aColor andStroke: ((bc isKindOf: Symbol) ifTrue: [Color gray] ifFalse: [bc])]! ! !PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'nk 12/29/2003 20:10'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor "since postscript strokes on the line and squeak strokes inside, we need to adjust inwards" self preserveStateDuring: [:pc | pc rect: (r insetBy: borderWidth / 2); setLinewidth: borderWidth; fill: fillColor andStroke: borderColor]! ! !PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'nk 12/29/2003 16:27'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor self preserveStateDuring: [:pc | target newpath. pc setLinewidth: 0. pc outlinePolygon: {r origin. r topRight. r topRight + (borderWidth negated @ borderWidth). r origin + (borderWidth @ borderWidth). r bottomLeft + (borderWidth @ borderWidth negated). r bottomLeft. r origin}; fill: topLeftColor andStroke: topLeftColor. target newpath. pc outlinePolygon: {r topRight. r bottomRight. r bottomLeft. r bottomLeft + (borderWidth @ borderWidth negated). r bottomRight - (borderWidth @ borderWidth). r topRight + (borderWidth negated @ borderWidth). r topRight}; fill: bottomRightColor andStroke: bottomRightColor]! ! !PostscriptCanvas methodsFor: 'drawing-text' stamp: 'nk 12/30/2003 17:50'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c background: b target preserveStateDuring: [ :t | self fillRectangle: boundsRect color: b ]. self drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c ! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'nk 1/2/2004 16:15'! reset super reset. origin _ 0@0. "origin of the top-left corner of this cavas" clipRect _ (0@0 corner: 10000@10000). "default clipping rectangle" currentTransformation _ nil. morphLevel _ 0. pages _ 0. gstateStack _ OrderedCollection new. usedFonts _ Dictionary new. initialScale _ 1.0! ! !PostscriptCanvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:08'! canBlendAlpha ^false! ! !PostscriptCanvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'! isPostscriptCanvas ^true! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 12/29/2003 09:51'! comment: aString with: anObject target comment:aString with:anObject. ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 15:34'! defineFont: aFont | psNameFor alreadyRemapped | (usedFonts includesKey: aFont) ifFalse:[ psNameFor _ self postscriptFontNameForFont: aFont. alreadyRemapped _ usedFonts includes: psNameFor. usedFonts at: aFont put: psNameFor. " here: define as Type-3 unless we think its available " " or, just remap" " I had some problems if same font remapped twice" alreadyRemapped ifFalse: [target remapFontForSqueak: psNameFor]. ].! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:54'! drawPage:aMorph self fullDrawMorph:aMorph. ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:18'! drawPages:collectionOfPages collectionOfPages do:[ :page | pages _ pages + 1. target print:'%%Page: '; write:pages; space; write:pages; cr. self drawPage:page. ]. morphLevel = 0 ifTrue: [ self writeTrailer: pages ].! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:53'! endGStateForMorph: aMorph morphLevel == 1 ifTrue: [ target showpage; print: 'grestore'; cr ]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 12/28/2003 21:08'! fill: fillColor fillColor isSolidFill ifTrue: [self paint: fillColor asColor operation: #eofill] ifFalse: [self preserveStateDuring: [:inner | inner clip; drawGradient: fillColor]]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 22:29'! outlineQuadraticBezierShape: vertices | where | 3 to: vertices size by: 3 do: [:i | | v1 v2 v3 | v1 := (vertices at: i - 2) roundTo: 0.001. v2 := (vertices at: i - 1) roundTo: 0.001. v3 := (vertices at: i) roundTo: 0.001. (v1 = v2 or: [v2 = v3]) ifTrue: [target lineto: v3] ifFalse: [target curvetoQuadratic: v3 from: v1 via: v2]. where := v3]. ^where! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 22:18'! postscriptFontNameForFont: font ^(self class postscriptFontInfoForFont: font) first ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 01:16'! setFont:aFont | fInfo | aFont = currentFont ifTrue: [^self]. currentFont _ aFont. self defineFont: aFont. fInfo _ self class postscriptFontInfoForFont: aFont. target selectflippedfont: fInfo first size: (aFont pointSize * fInfo second) ascent: aFont ascent. ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:42'! setupGStateForMorph: aMorph morphLevel == 1 ifTrue: [self writePageSetupFor: aMorph]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 20:24'! writeGlobalSetup: rotateFlag target print: '%%EndProlog'; cr. target print: '%%BeginSetup'; cr. target print: '% initialScale: '; write: initialScale; cr. target print: '% pageBBox: '; write: self pageBBox; cr. target print: '% pageOffset'; cr. target translate: self pageOffset. rotateFlag ifTrue: ["no translate needed for 0,0 = upper LH corner of page" target print: '90 rotate'; cr; print: '0 0 translate'; cr] ifFalse: [target write: 0 @ topLevelMorph height * initialScale; print: ' translate'; cr]. target print: '% flip'; cr. target scale: initialScale @ initialScale negated; print: ' [ {true setstrokeadjust} stopped ] pop'; cr. target print: '%%EndSetup'; cr! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 17:50'! writeHeaderRotated: rotateFlag self writePSIdentifierRotated: rotateFlag. self writeProcset. self writeGlobalSetup: rotateFlag.! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:37'! writePageSetupFor: aMorph target print: '%%BeginPageSetup'; cr. target print: 'gsave'; cr. target translate: aMorph bounds origin negated. target print: '%%EndPageSetup'; cr! ! !PostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 15:44'! writeTrailer: pages target print: '%%Trailer'; cr. usedFonts isEmpty ifFalse: [target print: '%%DocumentFonts:'. usedFonts values asSet do: [:f | target space; print: f]. target cr]. target print:'%%Pages: '; write: pages; cr. target print: '%%EOF'; cr! ! !DSCPostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53'! fullDraw: aMorph (morphLevel = 0 and: [aMorph pagesHandledAutomatically not]) ifTrue: [pages _ pages + 1. target print: '%%Page: 1 1'; cr]. super fullDraw: aMorph. morphLevel = 0 ifTrue: [ self writeTrailer: pages. ]! ! !DSCPostscriptCanvas methodsFor: 'initialization' stamp: 'nk 1/2/2004 15:36'! writePSIdentifierRotated: rotateFlag | morphExtent pageExtent | target print: '%!!PS-Adobe-2.0'; cr; print: '%%Pages: (atend)'; cr; print: '%%DocumentFonts: (atend)'; cr. "Define initialScale so that the morph will fit the page rotated or not" savedMorphExtent := morphExtent := rotateFlag ifTrue: [psBounds extent transposed] ifFalse: [psBounds extent]. pageExtent := self defaultImageableArea extent asFloatPoint. initialScale := (printSpecs isNil or: [printSpecs scaleToFitPage]) ifTrue: [pageExtent x / morphExtent x min: pageExtent y / morphExtent y] ifFalse: [1.0]. target print: '%%BoundingBox: '; write: self defaultImageableArea; cr. target print: '%%Title: '; print: self topLevelMorph externalName; cr. target print: '%%Creator: '; print: Utilities authorName; cr. target print: '%%CreationDate: '; print: Date today asString; space; print: Time now asString; cr. target print: '%%Orientation: '; print: (rotateFlag ifTrue: ['Landscape'] ifFalse: ['Portrait']); cr. target print: '%%EndComments'; cr. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:53'! endGStateForMorph: aMorph "position the morph on the page " morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue: [ target showpage; print: 'grestore'; cr ]! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:18'! fullDrawBookMorph: aBookMorph " draw all the pages in a book morph, but only if it is the top-level morph " morphLevel = 1 ifFalse: [^ super fullDrawBookMorph: aBookMorph]. "Unfortunately, the printable 'pages' of a StackMorph are the cards, but for a BookMorph, they are the pages. Separate the cases here." (aBookMorph isKindOf: StackMorph) ifTrue: [ aBookMorph cards do: [:aCard | aBookMorph goToCard: aCard. "cause card-specific morphs to be installed" pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aBookMorph pages]] ifFalse: [ aBookMorph pages do: [:aPage | pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aPage]]. morphLevel = 0 ifTrue: [ self writeTrailer: pages ]. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/1/2004 18:21'! setupGStateForMorph: aMorph "position the morph on the page " morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue: [ self writePageSetupFor: aMorph ]! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 19:56'! pageBBox | pageSize offset bbox trueExtent | trueExtent := savedMorphExtent * initialScale. "this one has been rotated" pageSize := self defaultPageSize. offset := pageSize extent - trueExtent / 2 max: 0 @ 0. bbox := offset extent: trueExtent. ^ bbox! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 12/30/2003 17:22'! pageOffset ^self pageBBox origin. ! ! !DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 17:39'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil self reset. psBounds := offset extent: aMorph bounds extent. topLevelMorph := aMorph. self writeHeaderRotated: rotateFlag. self fullDrawMorph: aMorph. ^ self close! ! !EPSCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53'! fullDraw: aMorph super fullDraw: aMorph. morphLevel = 0 ifTrue: [ self writeTrailer: 1. ]! ! !EPSCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 18:29'! pageBBox ^psBounds! ! !EPSCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 20:22'! pageOffset ^0@0! ! !EPSCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 12:48'! writeEPSPreviewImageFor: aMorph | form stream string lines newExtent | newExtent _ (aMorph width roundUpTo: 8) @ aMorph height. form _ aMorph imageForm: 1 forRectangle: (aMorph bounds origin extent: newExtent). stream _ RWBinaryOrTextStream on: (String new: (form bits byteSize * 2.04) asInteger). form storePostscriptHexOn: stream. string _ stream contents. lines _ string occurrencesOf: Character cr. "%%BeginPreview: 80 24 1 24" "width height depth " target print: '%%BeginPreview: '; write: newExtent; space; write: form depth; space; write: lines; cr. stream position: 0. [ stream atEnd ] whileFalse: [ target nextPut: $%; nextPutAll: (stream upTo: Character cr); cr. lines _ lines - 1. ]. target print: '%%EndPreview'; cr. ! ! !EPSCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:31'! writePSIdentifierRotated: rotateFlag target print: '%!!PS-Adobe-2.0 EPSF-2.0'; cr. rotateFlag ifTrue: [target print: '%%BoundingBox: '; write: (0 @ 0 corner: psBounds corner transposed) rounded; cr] ifFalse: [target print: '%%BoundingBox: '; write: psBounds rounded; cr]. target print: '%%Title: '; print: self topLevelMorph externalName; cr. target print: '%%Creator: '; print: Utilities authorName; cr. target print: '%%CreationDate: '; print: Date today asString; space; print: Time now asString; cr. "is this relevant?" target print: '%%Orientation: '; print: (rotateFlag ifTrue: [ 'Landscape' ] ifFalse: [ 'Portrait' ]); cr. target print: '%%DocumentFonts: (atend)'; cr. target print: '%%EndComments'; cr " self writeEPSPreviewImageFor: topLevelMorph." " target print: '%%EndProlog'; cr."! ! !PostscriptCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'! defaultExtension ^ '.ps'! ! !PostscriptCanvas class methodsFor: 'testing' stamp: 'nk 1/1/2004 20:21'! morphAsPostscript:aMorph rotated:rotateFlag offsetBy:offset | psCanvas | psCanvas _ self new. psCanvas reset. psCanvas bounds: (0@0 extent: (aMorph bounds extent + (2 * offset))). psCanvas topLevelMorph:aMorph. psCanvas resetContentRotated: rotateFlag. psCanvas fullDrawMorph: aMorph . ^psCanvas contents. ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:32'! convertFontName: aName "Break apart aName on case boundaries, inserting hyphens as needed." | lastCase | lastCase _ aName first isUppercase. ^ String streamContents: [ :s | aName do: [ :c | | thisCase | thisCase _ c isUppercase. (thisCase and: [ lastCase not ]) ifTrue: [ s nextPut: $- ]. lastCase _ thisCase. s nextPut: c ]]! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:20'! fontMap "Answer the font mapping dictionary. Made into a class var so that it can be edited." ^FontMap ifNil: [ self initializeFontMap. FontMap ].! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:26'! fontSampler "Produces a Postscript .eps file on disk, returns a Morph." "PostscriptCanvas fontSampler" "PostscriptCanvas fontSampler openInWorld" | morph file | morph _ Morph new layoutPolicy: TableLayout new; listDirection: #topToBottom; wrapDirection: #leftToRight; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color white. TextStyle actualTextStyles keysAndValuesDo: [ :styleName :style | { style fontArray first. style fontArray last } do: [ :baseFont | | info | 0 to: 2 do: [ :i | | font string string2 textMorph row | font _ baseFont emphasized: i. string _ font fontNameWithPointSize. row _ Morph new layoutPolicy: TableLayout new; listDirection: #topToBottom; hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellSpacing: 20@0; color: Color white. textMorph _ TextMorph new hResizing: #spaceFill; backgroundColor: Color white; beAllFont: font; contentsAsIs: string. row addMorphBack: (textMorph imageForm asMorph). info _ self postscriptFontInfoForFont: font. string2 _ String streamContents: [ :stream | stream nextPutAll: info first; space; print: (font pointSize * info second) rounded. ]. textMorph _ TextMorph new hResizing: #spaceFill; backgroundColor: Color white; beAllFont: font; contentsAsIs: string2. row addMorphBack: textMorph. morph addMorphBack: row. ] ] ]. morph bounds: World bounds. morph layoutChanged; fullBounds. file _ (FileDirectory default newFileNamed: 'PSFontSampler.eps'). Cursor wait showWhile: [ file nextPutAll: (EPSCanvas morphAsPostscript: morph) ]. ^morph! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForAccuAt | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica-Bold' 1.0); at: 1 put: #('Helvetica-Bold' 1.0); at: 2 put: #('Helvetica-BoldOblique' 1.0); at: 3 put: #('Helvetica-BoldOblique' 1.0). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForComicBold | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica-Narrow-Bold' 0.9); at: 1 put: #('Helvetica-Narrow-Bold' 0.9); at: 2 put: #('Helvetica-Narrow-BoldOblique' 0.9); at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.9). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForComicPlain | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" "how do we do underlined??" d _ Dictionary new. d at: 0 put: #('Helvetica-Narrow' 0.9); at: 1 put: #('Helvetica-Narrow-Bold' 0.9); at: 2 put: #('Helvetica-Narrow-Oblique' 0.9); at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.9). ^d ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForHelvetica | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica' 1.0); at: 1 put: #('Helvetica-Bold' 1.0); at: 2 put: #('Helvetica-Oblique' 1.0); at: 3 put: #('Helvetica-BoldOblique' 1.0); at: 8 put: #('Helvetica-Narrow' 1.0); at: 9 put: #('Helvetica-Narrow-Bold' 1.0); at: 10 put: #('Helvetica-Narrow-Oblique' 1.0); at: 11 put: #('Helvetica-Narrow-BoldOblique' 1.0). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForNewYork | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Times-Roman' 1.0); at: 1 put: #('Times-Bold' 1.0); at: 2 put: #('Times-Italic' 1.0); at: 3 put: #('Times-BoldItalic' 1.0); at: 8 put: #('Helvetica-Narrow' 1.0); at: 9 put: #('Helvetica-Narrow-Bold' 1.0); at: 10 put: #('Helvetica-Narrow-Oblique' 1.0); at: 11 put: #('Helvetica-Narrow-BoldOblique' 1.0). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForPalatino | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Palatino-Roman' 1.0); at: 1 put: #('Palatino-Bold' 1.0); at: 2 put: #('Palatino-Italic' 1.0); at: 3 put: #('Palatino-BoldItalic' 1.0). ^d ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 23:05'! initializeFontMap "Initialize the dictionary mapping font names to substitutions for Postscript code generation." "PostscriptCanvas initializeFontMap" | f | FontMap := Dictionary new. FontMap at: 'NewYork' put: (f _ self fontsForNewYork); at: 'Accuny' put: f; at: 'Helvetica' put: (f _ self fontsForHelvetica); at: 'Accujen' put: f; at: 'Palatino' put: self fontsForPalatino; at: 'ComicBold' put: (f _ self fontsForComicBold); at: 'Accuat' put: self fontsForAccuAt; at: 'ComicPlain' put: self fontsForComicPlain! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:34'! postscriptFontInfoForFont: font | fontName desired mask lengthToUse | fontName _ font familyName asString. lengthToUse _ fontName size. [lengthToUse > 0] whileTrue: [ self fontMap at: (fontName first: lengthToUse) ifPresent: [ :subD | desired _ font emphasis. mask _ 31. [ desired _ desired bitAnd: mask. subD at: desired ifPresent: [ :answer | ^answer]. mask _ mask bitShift: -1. desired > 0 ] whileTrue. ]. lengthToUse _ lengthToUse - 1. ]. "fontName _ self convertFontName: fontName." "(font emphasis == 0 and: [ (fontName includesSubString: '-Roman') not ]) ifTrue: [ fontName _ fontName,'-Roman' ]." (font emphasis == 1 and: [ (fontName includesSubString: '-Bold') not ]) ifTrue: [ fontName _ fontName,'-Bold' ]. (font emphasis == 2 and: [ (fontName includesSubString: '-Italic') not ]) ifTrue: [ fontName _ fontName,'-Italic' ]. (font emphasis == 3 and: [ (fontName includesSubString: '-BoldItalic') not ]) ifTrue: [ fontName _ fontName,'-BoldItalic' ]. ^ {fontName. 1.0} ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:50'! postscriptFontMappingSummary " Transcript nextPutAll: PostscriptCanvas postscriptFontMappingSummary ; endEntry " | stream | stream _ WriteStream on: (String new: 1000). TextStyle actualTextStyles keysAndValuesDo: [ :styleName :style | stream nextPutAll: styleName; cr. style fontArray do: [ :baseFont | | info | 0 to: 3 do: [ :i | | font | font _ baseFont emphasized: i. stream tab; nextPutAll: font fontNameWithPointSize; tab. info _ self postscriptFontInfoForFont: font. stream nextPutAll: info first; space; print: (font pointSize * info second) rounded. stream cr. ] ] ]. ^stream contents! ! !DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 16:58'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil | newFileName stream | ^[ (self new morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset) close ] on: PickAFileToWriteNotification do: [ :ex | newFileName _ FillInTheBlank request: 'Name of file to write:' translated initialAnswer: 'xxx',Time millisecondClockValue printString, self defaultExtension. newFileName isEmptyOrNil ifFalse: [ stream _ FileStream fileNamed: newFileName. stream ifNotNil: [ex resume: stream]. ]. ]. ! ! !EPSCanvas class methodsFor: 'configuring' stamp: 'nk 1/1/2004 20:22'! baseOffset ^0@0.! ! !EPSCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'! defaultExtension ^'.eps'! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/29/2003 16:01'! definePathProcIn: pathBlock during: aBlock "Bracket the output of pathBlock (which is passed the receiver) in an anonymous procedure, pushed on the PS stack. Drop the procedure at the end of execution of aBlock (which is also passed the receiver). Inside aBlock, the proc can be executed using executePathProc" | retval | self comment: 'begin pathProc'. self print: '{'; cr. pathBlock value: self. self print: '}'; cr. retval _ aBlock value: self. self comment: 'end pathProc'. ^ retval! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/28/2003 21:09'! eofill self print: 'eofill'; cr. ! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/29/2003 16:02'! executePathProc self print: 'dup exec'; cr.! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/29/2003 15:56'! preserveStateDuring: aBlock "Note that this method supplies self, an encoder, to the block" | retval | self print: 'gsave'; cr. retval := aBlock value: self. self print: 'grestore'; cr. ^ retval! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/30/2003 17:24'! rect: aRect self newpath. self moveto:aRect topLeft; lineto:aRect topRight x @ aRect topRight y; lineto:aRect bottomRight x @ aRect bottomRight y; lineto:aRect bottomLeft x @ aRect bottomLeft y; closepath. ! ! !SequenceableCollection methodsFor: '*connectors-enumerating' stamp: 'nk 12/30/2003 15:39'! groupsOf: n atATimeCollect: aBlock "Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end. Allows use of a flattened array for things that naturally group into groups of n. If aBlock has a single argument, pass it an array of n items, otherwise, pass the items as separate arguments. See also pairsDo:" | passArray args | passArray := aBlock numArgs = 1. ^(n to: self size by: n) collect: [:index | args := (self copyFrom: index - n + 1 to: index) asArray. passArray ifTrue: [aBlock value: args] ifFalse: [aBlock valueWithArguments: args]]! ! !SequenceableCollection methodsFor: '*connectors-enumerating' stamp: 'nk 12/30/2003 15:37'! groupsOf: n atATimeDo: aBlock "Evaluate aBlock with my elements taken n at a time. Ignore any leftovers at the end. Allows use of a flattened array for things that naturally group into groups of n. If aBlock has a single argument, pass it an array of n items, otherwise, pass the items as separate arguments. See also pairsDo:" | passArray args | passArray := (aBlock numArgs = 1). n to: self size by: n do: [:index | args := (self copyFrom: index - n + 1 to: index) asArray. passArray ifTrue: [ aBlock value: args ] ifFalse: [ aBlock valueWithArguments: args ]].! ! !Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02'! storeBits: startBit to: stopBit on: aStream "Store my bits as a hex string, breaking the lines every 100 bytes or so to comply with the maximum line length limits of Postscript (255 bytes). " | lineWidth | lineWidth := 0. self do: [:word | startBit to: stopBit by: -4 do: [:shift | aStream nextPut: (word >> shift bitAnd: 15) asHexDigit. lineWidth := lineWidth + 1]. (lineWidth > 100) ifTrue: [aStream cr. lineWidth := 0]]. lineWidth > 0 ifTrue: [ aStream cr ].! ! !TTCFont methodsFor: 'private' stamp: 'nk 1/1/2004 21:47'! indexOfSubfamilyName: aName NamesToIndexes ifNil: [ NamesToIndexes := Dictionary new. NamesToIndexes at: 'Regular' put: 0; at: 'Roman' put: 0; at: 'Medium' put: 0; at: 'Bold' put: 1; at: 'Italic' put: 2; at: 'Oblique' put: 2; at: 'BoldItalic' put: 3; at: 'BoldOblique' put: 3. ]. "If you get a halt here - please add the missing synonym to the lookup table above." ^NamesToIndexes at: (aName copyWithout: Character space) ifAbsent: [ self error: 'please add the missing synonym ', aName, ' to the lookup table in TTCFont>>indexOfSubfamilyName:.' ].! ! !TextMorph methodsFor: 'drawing' stamp: 'nk 1/1/2004 21:10'! drawNullTextOn: aCanvas "make null text frame visible" aCanvas isPostscriptCanvas ifFalse: [ aCanvas fillRectangle: bounds color: ((Color black) alpha: 0.1). ]! ! EPSCanvas class removeSelector: #bobsPostScriptHacks! PostscriptCanvas class removeSelector: #fullDrawBookMorph:! EPSCanvas removeSelector: #setupGStateForMorph:! EPSCanvas removeSelector: #writeEPSPreviewImage! !EPSCanvas reorganize! ('drawing-general' fullDraw:) ('page geometry' pageBBox pageOffset) ('private' writeEPSPreviewImageFor: writePSIdentifierRotated:) ! DSCPostscriptCanvas removeSelector: #writeTrailer! !DSCPostscriptCanvas reorganize! ('drawing-general' fullDraw:) ('initialization' writePSIdentifierRotated:) ('morph drawing' endGStateForMorph: fullDrawBookMorph: setupGStateForMorph:) ('page geometry' defaultImageableArea defaultMargin defaultPageSize pageBBox pageOffset) ! PostscriptCanvas removeSelector: #convertFontName:! PostscriptCanvas removeSelector: #fontsForComicBold! PostscriptCanvas removeSelector: #fontsForComicPlain! PostscriptCanvas removeSelector: #fontsForHelvetica! PostscriptCanvas removeSelector: #fontsForNewYork! PostscriptCanvas removeSelector: #fontsForPalatino! PostscriptCanvas removeSelector: #initializeFontMap! PostscriptCanvas removeSelector: #outlineQuardraticBezierShape:! PostscriptCanvas removeSelector: #postscriptFontInfoForFont:! PostscriptCanvas removeSelector: #writeSetupForRect:! PostscriptCanvas removeSelector: #writeTrailer! Canvas subclass: #PostscriptCanvas instanceVariableNames: 'origin clipRect currentColor currentFont morphLevel gstateStack fontMap usedFonts psBounds topLevelMorph initialScale savedMorphExtent currentTransformation printSpecs pages' classVariableNames: 'FontMap' poolDictionaries: '' category: 'Morphic-Postscript Canvases'! !PostscriptCanvas reorganize! ('accessing' clipRect contentsOfArea:into: origin) ('balloon compatibility' aaLevel: asBalloonCanvas deferred: drawGeneralBezierShape:color:borderWidth:borderColor: drawOval:color:borderWidth:borderColor: drawRectangle:color:borderWidth:borderColor: infiniteFillRectangle:fillStyle: setOrigin:clipRect: transformBy: transformBy:during: warpFrom:toRect:) ('drawing' fillColor: line:to:brushForm: line:to:width:color: paragraph:bounds:color:) ('drawing-general' draw: fullDraw: fullDrawBookMorph:) ('drawing-images' stencil:at:color:) ('drawing-ovals' fillOval:color:borderWidth:borderColor:) ('drawing-polygons' drawPolygon:color:borderWidth:borderColor:) ('drawing-rectangles' fillRectangle:color: fillRectangle:fillStyle: frameAndFillRectangle:fillColor:borderWidth:borderColor: frameAndFillRectangle:fillColor:borderWidth:topLeftColor:bottomRightColor: frameRectangle:width:color:) ('drawing-support' clipBy:during: preserveStateDuring: transformBy:clippingTo:during:smoothing: translateBy:during:) ('drawing-text' drawString:from:to:in:font:color: drawString:from:to:in:font:color:background:) ('initialization' reset) ('other' translateBy:clippingTo:during:) ('testing' canBlendAlpha doesRoundedCorners isPostscriptCanvas) ('private' bounds: clip closepath comment: comment:with: defaultFont defineFont: drawGradient: drawPage: drawPages: drawPostscriptContext: endGStateForMorph: fill: fill:andStroke: image:at:sourceRect:rule: lineto: moveto: outlinePolygon: outlineQuadraticBezierShape: oval: paint:operation: postscriptFontNameForFont: printContentsOn: psSize rect: resetContentRotated: setColor: setFont: setLinewidth: setupGStateForMorph: stroke: strokepath text:at:font:color:justified:parwidth: text:at:font:color:spacePad: textStyled:at:font:color:justified:parwidth: topLevelMorph topLevelMorph: translate: writeGlobalSetup: writeHeaderRotated: writePSIdentifierRotated: writePageSetupFor: writeProcset) ('morph drawing' writeTrailer:) !