!*** polygone v4.1 source code *** !Scans a postscript file for groups of polygons, and merges those that !share a common edge and are shaded using the same colour. Produces a new !postscript file, which is often significantly smaller than the original. !(c) Ian Thompson, !School of Mathematics, !University of Liverpool !June 2014 !See for details of use. !Please report bugs to !You may do whatever you want with this code, except ! - incorporate any part of it in a commercial package, ! - claim that any part of it was written by anyone other than Ian ! Thompson of the Department of Mathematical Sciences, University ! of Liverpool (formerly of Loughborough University). !Standard-compliant Fortran 2003. !Tested under x86-64 linux with NAG Fortran compiler version 5.3.2(947) ! Windows 7 with NAG Fortran compiler version 5.3.1(924) !Doesn't compile with gfortran 4.9. This may be due to a limitation in !support for variable length strings, or a compiler bug. Check wepage !for updates: !Compiles with pgfortran 14.3, but causes a compiler bug causes a segmentation fault: ! !Compiles with up to date versions of the Intel Fortran compiler. !***** module param implicit none !----- !Change to .false. if there is a problem with the display. logical , parameter :: ansi_terminal = .true. integer , parameter :: dp = selected_real_kind( 15 ) !Floating precision. integer , parameter :: li = selected_int_kind ( 18 ) !Large integer kind. integer , parameter :: coord_length = 10 !Length of string used to represent a coordinate. integer , parameter :: decimal_places = 3 !Maximum number of decimal places used in a coordinate. real (dp) , parameter :: scale_factor = 10.0_dp**decimal_places !Better to use new_line, but ifort doesn't support that yet character , parameter :: NL = char( 10 ) character , parameter :: CR = char( 13 ) !Should polygone ignore spaces preceding CR/LF characters? logical , parameter :: strip_trailing_spaces = .true. !Set from file upon tokenization character (:) , allocatable :: line_feed !Ansi terminal control sequence - moves cursor up one line. character (4) , parameter :: ansi_up_1 = char( 27 ) // "[1A" !----- end module !***** module string_utils implicit none !----- private public :: string_is_num !----- contains !----- logical function string_is_num( string ) character (*) , intent (in) :: string !----- integer , parameter :: ic0 = ichar( '0' ) integer , parameter :: ic9 = ichar( '9' ) integer , parameter :: icd = ichar( '.' ) logical :: dec integer :: j , j_min integer :: icj , ls !----- ls = len( string ) if ( ls == 0 ) then !Watch out for empty string string_is_num = .false. return end if !----- !A number that starts with a minus sign !requires at least two characters. if ( string(1:1) == "-" ) then if ( ls == 1 ) then string_is_num = .false. return end if j_min = 2 else j_min = 1 end if !----- dec = .false. string_is_num = .true. do j = j_min , ls icj = ichar( string(j:j) ) if ( icj > ic9 .or. icj < ic0 ) then if ( icj == icd ) then if ( dec ) then !Only one decimal point is allowed string_is_num = .false. return else dec = .true. end if else string_is_num = .false. return end if end if end do !----- if ( dec ) then !Check length to ensure at least one digit is present. if ( ls - j_min < 1 ) string_is_num = .false. end if !----- end function !----- end module !***** module tokens implicit none !----- private public :: spc_cat , num_cat , str_cat public :: token public :: purge , destroy public :: purge_comments_v2 public :: tokenize_file_v4 , tokenize_string public :: operator( == ) , operator( /= ) !----- integer , parameter :: spc_cat = 1 integer , parameter :: num_cat = 2 integer , parameter :: str_cat = 3 !----- type :: token integer :: leading_spaces = 0 !Tokens extracted from a file have a line number. !For other tokens we leave this alone. integer :: line_number = -1 !1 - special (CR, LF), 2 - number, 3 - string integer :: catcode character (:) , allocatable :: string character (:) , allocatable :: alternate type (token) , pointer :: next => null() contains procedure , pass :: display => display_token procedure , pass :: write => write_token end type !----- interface operator( == ) module procedure tok_eq_tok end interface interface operator( /= ) module procedure tok_neq_tok end interface !----- contains !----- subroutine display_token( tok , u ) use param , only : NL class (token) , intent (in) :: tok integer , intent (in) :: u !----- character (10) :: ls character (:) , allocatable :: tt !----- if ( tok % leading_spaces == 1 ) then write (u,fmt='( "1 leading space, followed by " )',advance='no') else if ( tok % leading_spaces > 1 ) then write (ls,fmt='( i10 )') tok % leading_spaces write (u,fmt='( a , " leading spaces, followed by " )',advance='no') trim( adjustl( ls ) ) end if !----- select case( tok % catcode ) case( spc_cat ) if ( tok % string == NL ) then allocate( tt , source = "" ) else allocate( tt , source = "" ) end if case( num_cat ) allocate( tt , source = "the number '" // tok % string // "'" ) case( str_cat ) allocate( tt , source = "the string '" // tok % string // "'" ) end select !----- if ( tok % line_number > 0 ) then write (u,fmt='( a , " [" , i1 , "] " , " from line " , i10 )') tt , tok % catcode , tok % line_number else write (u,fmt='( a , " [" , i1 , "] " )') tt , tok % catcode end if flush( u ) !----- end subroutine !----- subroutine write_token( tok , u ) use param , only : strip_trailing_spaces class (token) , intent (in) :: tok integer , intent (in) :: u !----- if ( tok % catcode == spc_cat .and. strip_trailing_spaces ) then write (u) tok % string else !Writing zero length strings to a file probably isn't a brilliant idea, !so we'll concatenate first, in case tok % leading_spaces = 0. write (u) repeat( " " , tok % leading_spaces ) // tok % string end if flush( u ) !----- end subroutine !----- logical function tok_eq_tok( t1 , t2 ) type (token) , intent (in) :: t1 , t2 !----- tok_eq_tok = .false. if ( t1 % catcode == t2 % catcode ) then if ( allocated( t1 % string ) ) then if ( allocated( t2 % string ) ) then if ( t1 % string == t2 % string ) tok_eq_tok = .true. end if else if ( .not. allocated( t2 % string ) ) tok_eq_tok = .true. end if end if !----- end function !----- logical function tok_neq_tok( t1 , t2 ) type (token) , intent (in) :: t1 , t2 !----- tok_neq_tok = .not. ( t1 == t2 ) !----- end function !----- subroutine purge( tok , u ) !Output tok and all subsequent tokens to unit u, destroy pointer chain. type (token) , intent (inout) , pointer :: tok integer , intent (in) :: u !----- type (token) , pointer :: p !----- do if ( .not. associated( tok ) ) exit call tok % write( u ) p => tok % next deallocate( tok ) tok => p end do !----- end subroutine !----- subroutine purge_comments_v2( tok , u , insert ) !Output tok and subsequent tokens to unit u, until a token that is not part !of a comment is encountered. Does nothing if tok does not start a comment. use param , only : NL type (token) , intent (inout) , pointer :: tok integer , intent (in) :: u type (token) , intent (in) :: insert !----- type (token) , pointer :: p !----- comment_toks : do if ( .not. associated( tok ) ) exit comment_toks if ( tok % string(1:1) == "%" ) then if ( tok % string == "%%EndComments" ) call insert % write( u ) !Write to line end this_line : do call tok % write( u ) if ( tok % string == NL ) then p => tok % next deallocate( tok ) tok => p exit this_line else p => tok % next deallocate( tok ) tok => p end if if ( .not. associated( tok ) ) exit comment_toks end do this_line else exit comment_toks end if end do comment_toks !----- end subroutine !----- subroutine destroy( tok ) !Destroy tok and all subsequent tokens. type (token) , intent (inout) , pointer :: tok !----- type (token) , pointer :: p !----- do if ( .not. associated( tok ) ) exit p => tok % next deallocate( tok ) tok => p end do !----- end subroutine !----- subroutine tokenize_file_v4( filename , tok ) !Convert the file connected to logical unit u into a queue of tokens, starting !at the current position. Assumes that u is connected for stream access. use , intrinsic :: iso_fortran_env , only : iostat_end , terminal => output_unit use param , only : li , NL , CR , line_feed use string_utils , only : string_is_num character (*) , intent (in) :: filename type (token) , intent (out) , pointer :: tok !----- integer , parameter :: iNL = ichar( NL ) integer , parameter :: iCR = ichar( CR ) integer , parameter :: ics = ichar( ' ' ) !----- !1 - space, 2 - line break, 3 - carriage return, 4 - eof integer :: sc_type integer :: u , ios integer :: lineno integer :: s integer :: ncr , nlf integer (li) :: ntoks character :: c character (:) , allocatable :: string type (token) , target :: sentinel type (token) , pointer :: this !----- u = 10 open( unit = u , file = filename , action = 'read' , form = 'unformatted' , access = 'stream' ) !----- write (terminal,fmt='( "Tokenizing postscript code ..." )',advance='no') flush( terminal ) this => sentinel s = 0 sc_type = 0 lineno = 1 ntoks = 0 ncr = 0 nlf = 0 allocate( string , source = "" ) chars : do read (u,iostat=ios) c select case( ios ) case( 0 ) select case( ichar( c ) ) case( ics ) sc_type = 1 case( iNL ) sc_type = 2 nlf = nlf + 1 case( iCR ) sc_type = 3 ncr = ncr + 1 case default string = string // c cycle chars end select case( iostat_end ) sc_type = 4 case default write (terminal,fmt='( "polygone: iostat error " , i4 , " has occurred." )') ios write (terminal,fmt='( "Current line number : " , i8 )') lineno stop end select !----- !If we get to here, a separator character must have occured. if ( len( string ) > 0 ) then !Create new token allocate( this % next ) this => this % next this % line_number = lineno allocate( this % string , source = string ) !Insert leading spaces if necessary this % leading_spaces = s if ( string_is_num( string ) ) then this % catcode = num_cat else this % catcode = str_cat end if ntoks = ntoks + 1 string = "" s = 0 end if !----- select case( sc_type ) case( 1 ) !Space s = s + 1 case( 2 ) !Line break !Create new token allocate( this % next ) this => this % next this % line_number = lineno allocate( this % string , source = c ) this % catcode = spc_cat this % leading_spaces = s ntoks = ntoks + 1 lineno = lineno + 1 s = 0 if ( mod( lineno , 200000 ) == 0 ) then write (terminal,fmt='( "." )',advance='no') flush( terminal ) end if case( 3 ) !Carriage return !Create new token allocate( this % next ) this => this % next this % line_number = lineno allocate( this % string , source = c ) this % catcode = spc_cat this % leading_spaces = s ntoks = ntoks + 1 s = 0 case( 4 ) !End of file exit chars end select sc_type = 0 end do chars !----- close( u ) write (terminal,*) " created " , ntoks , " tokens." if ( allocated( line_feed ) ) deallocate( line_feed ) if ( ncr == 0 ) then write (terminal,fmt='( a )') "Unix line feeds detected." allocate( line_feed , source = NL ) else if ( ncr == nlf ) then write (terminal,fmt='( a )') "Windows line feeds detected." allocate( line_feed , source = CR // NL ) else write (terminal,fmt='( a )') "Mixed line feeds detected; output routine set to unix mode." allocate( line_feed , source = NL ) end if tok => sentinel % next !----- end subroutine !----- subroutine tokenize_string( string , tok ) !Converts string into a queue of tokens. Trailing spaces are discarded. use string_utils , only : string_is_num character (*) , intent (in) :: string type (token) , intent (out) , pointer :: tok !------ logical :: new_token integer :: j integer :: s type (token) , target :: sentinel type (token) , pointer :: this !----- this => sentinel new_token = .true. s = 0 !Saves a conditional inside the loop allocate( this % string , source = "" ) do j = 1 , len( string ) select case( string(j:j) ) case( " " ) s = s + 1 new_token = .true. case default if ( new_token ) then !Create new token allocate( this % next ) this => this % next !Insert leading spaces if necessary this % leading_spaces = this % leading_spaces + s s = 0 allocate( this % string , source = string(j:j) ) new_token = .false. else this % string = this % string // string(j:j) end if end select end do !----- !Add catcodes this => sentinel % next do if ( .not. associated( this ) ) exit if ( string_is_num( this % string ) ) then this % catcode = num_cat else this % catcode = str_cat end if this => this % next end do !----- tok => sentinel % next !----- end subroutine !----- end module !***** module setup use param , only : li use tokens , only : token implicit none save !----- private public :: drawing_token_scan_v3 public :: pgf_setup !----- type :: drawing_token_set integer :: sep_toks = 0 integer (li) :: associated_polygons = 0 !1 - moveto, 2 - lineto, 3 (actually a token queue) - closepath, fill, etc. type (token) , dimension (3) :: dts type (drawing_token_set) , pointer :: next => null() end type !----- type (drawing_token_set) , target :: dts_count_sentinel !----- contains !----- subroutine display_dts( d , compact ) use , intrinsic :: iso_fortran_env , only : terminal => output_unit use param , only : NL !----- type (drawing_token_set) , intent (in) , target :: d logical , intent (in) :: compact !----- character :: nlp character (10) :: c character (85) :: fmc type (token) , pointer :: p !----- if ( compact ) then fmc = '( " " , 5( a ) )' nlp = " " else fmc = '( " moveto : " , a , a , " lineto : " , a , a , " end polygon : " )' nlp = NL end if write (terminal,fmt=fmc,advance='no') d % dts(1) % string , nlp , d % dts(2) % string , nlp p => d % dts(3) do if ( .not. associated( p ) ) exit write (terminal,fmt='( a , " " )',advance='no') p % string if ( allocated( p % alternate ) ) write (terminal,fmt='( " (" , a , ") ")',advance='no') p % alternate p => p % next end do write (c,fmt='( i10 )') d % associated_polygons write (terminal,fmt='( " (" , a , " polygons)" , a )') trim( adjustl( c ) ) !----- end subroutine !----- subroutine pgf_setup( first_tok , pgf_macro , native_pgf_start , verbose ) use , intrinsic :: iso_fortran_env , only : terminal => output_unit use tokens , only : tokenize_string , operator( == ) , operator( /= ) !----- type (token) , intent (in) , pointer :: first_tok type (token) , intent (out) , pointer :: pgf_macro type (token) , intent (out) , optional , pointer :: native_pgf_start logical , intent (in) , optional :: verbose !----- integer , parameter :: max_attempts = 100 character , parameter :: pgfx = "x" character (4) , parameter :: pgf_init = "/pgf" !N.B. 0 setlinewidth is needed in case a larger setting is in !force when the polygons are drawn. That could lead to trouble if !said setting is needed again later, but restoring it wouldn't be !easy. Maybe something like /temp_lw linewidth bind def before the !first polygon and then use temp_lw setlinewidth to put it back at !the end of the group. Not worth implementing this without a !postscript file for which it is a problem. character (63) , parameter :: pgf_def = " {closepath gsave 0 setlinewidth stroke grestore fill} bind def" !----- logical :: verbose_local logical :: native_pgf_present integer :: j type (token) , pointer :: pgf_toks , this_pgf_tok type (token) , pointer :: this_tok !----- if ( present( verbose ) ) then verbose_local = verbose else verbose_local = .false. end if if ( present( native_pgf_start ) ) nullify( native_pgf_start ) !----- write (terminal,*) write (terminal,fmt='( "Attempting to set stroke/fill macro ..." )' ) allocate( pgf_macro ) pgf_macro % catcode = 3 allocate( pgf_macro % string , source = pgf_init ) call tokenize_string( pgf_def , pgf_toks ) !----- attempts : do j = 1 , max_attempts native_pgf_present = .false. this_tok => first_tok toks : do if ( this_tok == pgf_macro ) then !We want to remember the location of the first native pgf macro if ( present( native_pgf_start ) ) then if ( .not. associated( native_pgf_start ) ) native_pgf_start => this_tok end if if ( verbose_local ) then write (terminal,fmt='( "pgf macro " , a , " detected ..." )',advance='no') pgf_macro % string end if !Macro is already in use; did we put it here? this_pgf_tok => pgf_toks test : do !At this point, we have at least one test to perform, so... if ( .not. associated( this_tok % next ) ) then if ( verbose_local ) write (terminal,*) "foreign" if ( present( native_pgf_start ) ) nullify( native_pgf_start ) pgf_macro % string = pgf_macro % string // pgfx cycle attempts end if this_tok => this_tok % next if ( this_tok /= this_pgf_tok ) then if ( verbose_local ) write (terminal,*) "foreign" if ( present( native_pgf_start ) ) nullify( native_pgf_start ) pgf_macro % string = pgf_macro % string // pgfx cycle attempts end if if ( .not. associated( this_pgf_tok % next ) ) exit test this_pgf_tok => this_pgf_tok % next end do test !If we get to here, then we have discovered a native pgf command. !However, this could be redefined later, so we must continue the search. native_pgf_present = .true. if ( verbose_local ) write (terminal,*) "native" end if !----- !If this happens, then we have found a native pgf command, and we !are at the end of the file, so it cannot be redefined later. if ( .not. associated( this_tok % next ) ) exit attempts this_tok => this_tok % next !----- end do toks !----- end do attempts !----- if ( j > max_attempts ) then write (terminal,fmt='( "polgone: fatal error --- unable to determine a safe pgf command." )') write (terminal,fmt='( "Last attempt was : " , a )') pgf_macro % string stop else pgf_macro % next => pgf_toks write (terminal,fmt='( "Safe pgf macro is " , a )',advance='no') pgf_macro % string if ( native_pgf_present ) then write (terminal,*) "(already defined in file)" else write (terminal,*) end if end if !----- end subroutine !----- subroutine drawing_token_scan_v3( first_tok , d_toks , min_sep_tokens , verbose ) !Scans the queue of tokens that starts with first_tok and uses a pattern !matching mechanism to determine the tokens that represent moveto, lineto !closepath, fill and newpath within polygon groups. use , intrinsic :: iso_fortran_env , only : terminal => output_unit use param , only : NL use tokens , only : str_cat , num_cat , spc_cat , destroy , operator( == ) , operator( /= ) !----- type (token) , intent (in) , target :: first_tok type (token) , intent (out) , dimension (3) :: d_toks integer , intent (in) :: min_sep_tokens logical , intent (in) , optional :: verbose !----- !A set of separator tokens will be assumed to end when two consecutive !numbers are encountered. We'll set a reasonable limit, just in case. integer , parameter :: max_sep_tokens = 100 !----- logical :: verbose_local logical :: exit_polygon integer :: scan_mode integer :: sep_tokens , consecutive_numbers type (token) , pointer :: this_tok , continue_from type (token) , pointer :: p1_tok , p2_tok , a_tok , o_tok type (token) , dimension (3) , target :: dts type (drawing_token_set) , pointer :: s1 , s2 !----- write (terminal,fmt='( "Looking for polygon drawing operators..." )') if ( present( verbose ) ) then verbose_local = verbose else verbose_local = .false. end if !----- scan_mode = 0 sep_tokens = 0 continue_from => first_tok this_tok => first_tok toks : do !Make sure continue_from points to a number. Note that this !can cause continue_from to run ahead of this_tok, but there !is not need to add extra code to prevent this, because when !it happens the scan mode will stay at zero until this_tok !catches up. do if ( .not. associated( continue_from ) ) exit toks if ( continue_from % catcode == num_cat ) then exit else if ( continue_from % catcode == str_cat ) then !Ignore tokens to line end if ( continue_from % string(1:1) == "%" ) then do if ( .not. associated( continue_from % next ) ) exit toks continue_from => continue_from % next if ( continue_from % string == NL ) cycle toks end do end if end if continue_from => continue_from % next end do if ( .not. associated( this_tok ) ) exit toks select case( this_tok % catcode ) case( spc_cat ) !Ignore line feeds and carriage returns this_tok => this_tok % next cycle toks case( str_cat ) if ( this_tok % string(1:1) == "%" ) then do !Ignore tokens up to line end this_tok => this_tok % next if ( .not. associated( this_tok ) ) exit toks if ( this_tok % string == NL ) cycle toks end do end if end select !----- exit_polygon = .false. select case( scan_mode ) case( 2 ) !moveto if ( this_tok % catcode == str_cat ) then dts(1) = this_tok scan_mode = 3 !If it turns out that we don't have a polygon here, then !no polygon can possibly start before the next token, so... continue_from => this_tok else exit_polygon = .true. end if case( 5 ) !lineto !Note the assumption here: a polygon must have at least two(!) points. !Mathematica sometimes inserts 'shapes' that consist of a single point, !or two. All of these are deleted when the token queue is converted to !a postscript path queue. For the purposes of detecting drawing tokens, !we treat a shape with two points as normal, but we don't allow shapes !with only one point, because that would weaken the pattern matching !algorithm to a dangerous extent. This means the tokens that make up !single point shapes will not be counted, which seems the lesser of two !evils. Hopefully there will only ever be a small number of these, but !everything should still work even if there are many, because there will !probably be a very large number of other small shapes in this case. if ( this_tok % catcode == str_cat ) then if ( this_tok % string == dts(1) % string ) then exit_polygon = .true. else dts(2) = this_tok scan_mode = 6 end if else exit_polygon = .true. end if case( 6 ) !Could be a number or a closepath if ( this_tok % catcode == num_cat ) then scan_mode = 4 !Wait for another number else dts(3) = this_tok p1_tok => dts(3) consecutive_numbers = 0 continue_from => this_tok scan_mode = 7 end if case( 7 ) !Gather tokens until we encounter two consecutive numbers if ( this_tok % catcode == num_cat ) then consecutive_numbers = consecutive_numbers + 1 if ( consecutive_numbers > 1 .or. sep_tokens > max_sep_tokens ) then nullify( p1_tok % next ) exit_polygon = .true. else allocate( p1_tok % next ) p1_tok % next = this_tok p1_tok => p1_tok % next sep_tokens = sep_tokens + 1 end if else consecutive_numbers = 0 continue_from => this_tok allocate( p1_tok % next ) p1_tok % next = this_tok p1_tok => p1_tok % next sep_tokens = sep_tokens + 1 end if case default !Used when numbers are expected if ( this_tok % catcode == num_cat ) then scan_mode = scan_mode + 1 else exit_polygon = .true. end if end select !----- if ( exit_polygon ) then if ( sep_tokens >= min_sep_tokens .and. sep_tokens <= max_sep_tokens ) then call clip( dts(3) ) call add_to_count( dts ) end if scan_mode = 0 sep_tokens = 0 this_tok => continue_from continue_from => continue_from % next else this_tok => this_tok % next end if !----- end do toks !----- if ( .not. associated( dts_count_sentinel % next ) ) stop "No drawing tokens detected." call sort_sets() if ( dts_count_sentinel % next % associated_polygons < 2 ) stop "No polygon groups detected." if ( verbose_local ) then write (terminal,*) write (terminal,fmt='( "Possible drawing token sets:" )') call display_sets( 2 ) write (terminal,*) end if !----- !Check for alternate token if ( associated( dts_count_sentinel % next % next ) ) then s1 => dts_count_sentinel % next s2 => dts_count_sentinel % next % next if ( s1 % dts(1) == s2 % dts(1) .and. s1 % dts(2) == s2 % dts(2) ) then nullify( a_tok ) p1_tok => s1 % dts(3) p2_tok => s2 % dts(3) find_alt : do if ( p1_tok /= p2_tok ) then !Nothing in this game for two in a bed if ( associated( a_tok ) ) then nullify( a_tok ) exit find_alt else o_tok => p1_tok !Original a_tok => p2_tok !Alternate end if end if if ( .not. associated( p1_tok % next ) ) then if ( associated( p2_tok % next ) ) nullify( a_tok ) exit find_alt end if !If we get to here then p1_tok % next is associated if ( .not. associated( p2_tok % next ) ) then nullify( a_tok ) exit find_alt end if p1_tok => p1_tok % next p2_tok => p2_tok % next end do find_alt !----- if ( associated( a_tok ) ) allocate( o_tok % alternate , source = a_tok % string ) !----- end if end if !----- write (terminal,fmt='( "Polygon drawing tokens:" )') if ( verbose_local ) then call display_dts( dts_count_sentinel % next , .false. ) else call display_dts( dts_count_sentinel % next , .true. ) end if d_toks = dts_count_sentinel % next % dts !Watch that d_toks(3) % next etc. are not destroyed nullify( dts_count_sentinel % next % dts(3) % next ) !----- !Clean house do if ( .not. associated( dts_count_sentinel % next ) ) exit s1 => dts_count_sentinel % next % next call destroy( dts_count_sentinel % dts(3) % next ) deallocate( dts_count_sentinel % next ) dts_count_sentinel % next => s1 end do !----- end subroutine !----- subroutine clip( t ) !Remove any trailing numbers at the end of the queue following t use tokens , only : num_cat !----- type (token) , intent (inout) , target :: t !----- type (token) , pointer :: last_string , this !----- last_string => t this => t do if ( .not. associated( this % next ) ) exit this => this % next if ( this % catcode /= num_cat ) last_string => this end do do if ( .not. associated( last_string % next ) ) exit this => last_string % next last_string % next => last_string % next % next deallocate( this ) end do !----- end subroutine !----- subroutine add_to_count( dts ) use tokens , only : operator ( == ) , operator ( /= ) !----- type (token) , intent (inout) , dimension (3) , target :: dts !----- logical :: new_set type (token) , pointer :: p1 , p2 type (drawing_token_set) , pointer :: this_set !----- !Check if dts has been encountered before. We require a complete !match, which means the final polygon in a group will be omitted !if redundant newpath operators are in use. Otherwise, we could !get into trouble with files that draw filled polygons followed by !their outlines, so that the only difference is that fill is !replaced by stroke. new_set = .false. this_set => dts_count_sentinel known_sets : do if ( associated( this_set % next ) ) then this_set => this_set % next else new_set = .true. exit known_sets end if if ( dts(1) /= this_set % dts(1) .or. dts(2) /= this_set % dts(2) .or. & dts(3) /= this_set % dts(3) ) cycle known_sets p1 => this_set % dts(3) p2 => dts(3) dts3_chain : do if ( associated( p1 % next ) ) then if ( associated( p2 % next ) ) then if ( p1 % next == p2 % next ) then p1 => p1 % next p2 => p2 % next cycle dts3_chain else cycle known_sets end if else cycle known_sets end if else if ( associated( p2 % next ) ) then cycle known_sets else exit known_sets !Match end if end if end do dts3_chain end do known_sets !----- if ( new_set ) then allocate( this_set % next ) this_set % next % dts(1:3) = dts(1:3) this_set % next % associated_polygons = 1 nullify( dts(3) % next ) else this_set % associated_polygons = this_set % associated_polygons + 1 end if !----- end subroutine !----- subroutine sort_sets() integer :: max_n_polygons type (drawing_token_set) , pointer :: m , s , t !----- !Aim s one entry early to enable pointer changes. s => dts_count_sentinel do if ( .not. associated( s % next ) ) exit !No point correcting the last entry; it will always be !correct if all the preceding entries are correct. if ( .not. associated( s % next % next ) ) exit max_n_polygons = s % next % associated_polygons m => s t => s % next do if ( .not. associated( t % next ) ) exit if ( t % next % associated_polygons > max_n_polygons ) then m => t max_n_polygons = t % next % associated_polygons end if t => t % next end do if ( .not. associated( m , s ) ) then !Swap m % next with s % next t => s % next s % next => m % next m % next => t !Note: m % next and s % next are always associated at !this point, so s % next % next and m % next % next do !at least exist, even if they are hanging. t => s % next % next s % next % next => m % next % next m % next % next => t end if s => s % next end do !----- end subroutine !----- subroutine display_sets( min_p ) integer , intent (in) :: min_p !----- type (drawing_token_set) , pointer :: p !----- p => dts_count_sentinel do if ( .not. associated( p % next ) ) exit p => p % next if ( p % associated_polygons >= min_p ) call display_dts( p , .false. ) end do !----- end subroutine !----- end module !***** module alternate implicit none !----- private public :: trash_alternate_polygons !----- contains !----- subroutine trash_alternate_polygons( dts , first_tok , trashed_polygons ) use tokens , only : str_cat , token , operator( == ) !----- type (token) , intent (in) , dimension (3) , target :: dts type (token) , intent (inout) , pointer :: first_tok integer , intent (out) :: trashed_polygons !----- type (token) , target :: sentinel type (token) , pointer :: oa_tok type (token) , pointer :: p , k type (token) , pointer :: left_hold , right_hold !----- trashed_polygons = 0 !Locate the token that has an alternate string oa_tok => dts(3) do if ( allocated( oa_tok % alternate ) ) exit !No alternate token exists in this case if ( .not. associated( oa_tok % next ) ) return oa_tok => oa_tok % next end do !----- sentinel % next => first_tok left_hold => sentinel p => sentinel toks : do if ( .not. associated( p % next ) ) exit toks if ( p % next % catcode == str_cat ) then if ( p % next % string == oa_tok % string ) then left_hold => p % next else if ( p % next % string == oa_tok % alternate ) then !Tokens from left_hold % next up to and including p % next will be deleted right_hold => p % next % next nullify( k ) do !Watch out for the case where an alternate fill ends a group, so that right_hold is null if ( .not. associated( left_hold % next ) ) exit toks if ( associated( left_hold % next , right_hold ) ) exit k => left_hold % next left_hold % next => k % next deallocate( k ) end do p => left_hold trashed_polygons = trashed_polygons + 1 end if end if p => p % next end do toks !----- end subroutine !----- end module !***** module postscript_path use param , only : dp , li , coord_length implicit none !----- private public :: ps_path public :: compare_postscript_paths public :: merge_postscript_paths public :: tokens_to_ps_path !----- type :: ps_point integer (li) , dimension (2) :: coords_i_rep character (coord_length) , dimension (2) :: coords_c_rep type (ps_point) , pointer :: next_pt => null() type (ps_point) , pointer , private :: prev_pt => null() end type !----- type :: ps_path integer :: npts = 0 integer (li) :: x0 , x1 , y0 , y1 !Only used when building a path(?), and rather confusing. !Maybe we should get rid of this. type (ps_point) , pointer , private :: first_pt => null() type (ps_point) , pointer :: this_pt => null() type (ps_path) , pointer :: next_path => null() contains procedure , pass :: step_back procedure , pass :: reverse procedure , pass :: output procedure , pass :: destroy => destroy_pp !Rename works around a bug in pgfortran procedure , pass :: remove_superfluous_points_v2 end type !----- contains !----- subroutine step_back( pp ) class (ps_path) , intent (inout) :: pp !----- pp % this_pt => pp % this_pt % prev_pt !----- end subroutine !----- subroutine reverse( pp ) !Reverses the ordering of the points in the ps path pp. !The target of pp % this_pt is unchanged on exit. class (ps_path) , intent (inout) :: pp !----- integer :: j type (ps_point) , pointer :: t !----- do j = 1 , pp % npts !Hold previous point t => pp % this_pt % prev_pt !Aim prev pointer at next point pp % this_pt % prev_pt => pp % this_pt % next_pt !Aim next pointer at previous point pp % this_pt % next_pt => t !Move to (old) previous point pp % this_pt => t end do !----- end subroutine !----- subroutine output( pp , drawing_toks , u , points_per_line ) !Output the ps path pp in the appropriate format. use param , only : line_feed use tokens , only : token !----- class (ps_path) , intent (inout) :: pp type (token) , intent (in) , dimension (:) , target :: drawing_toks integer , intent (in) :: u integer , intent (in) , optional :: points_per_line !----- integer :: j integer :: ppl type (token) , pointer :: p !----- if ( present( points_per_line ) ) then ppl = points_per_line else ppl = 5 end if !----- ! moveto write (u) trim( pp % this_pt % coords_c_rep(1) ) , " " , trim( pp % this_pt % coords_c_rep(2) ) , & & " " , drawing_toks(1) % string , line_feed pts : do j = 1 , pp % npts - 1 pp % this_pt => pp % this_pt % next_pt ! lineto write (u) trim( pp % this_pt % coords_c_rep(1) ) , " " , trim( pp % this_pt % coords_c_rep(2) ) , & & " " , drawing_toks(2) % string !Insert linebreaks where necessary if ( mod( j , ppl ) == 0 ) then write (u) line_feed else write (u) " " end if end do pts if ( mod( j , ppl ) /= 1 ) write (u) line_feed !closepath fill etc. p => drawing_toks(3) do write (u) p % string if ( associated( p % next ) ) then write (u) " " p => p % next else write (u) line_feed exit end if end do !----- end subroutine !----- subroutine destroy_pp( pp ) !Destroy all data held in the ps path pp class (ps_path) , intent (inout) :: pp !----- type (ps_point) , pointer :: t !----- !Break cycle nullify( pp % this_pt % prev_pt % next_pt ) do !Hold next point t => pp % this_pt % next_pt !Destroy current point deallocate( pp % this_pt ) pp % npts = pp % npts - 1 if ( .not. associated( t ) ) exit pp % this_pt => t end do !----- end subroutine !----- subroutine compare_postscript_paths( pp1 , pp2 , match , reverse ) !Looks for a common edge in the paths pp1 and pp2. !If a match is found, and reverse = .false. on exit, then ! ! pp1 % this_pt == pp2 % this_pt ! pp1 % this_pt % next_pt == pp2 % this_pt % next_pt ! !(forward match), whereas if reverse = .true. then (reverse match) ! ! pp1 % this_pt == pp2 % this_pt % next_pt ! pp1 % this_pt % next_pt == pp2 % this_pt class (ps_path) , intent (inout) :: pp1 , pp2 logical , intent (out) :: match , reverse !----- integer :: j , p integer (li) , dimension (2) :: ct1 , ct2 , cn1 , cn2 !Overlap region integer (li) :: x0 , x1 , y0 , y1 !----- match = .false. reverse = .false. !----- !Overlap region x0 = max( pp1 % x0 , pp2 % x0 ) x1 = min( pp1 % x1 , pp2 % x1 ) y0 = max( pp1 % y0 , pp2 % y0 ) y1 = min( pp1 % y1 , pp2 % y1 ) if ( x0 > x1 .or. y0 > y1 ) return !----- do j = 1 , pp1 % npts do p = 1 , pp2 % npts ct1 = pp1 % this_pt % coords_i_rep ct2 = pp2 % this_pt % coords_i_rep cn1 = pp1 % this_pt % next_pt % coords_i_rep cn2 = pp2 % this_pt % next_pt % coords_i_rep if ( sum( ( ct1 - ct2 )**2 + ( cn1 - cn2 )**2 ) == 0 ) then match = .true. return end if if ( sum( ( ct1 - cn2 )**2 + ( cn1 - ct2 )**2 ) == 0 ) then match = .true. reverse = .true. return end if pp2 % this_pt => pp2 % this_pt % next_pt end do pp1 % this_pt => pp1 % this_pt % next_pt end do !----- end subroutine !----- subroutine merge_postscript_paths( pp1 , pp2 ) !Merge the postscript paths pp1 and pp2. Assumes that ! ! pp1 % this_pt == pp2 % this_pt % next_pt ! pp1 % this_pt % next_pt == pp2 % this_pt ! !(i.e. a reverse match). !On exit, pp1 contains the merged path; pp2 is destroyed type (ps_path) , intent (inout) , pointer :: pp1 , pp2 !----- type (ps_point) , pointer :: pp1_start , pp1_end type (ps_point) , pointer :: pp2_start , pp2_end !----- !pp1 % this and pp2 % this are two distinct common points. pp1_start => pp1 % this_pt % next_pt pp1_end => pp1 % this_pt % prev_pt pp2_start => pp2 % this_pt % next_pt pp2_end => pp2 % this_pt % prev_pt !One copy of each common point can now be safely destroyed. deallocate( pp1 % this_pt ) deallocate( pp2 % this_pt ) !What's left of pp2 is an alternative route from pp1_end to ! pp1_start. pp1_end % next_pt => pp2_start pp2_start % prev_pt => pp1_end pp2_end % next_pt => pp1_start pp1_start % prev_pt => pp2_end !One point has been removed from each path pp1 % npts = pp1 % npts - 1 pp2 % npts = pp2 % npts - 1 pp1 % this_pt => pp1_start pp1 % npts = pp1 % npts + pp2 % npts !Update bounds for pp1 pp1 % x0 = min( pp1 % x0 , pp2 % x0 ) pp1 % x1 = max( pp1 % x1 , pp2 % x1 ) pp1 % y0 = min( pp1 % y0 , pp2 % y0 ) pp1 % y1 = max( pp1 % y1 , pp2 % y1 ) !----- !Data has been removed from pp2 deallocate( pp2 ) !----- end subroutine !----- subroutine tokens_to_ps_path( first_tok , last_tok , pp ) use param , only : scale_factor use tokens , only : token , num_cat !----- type (token) , intent (in) , pointer :: first_tok , last_tok type (ps_path) , intent (out) :: pp !----- real (dp) , dimension (2) :: t type (ps_point) , target :: sentinel_pt type (token) , pointer :: this_tok !----- !First we must extract the data from the tokens pp % this_pt => sentinel_pt this_tok => first_tok do !Note: this condition can't be satisfied if !last_tok is the second of a pair of numbers. if ( associated( this_tok , last_tok ) ) exit !Everything except consecutive pairs of numbers can be ignored. if ( this_tok % catcode == num_cat ) then if ( this_tok % next % catcode == num_cat ) then !Create new point allocate( pp % this_pt % next_pt ) pp % this_pt % next_pt % prev_pt => pp % this_pt pp % this_pt => pp % this_pt % next_pt !Obtain data for new point pp % this_pt % coords_c_rep(1) = this_tok % string this_tok => this_tok % next pp % this_pt % coords_c_rep(2) = this_tok % string !Convert data to integer form read (pp % this_pt % coords_c_rep(:),*) t t = scale_factor * t pp % this_pt % coords_i_rep = nint( t ) pp % npts = pp % npts + 1 end if end if this_tok => this_tok % next end do !----- !Now we need to locate the leftmost and !rightmost points, etc. pp % this_pt => sentinel_pt % next_pt pp % x0 = pp % this_pt % coords_i_rep(1) pp % x1 = pp % x0 pp % y0 = pp % this_pt % coords_i_rep(2) pp % y1 = pp % y0 do !Mathematica sometimes creates paths with only one !point(!); hence we check association status now. if ( .not. associated( pp % this_pt % next_pt ) ) exit pp % this_pt => pp % this_pt % next_pt if ( pp % this_pt % coords_i_rep(1) < pp % x0 ) then pp % x0 = pp % this_pt % coords_i_rep(1) else if ( pp % this_pt % coords_i_rep(1) > pp % x1 ) then pp % x1 = pp % this_pt % coords_i_rep(1) end if if ( pp % this_pt % coords_i_rep(2) < pp % y0 ) then pp % y0 = pp % this_pt % coords_i_rep(2) else if ( pp % this_pt % coords_i_rep(2) > pp % y1 ) then pp % y1 = pp % this_pt % coords_i_rep(2) end if end do !Close the path pp % this_pt % next_pt => sentinel_pt % next_pt pp % this_pt % next_pt % prev_pt => pp % this_pt !----- end subroutine !----- subroutine remove_superfluous_points_v2( pp ) !Does exactly what it says on the tin. class (ps_path) , intent (inout) :: pp !----- logical :: full_circle logical :: remove integer (li) :: d1 , d2 , d3 integer (li) , dimension (2) :: dxy0 , dxy1 type (ps_point) , pointer :: t , f !----- full_circle = .false. f => pp % this_pt % prev_pt !In the algorithm below, f and pp % this_pt can become associated in two ways. !1: If pp has only two points, then this_pt will be removed. After this, one ! more cycle will occur in which the remaining point will also be removed. !2: If we reach the last point that has not yet been checked. After this, we ! will exit when we find a point that is not superfluous. check_points : do !If any two of this_pt, next_pt and prev_pt are identical, then this_pt is redundant. d1 = sum( abs( pp % this_pt % prev_pt % coords_i_rep - pp % this_pt % next_pt % coords_i_rep ) ) d2 = sum( abs( pp % this_pt % coords_i_rep - pp % this_pt % next_pt % coords_i_rep ) ) d3 = sum( abs( pp % this_pt % prev_pt % coords_i_rep - pp % this_pt % coords_i_rep ) ) redundant : if ( d1 * d2 * d3 == 0 ) then remove = .true. else redundant !Check for colinearity dxy0 = pp % this_pt % coords_i_rep - pp % this_pt % prev_pt % coords_i_rep dxy1 = pp % this_pt % next_pt % coords_i_rep - pp % this_pt % coords_i_rep dx0 : if ( dxy0(1) == 0 ) then if ( dxy1(1) == 0 ) then remove = .true. else remove = .false. end if else dx0 remove = ( dxy0(2) * dxy1(1) == dxy1(2) * dxy0(1) ) end if dx0 end if redundant !----- if ( remove ) then !Hold current point t => pp % this_pt !Remove this_pt from pointer chain pp % this_pt % prev_pt % next_pt => pp % this_pt % next_pt pp % this_pt % next_pt % prev_pt => pp % this_pt % prev_pt !The previous point may have become superfluous pp % this_pt => t % prev_pt !Watch out for the annoying case where pp % this_pt has landed on f if ( associated( pp % this_pt , f ) ) f => f % prev_pt !Destroy superfluous point deallocate( t ) pp % npts = pp % npts - 1 !Watch out for collapsed paths if ( pp % npts == 0 ) exit check_points else if ( full_circle ) exit check_points pp % this_pt => pp % this_pt % next_pt end if if ( associated( pp % this_pt , f ) ) full_circle = .true. !----- end do check_points !----- end subroutine !----- end module !***** module postscript_path_queue use postscript_path , only : ps_path implicit none !----- private public :: ps_path_queue public :: tokens_to_ps_path_queue !----- type :: ps_path_queue integer :: npaths , npts !Note the distinction here: path_sentinel and last_path are !structural, whereas prev_path and this_path are used to move !along the queue. move_to_start should be called after !remove_head or remove_this_path. type (ps_path) , pointer , private :: path_sentinel => null() type (ps_path) , pointer , private :: last_path => null() type (ps_path) , pointer :: this_path => null() type (ps_path) , pointer , private :: prev_path => null() type (ps_path_queue) , pointer :: next_ps_path_queue => null() type (ps_path_queue) , pointer :: prev_ps_path_queue => null() contains procedure , pass :: init procedure , pass :: add_after_last procedure , pass :: move_to_start procedure , pass :: step_forward procedure , pass :: remove_head procedure , pass :: remove_this_path procedure , pass :: is_empty procedure , pass :: output procedure , pass :: destroy procedure , pass :: stratify procedure , pass :: gather end type !----- contains !----- subroutine init( ppq ) !----- class (ps_path_queue) , intent (inout) :: ppq !----- allocate( ppq % path_sentinel ) ppq % last_path => ppq % path_sentinel ppq % npaths = 0 ppq % npts = 0 !----- end subroutine !----- subroutine add_after_last( ppq , pp ) class (ps_path_queue) , intent (inout) :: ppq type (ps_path) , intent (inout) , pointer :: pp !----- !Add new path to queue end ppq % last_path % next_path => pp !Step last_path pointer forward to new queue end ppq % last_path => ppq % last_path % next_path ppq % npaths = ppq % npaths + 1 ppq % npts = ppq % npts + pp % npts !pp can only be accessed again from within the queue. nullify( pp ) !----- end subroutine !----- subroutine move_to_start( ppq ) class (ps_path_queue) , intent (inout) :: ppq !----- ppq % prev_path => ppq % path_sentinel ppq % this_path => ppq % path_sentinel % next_path !----- end subroutine !----- subroutine step_forward( ppq ) class (ps_path_queue) , intent (inout) :: ppq !----- ppq % prev_path => ppq % this_path ppq % this_path => ppq % this_path % next_path !----- end subroutine !----- subroutine remove_head( ppq , pp ) !Use with care! Using this can hang ppq % this_path or ppq % prev_path. !(The idea is to remove the head item and then move to the queue start so !as to begin searching for matches). class (ps_path_queue) , intent (inout) :: ppq type (ps_path) , intent (out) , pointer :: pp !----- !Return first path pp => ppq % path_sentinel % next_path !Watch out for the case where the queue is made empty if ( associated( pp , ppq % last_path ) ) ppq % last_path => ppq % path_sentinel ppq % npaths = ppq % npaths - 1 ppq % npts = ppq % npts - pp % npts !Reestablish pointer chain ppq % path_sentinel % next_path => pp % next_path !pp is no longer in the queue; next_path has no meaning nullify( pp % next_path ) !----- end subroutine !----- subroutine remove_this_path( ppq , pp ) !Does exactly what it says on the tin. !Then aims ppq % this_path at the (new) queue head ?!?! class (ps_path_queue) , intent (inout) :: ppq type (ps_path) , intent (out) , pointer :: pp !----- !Watch out for the case where the last path is removed if ( associated( ppq % this_path , ppq % last_path ) ) ppq % last_path => ppq % prev_path !Break queue connection to ppq % this_path ppq % prev_path % next_path => ppq % this_path % next_path !Return ppq % this_path pp => ppq % this_path ppq % npaths = ppq % npaths - 1 ppq % npts = ppq % npts - pp % npts !pp is no longer in the queue; next_path has no meaning nullify( pp % next_path ) nullify( ppq % this_path ) nullify( ppq % prev_path ) !----- end subroutine !----- logical function is_empty( ppq ) class (ps_path_queue) , intent (in) :: ppq !----- is_empty = .not. associated( ppq % path_sentinel % next_path ) !----- end function !----- subroutine output( ppq , drawing_toks , u ) use param , only : line_feed use tokens , only : token !----- class (ps_path_queue) , intent (inout) :: ppq type (token) , intent (in) , dimension (:) :: drawing_toks integer , intent (in) :: u !----- ppq % this_path => ppq % path_sentinel write (u) line_feed do if ( .not. associated( ppq % this_path % next_path ) ) exit ppq % this_path => ppq % this_path % next_path call ppq % this_path % output( drawing_toks , u ) end do !----- end subroutine !----- subroutine destroy( ppq ) class (ps_path_queue) , intent (inout) :: ppq !----- !Nullify unrequired pointers nullify( ppq % last_path ) nullify( ppq % prev_path ) !----- do !Exit if first path does not exist if ( .not. associated( ppq % path_sentinel % next_path ) ) exit !Hold first path ppq % this_path => ppq % path_sentinel % next_path !The new first path is the old second path ppq % path_sentinel % next_path => ppq % this_path % next_path !This will destroy point data call ppq % this_path % destroy() !Destroy redundant node deallocate( ppq % this_path ) end do !----- deallocate( ppq % path_sentinel ) ppq % npaths = 0 ppq % npts = 0 !----- end subroutine !----- subroutine stratify( ppq , verbose ) use , intrinsic :: iso_fortran_env , only : terminal => output_unit !----- class (ps_path_queue) , intent (inout) , target :: ppq logical , intent (in) , optional :: verbose !----- logical :: verbose_local integer :: j type (ps_path) , pointer :: pp => null() type (ps_path_queue) , pointer :: this_ps_path_queue => null() !----- if ( present( verbose ) ) then verbose_local = verbose else verbose_local = .false. end if if ( verbose_local ) then write (terminal,fmt='( " Stratifying ... ")',advance='no') flush ( terminal ) end if !----- call ppq % move_to_start() !----- !Note: each of the queues will be switched with the unmatched path !queue during processing. Therefore none should be statically !allocated; instead ppq becomes a sentinel node. do if ( ppq % is_empty() ) exit !Take current path out of the queue call ppq % remove_head( pp ) !Find the correct place for pp this_ps_path_queue => ppq do j = 3 , pp % npts !Create an additional queue if necessary. if ( .not. associated( this_ps_path_queue % next_ps_path_queue ) ) then allocate( this_ps_path_queue % next_ps_path_queue ) call this_ps_path_queue % next_ps_path_queue % init() this_ps_path_queue % next_ps_path_queue % prev_ps_path_queue => this_ps_path_queue end if !Now it's definitely ok to move to the next queue. this_ps_path_queue => this_ps_path_queue % next_ps_path_queue end do !Put pp in the appropriate queue. call this_ps_path_queue % add_after_last( pp ) end do !----- if ( verbose_local ) then write (terminal,fmt='( "[ " )',advance='no') this_ps_path_queue => ppq % next_ps_path_queue do write (terminal,fmt='( i8 )',advance='no') this_ps_path_queue % npaths if ( associated( this_ps_path_queue % next_ps_path_queue ) ) then write (terminal,fmt='( " , " )',advance='no') this_ps_path_queue => this_ps_path_queue % next_ps_path_queue else write (terminal,fmt='( " ]" )') exit end if end do end if !----- end subroutine !----- subroutine gather( ppq , verbose ) use , intrinsic :: iso_fortran_env , only : terminal => output_unit !----- class (ps_path_queue) , intent (inout) , target :: ppq logical , intent (in) , optional :: verbose !----- logical :: verbose_local type (ps_path_queue) , pointer :: this_ps_path_queue => null() !----- if ( present( verbose ) ) then verbose_local = verbose else verbose_local = .false. end if if ( verbose_local ) then write (terminal,fmt='( " Gathering ... ")',advance='no') flush ( terminal ) end if !----- !Find the first nonempty queue this_ps_path_queue => ppq % next_ps_path_queue do if ( .not. associated( this_ps_path_queue ) ) exit if ( this_ps_path_queue % is_empty() ) then this_ps_path_queue => this_ps_path_queue % next_ps_path_queue else ppq % path_sentinel => this_ps_path_queue % path_sentinel exit end if end do if ( .not. associated( ppq % path_sentinel ) ) stop "Error : nothing to gather!" !----- do !Hold next queue this_ps_path_queue => ppq % next_ps_path_queue if ( .not. associated( this_ps_path_queue ) ) exit ppq % next_ps_path_queue => this_ps_path_queue % next_ps_path_queue if ( .not. this_ps_path_queue % is_empty() ) then !Add paths from current queue to main queue ppq % last_path % next_path => this_ps_path_queue % path_sentinel % next_path ppq % last_path => this_ps_path_queue % last_path ppq % npaths = ppq % npaths + this_ps_path_queue % npaths ppq % npts = ppq % npts + this_ps_path_queue % npts end if !Destroy redundant queue deallocate( this_ps_path_queue ) end do nullify( ppq % next_ps_path_queue ) !----- if ( verbose_local ) then write (terminal,fmt='( i8 , " points in " , i8 , " paths." )') ppq % npts , ppq % npaths end if !----- end subroutine !----- subroutine tokens_to_ps_path_queue( tok , fill_tok , ppq , display ) use , intrinsic :: iso_fortran_env , only : terminal => output_unit use tokens , only : token , operator( == ) use postscript_path , only : ps_path , tokens_to_ps_path !----- type (token) , intent (in) , target :: tok type (token) , intent (in) :: fill_tok type (ps_path_queue) , intent (out) :: ppq logical , intent (in) , optional :: display !----- logical :: display_local integer :: npoints , npaths type (ps_path) , pointer :: pp type (token) , pointer :: path_start , this_token !----- if ( present( display ) ) then display_local = display else display_local = .false. end if !----- call ppq % init() this_token => tok npoints = 0 npaths = 0 !----- if ( display_local ) then write (terminal,fmt='( " lines " , i8 , " ... " )',advance='no') this_token % line_number end if !----- toks : do path_start => this_token path : do if ( .not. associated( this_token % next ) ) exit toks this_token => this_token % next if ( this_token == fill_tok ) exit path end do path allocate( pp ) call tokens_to_ps_path( path_start , this_token , pp ) npoints = npoints + pp % npts npaths = npaths + 1 !Remove points that are not actually necessary call pp % remove_superfluous_points_v2() if ( pp % npts > 2 ) then !Note that this will nullify pp call ppq % add_after_last( pp ) else !Discard (note that the number of points will always !be zero here, due to remove_superfluous_points). deallocate( pp ) end if end do toks !----- if ( display_local ) write (terminal,100) this_token % line_number , npoints , npaths 100 format( i8 , " ; ", i12 , " points in " , i7 , " paths." ) !----- end subroutine !----- end module !***** module v3_engine implicit none private public :: v3_process !----- contains !----- subroutine v3_process( ppq_sentinel , max_merge_points ) use , intrinsic :: iso_fortran_env , only : terminal => output_unit use param , only : ansi_terminal , ansi_up_1 use postscript_path , only : ps_path , merge_postscript_paths , compare_postscript_paths use postscript_path_queue , only : ps_path_queue !----- type (ps_path_queue) , intent (inout) , target :: ppq_sentinel integer , intent (in) :: max_merge_points !----- logical :: check_current , check_unmatched logical :: all_tried logical :: match , reverse integer :: j integer :: mergers , update_period integer :: current_path_npts character (len=7) :: nc type (ps_path) , pointer :: pp => null() type (ps_path) , pointer :: pp2 => null() type (ps_path_queue) , pointer :: current_path_queue => null() type (ps_path_queue) , pointer :: unmatched_path_queue => null() type (ps_path_queue) , pointer :: test_queue => null() type (ps_path_queue) , pointer :: tmp_path_queue => null() !----- if ( ansi_terminal ) then update_period = 100 write (terminal,fmt='( " Processing " )',advance='yes') else update_period = 1000 write (terminal,fmt='( " Processing " )',advance='no') flush( terminal ) end if !----- allocate( unmatched_path_queue ) call unmatched_path_queue % init() current_path_queue => ppq_sentinel % next_ps_path_queue current_path_npts = 3 mergers = 0 !----- all_paths : do !Shows some indication of progress (loops may be slow). There !is no way to determine a priori when processing will finish. if ( mod( mergers , update_period ) == 0 ) then if ( ansi_terminal ) then write (nc,fmt='( i7 )') mergers write (terminal,fmt='( 3( a ) )') ansi_up_1 , " Processing ... mergers :" , trim( nc ) else write (terminal,fmt='( "." )',advance='no') end if end if !Get a path from the current queue, if we don't already have one if ( .not. associated( pp ) ) then new_current_queue : do if ( .not. current_path_queue % is_empty() ) exit new_current_queue if ( .not. unmatched_path_queue % is_empty() ) then !Put unmatched path queue in place of current queue !Set links to and from unmatched path queue current_path_queue % prev_ps_path_queue % next_ps_path_queue => unmatched_path_queue unmatched_path_queue % prev_ps_path_queue => current_path_queue % prev_ps_path_queue if ( associated( current_path_queue % next_ps_path_queue ) ) then current_path_queue % next_ps_path_queue % prev_ps_path_queue => unmatched_path_queue unmatched_path_queue % next_ps_path_queue => current_path_queue % next_ps_path_queue end if !Hold current queue tmp_path_queue => current_path_queue current_path_queue => unmatched_path_queue !What was the current path queue can now be used as the unmatched !queue, provided we nullify its pointers to other queues. unmatched_path_queue => tmp_path_queue nullify( unmatched_path_queue % next_ps_path_queue ) nullify( unmatched_path_queue % prev_ps_path_queue ) end if !N.B. the unmatched queue is always empty at this point if ( associated( current_path_queue % next_ps_path_queue ) ) then !Move current path queue forward current_path_queue => current_path_queue % next_ps_path_queue current_path_npts = current_path_npts + 1 !Check whether we should process this queue if ( max_merge_points > 0 .and. current_path_npts > max_merge_points ) then call unmatched_path_queue % destroy() deallocate( unmatched_path_queue ) exit all_paths end if else !Processing finished call unmatched_path_queue % destroy() deallocate( unmatched_path_queue ) exit all_paths end if end do new_current_queue !----- !If we reach this point, we have a current queue !with at least one shape ... grab it. call current_path_queue % remove_head( pp ) check_current = .true. check_unmatched = .false. all_tried = .false. !----- end if !----- !Now we try to find a match for pp test_queue => ppq_sentinel % next_ps_path_queue test_queues : do call test_queue % move_to_start() this_test_queue : do if ( .not. associated( test_queue % this_path ) ) exit this_test_queue call compare_postscript_paths( pp , test_queue % this_path , match , reverse ) found_match : if ( match ) then !Extract current path call test_queue % remove_this_path( pp2 ) !We need a reverse match if ( .not. reverse ) then call pp2 % reverse() !prev and next are interchanged by this operation, so... call pp2 % step_back() end if !Merge paths (N.B. no data will be left in pp2) call merge_postscript_paths( pp , pp2 ) call pp % remove_superfluous_points_v2() if ( pp % npts <= 2 ) stop "polygone: fatal error --- collapsed path!" mergers = mergers + 1 !If this has more points than the shapes in the current !queue, then we'll drop it off for processing later. if ( pp % npts > current_path_npts ) then tmp_path_queue => current_path_queue do j = 1 , pp % npts - current_path_npts !Watch out ... the appropriate path queue may not exist if ( .not. associated( tmp_path_queue % next_ps_path_queue ) ) then allocate( tmp_path_queue % next_ps_path_queue ) call tmp_path_queue % next_ps_path_queue % init() tmp_path_queue % next_ps_path_queue % prev_ps_path_queue => tmp_path_queue end if !Now it's definitely ok to move to the next queue. tmp_path_queue => tmp_path_queue % next_ps_path_queue end do !Put pp in the appropriate queue. call tmp_path_queue % add_after_last( pp ) !nullifies pp else if ( pp % npts < current_path_npts ) then check_unmatched = .true. all_tried = .false. else check_current = .true. check_unmatched = .true. all_tried = .false. end if cycle all_paths end if found_match call test_queue % step_forward() end do this_test_queue !----- if ( associated( test_queue , current_path_queue % prev_ps_path_queue ) ) then if ( check_current ) then test_queue => test_queue % next_ps_path_queue else if ( check_unmatched ) then test_queue => unmatched_path_queue else all_tried = .true. end if else if ( associated( test_queue , current_path_queue ) ) then if ( check_unmatched ) then test_queue => unmatched_path_queue else all_tried = .true. end if else if ( associated( test_queue , unmatched_path_queue ) ) then all_tried = .true. else test_queue => test_queue % next_ps_path_queue end if if ( all_tried ) then !Note that this path cannot have more points than those in the current queue. if ( pp % npts == current_path_npts ) then call unmatched_path_queue % add_after_last( pp ) ! (nullifies pp) else tmp_path_queue => current_path_queue do j = 1 , current_path_npts - pp % npts tmp_path_queue => tmp_path_queue % prev_ps_path_queue end do call tmp_path_queue % add_after_last( pp ) ! (nullifies pp) end if exit test_queues end if !----- end do test_queues end do all_paths !----- if ( ansi_terminal ) then write (nc,fmt='( i7 )') mergers write (terminal,fmt='( 3( a ) )') ansi_up_1 , " Processing ... mergers :" , trim( nc ) else write (terminal,fmt='( "." )') end if !----- end subroutine !----- end module !***** program polygone use , intrinsic :: iso_fortran_env , only : terminal => output_unit , keyboard => input_unit use param , only : NL , line_feed use tokens , only : token , purge , destroy , purge_comments_v2 , operator( == ) , & & tokenize_file_v4 , spc_cat , num_cat use setup , only : pgf_setup , drawing_token_scan_v3 use alternate , only : trash_alternate_polygons use postscript_path_queue , only : ps_path_queue , tokens_to_ps_path_queue use v3_engine , only : v3_process implicit none !----- character (58) , parameter :: usage = "Usage : polygone4 myfile.eps [-mj] [-sp] [-aq] [-r] [-v]" character (63) , dimension (2) , parameter :: remarks = & & [ "polygone version 4.1 (July 2014) " , & & "Ian Thompson, School of Mathematics, University of Liverpool. " ] character (63) , parameter , dimension (7) :: helptext = [ & & "-mj: polygons with more then j points will be ineligible for " , & & "merger, unless j = 0(default), when all polygons are eligible. " , & & "-sp: a minimum of p postscript operators are required to " , & & "separate consecutive polygons (default 2). " , & & "-aq: alternate fill mode q. 0 disallow (default), 1 treat as " , & & "normal, 2 trash. See manual for details. " , & & "-r: remove mesh (default off). -v: verbose mode (default off). " ] !----- !Program options logical :: error = .false. logical :: remove_mesh = .false. logical :: verbose = .false. integer :: m = 0 integer :: min_sep_toks = 2 integer :: alternate_mode = 0 !----- logical :: exists logical :: pattern_mismatch logical :: atest integer :: ios integer :: j , l , n_args integer :: file_arg integer :: point_loc integer :: scan_mode integer :: group_number , polygons_this_group integer :: trashed_polygons integer :: cs , ce , cps integer :: out_unit integer :: if_size , of_size character (10) :: date_char , time_char character (:) , allocatable :: filename , repaired_filename character (:) , allocatable :: tmp type (token) , dimension (3) :: drawing_toks , od_toks type (token) , pointer :: p type (token) , pointer :: this , first type (token) , pointer :: last_fill type (token) , pointer :: pgf_macro , pgf_start_locator type (ps_path_queue) :: ppq !----- write (terminal,fmt='( 7( a ) )') NL , "*** " , trim( remarks(1) ) , " ***" , NL , NL , remarks(2:) write (terminal,fmt='( "Please report bugs to ." , a )') NL !----- error = .false. n_args = command_argument_count() !Get filename and parameters from terminal if no arguments are present if ( n_args == 0 ) then allocate( character(len=100) :: filename ) write (terminal,fmt='( "Enter name of eps file for repair : " )',advance='no') read (keyboard,*) filename filename = trim( filename ) write (terminal,fmt='( "Paths with m points or fewer will be considered eligible for merger." )') do write (terminal,fmt='( "Enter m (0 for no limit) : " )',advance='no') read (keyboard,*,iostat=ios) m if ( ios == 0 .and. m >= 0 ) exit end do write (terminal,fmt='( "A minimum of p postscript operators are required to separate consecutive polygons." )') do write (terminal,fmt='( "Enter p (2 is usually recommended) : " )',advance='no') read (keyboard,*,iostat=ios) min_sep_toks if ( ios == 0 .and. min_sep_toks > 0 ) exit end do do write (terminal,fmt='( "Remove mesh? 1: no, 2: yes " )',advance='no') read (keyboard,*,iostat=ios) j if ( ios == 0 .and. j == 1 .or. j == 2 ) exit end do remove_mesh = ( j == 2 ) do write (terminal,fmt='( "Run in verbose mode? 1: no, 2: yes " )',advance='no') read (keyboard,*,iostat=ios) j if ( ios == 0 .and. j == 1 .or. j == 2 ) exit end do verbose = ( j == 2 ) do write (terminal,fmt='( "Select alternate fill mode: 0 - disallow")') write (terminal,fmt='( " 1 - treat alternate polygons as normal")') write (terminal,fmt='( " 2 - trash alternate polygons")') read (keyboard,*,iostat=ios) j if ( ios == 0 .and. ( j >= 0 .and. j <= 2 ) ) exit end do alternate_mode = j else !Obtain filename from command line if arguments are present get_filename : do j = 1 , n_args call get_command_argument( j , length = l ) allocate( character(len=l) :: filename ) call get_command_argument( j , value = filename ) if ( filename(1:1) == "-" ) then deallocate( filename ) else file_arg = j exit get_filename end if end do get_filename if ( .not. allocated( filename ) ) then write (terminal,fmt='( 2( a ) )') usage , NL write (terminal,fmt='( a )') helptext stop end if end if !----- !Add .eps if no extension is present point_loc = scan( filename , "." , back = .true. ) if ( point_loc == 0 ) then point_loc = len( filename ) + 1 filename = filename // ".eps" end if inquire( file = filename , exist = exists ) if ( .not. exists ) then write (terminal,50) filename 50 format( "polygone: fatal error --- file '" , a , "' does not exist." ) stop end if repaired_filename = filename(1:point_loc-1) // "_r" // filename(point_loc:) !----- !Check for options args : do j = 1 , n_args if ( j == file_arg ) cycle args call get_command_argument( j , length = l ) allocate( character(len=l) :: tmp ) call get_command_argument( j , value = tmp ) select case( l ) case( :1 ) error = .true. exit args case( 2 ) if ( tmp(1:1) /= "-" ) then error = .true. exit args end if select case( tmp(2:2) ) case( "r" ) remove_mesh = .true. case( "v" ) verbose = .true. case default write (terminal,fmt='( "Unrecognised option " , a2 )') tmp error = .true. end select case( 3: ) if ( tmp(1:2) == '-m' ) then read(tmp(3:),*,iostat=ios) m error = ( ios /= 0 .or. m < 0 ) else if ( tmp(1:2) == '-s' ) then read(tmp(3:),*,iostat=ios) min_sep_toks error = ( ios /= 0 .or. min_sep_toks <= 0 ) else if ( tmp(1:2) == '-a' ) then read(tmp(3:),*,iostat=ios) alternate_mode error = ( ios /= 0 .or. alternate_mode < 0 .or. alternate_mode > 2 ) else error = .true. exit args end if end select deallocate( tmp ) end do args !----- if ( error ) then write (terminal,fmt='( 2( a ) )') usage , NL write (terminal,fmt='( a )') helptext stop end if if ( verbose .and. n_args /= 0 ) then write (terminal,fmt='( "Verbose mode on." )') if ( remove_mesh ) then write (terminal,fmt='( "Mesh removal on." )') else write (terminal,fmt='( "Mesh removal off." )') end if write (terminal,fmt='( "Minimum number of separator tokens: " , i2 )') min_sep_toks select case( alternate_mode ) case( 0 ) write (terminal,fmt='( "Alternate fill tokens disallowed." )') case( 1 ) write (terminal,fmt='( "Polygons filled by alternate tokens will be processed as normal." )') case( 2 ) write (terminal,fmt='( "Polygons filled by alternate tokens will be trashed." )') end select write (terminal,*) end if !----- out_unit = 11 open( unit = out_unit , file = repaired_filename , action = 'write' , form = 'unformatted' , & & access = 'stream' , status = 'replace' ) !Start timing call system_clock( cs ) !----- call tokenize_file_v4( filename , first ) !Copy comments to new postscript and add processing details. call date_and_time( date = date_char(1:8) , time = time_char ) allocate( character (10) :: tmp ) write (tmp,fmt='( i10 )') m allocate( p ) allocate( p % string , source = "%%Processed by " ) p % string = p % string // trim( remarks(1) ) // " with m = " // trim( adjustl( tmp ) ) // " at " // & & time_char(1:2) // ":" // time_char(3:4) // " on " // date_char(7:8) // "/" // & & date_char(5:6) // "/" // date_char(1:4) // line_feed call purge_comments_v2( first , out_unit , p ) deallocate( p ) call drawing_token_scan_v3( first , drawing_toks , min_sep_toks , verbose = verbose ) !----- !Drawing tokens for use on output. Initially we use the !tokens in the input file, but this may change below. od_toks = drawing_toks if ( remove_mesh ) then call pgf_setup( first , pgf_macro , native_pgf_start = pgf_start_locator , verbose = verbose ) !Change the token used for fill on output od_toks(3) % string = pgf_macro % string(2:) nullify( od_toks(3) % next ) !Put the pgf macro immediately after the comments, if it is not already there. if ( .not. associated( pgf_start_locator , first ) ) then call purge( pgf_macro , out_unit ) allocate( p ) p % string = line_feed call purge( p , out_unit ) else call destroy( pgf_macro ) end if end if !----- write (terminal,*) this => first pattern_mismatch = .false. group_number = 0 polygons_this_group = 0 scan_mode = 0 !Scan modes !0: number !1: number !2: moveto !3: number or dts(3) !4: number !5: lineto !6: number or dts(3) !7: dts(3) chain !8: dts(3) last !We could have a problem if the postscript file consists entirely of comments, so... if ( associated( first ) ) then toks : do select case( scan_mode ) case( 2 ) !A moveto is required if ( this == drawing_toks(1) ) then scan_mode = 3 else pattern_mismatch = .true. end if case( 3 ) !Mathematica sometimes inserts 'shapes' with only a single point. Therefore !we must allow for the possibility that the next token is a closepath. if ( this % catcode == num_cat ) then scan_mode = 4 else atest = .false. if ( alternate_mode /= 0 ) then if ( allocated( drawing_toks(3) % alternate ) ) then if ( this % string == drawing_toks(3) % alternate ) atest = .true. end if end if if ( this % string == drawing_toks(3) % string .or. atest ) then if ( associated( drawing_toks(3) % next ) ) then !Set for next match p => drawing_toks(3) % next if ( associated( p % next ) ) then scan_mode = 7 else !Note: mode 8 allows for the case where each polygon in a group !has a redundant newpath operator, except the last. Therefore !the current token may be the last filling token in the group. !If this is wrong, it will be corrected harmlessly. last_fill => this scan_mode = 8 end if else !Nothing else to match in this case last_fill => this polygons_this_group = polygons_this_group + 1 scan_mode = 0 end if else pattern_mismatch = .true. end if end if !----- case( 5 ) !A lineto is required if ( this == drawing_toks(2) ) then scan_mode = 6 else pattern_mismatch = .true. end if case( 6 ) !What follows a lineto could be a closepath or a number if ( this % catcode == num_cat ) then scan_mode = 4 else atest = .false. if ( alternate_mode /= 0 ) then if ( allocated( drawing_toks(3) % alternate ) ) then if ( this % string == drawing_toks(3) % alternate ) atest = .true. end if end if if ( this % string == drawing_toks(3) % string .or. atest ) then if ( associated( drawing_toks(3) % next ) ) then !Set for next match p => drawing_toks(3) % next if ( associated( p % next ) ) then scan_mode = 7 else last_fill => this !See above comment re. scan mode 8 scan_mode = 8 end if else !Nothing else to match in this case last_fill => this polygons_this_group = polygons_this_group + 1 scan_mode = 0 end if else pattern_mismatch = .true. end if end if case( 7 ) atest = .false. if ( alternate_mode /= 0 ) then if ( allocated( p % alternate ) ) then if ( this % string == p % alternate ) atest = .true. end if end if if ( this == p .or. atest ) then !N.B. we always check that p % next is associated before switching to mode 7 p => p % next if ( .not. associated( p % next ) ) then last_fill => this !See above comment re. scan mode 8 scan_mode = 8 end if else pattern_mismatch = .true. end if case( 8 ) !If redundant newpath operators are in use, then the last !polygon in a group will suffer a mismatch at mode 8. polygons_this_group = polygons_this_group + 1 atest = .false. if ( alternate_mode /= 0 ) then if ( allocated( p % alternate ) ) then if ( this % string == p % alternate ) atest = .true. end if end if if ( this == p .or. atest ) then last_fill => this scan_mode = 0 else pattern_mismatch = .true. end if case default !Used when numbers are expected if ( this % catcode == num_cat ) then scan_mode = scan_mode + 1 else pattern_mismatch = .true. end if end select !----- mismatch : if ( pattern_mismatch ) then ptg : if ( polygons_this_group > 1 ) then group_number = group_number + 1 write (terminal,fmt='( "Group " , i3 , ":" )',advance='no') group_number !Break pointer chain this => last_fill % next nullify( last_fill % next ) !tokens_to_ps_path_queue ignores leading spaces, which will cause !a problem if any such spaces are attached to first. So... if ( first % leading_spaces > 0 ) write (out_unit) " " if ( alternate_mode == 2 ) then call trash_alternate_polygons( drawing_toks , first , trashed_polygons ) write (terminal,fmt='( i8 , " alternate polygons have been trashed." )' ) trashed_polygons write (terminal,fmt='( " " )',advance='no') end if !Tokens up to and including the last fill can be converted into a postscript path queue. call tokens_to_ps_path_queue( first , drawing_toks(3) , ppq , display = .true. ) call destroy( first ) !Note: tokens_to_ps_path_queue will discard 'polygons' with only two points, !so in theory we could get to here with a group that has fewer than two polygons. if ( ppq % npaths > 1 ) then call ppq % stratify( verbose = .false. ) call v3_process( ppq , m ) call ppq % gather( verbose = .true. ) !Output processed path data to file call ppq % output( od_toks , out_unit ) call ppq % destroy() else call ppq % output( od_toks , out_unit ) call ppq % destroy() end if first => this else ptg call first % write( out_unit ) this => first % next deallocate( first ) first => this end if ptg polygons_this_group = 0 pattern_mismatch = .false. scan_mode = 0 else mismatch this => this % next end if mismatch !----- !Skip special tokens (line ends, etc.) specials : do if ( .not. associated( this ) ) exit toks if ( this % catcode == spc_cat ) then this => this % next else exit specials end if end do specials !----- end do toks end if !----- !Purge anything we have left call purge( first , out_unit ) !----- !Processing complete; display new file name. write (terminal,200) NL , repaired_filename 200 format( a , "Repaired filename is '" , a , "'" ) call system_clock( ce , cps ) !Make sure all data has been written to out_unit. Flushing the !buffer does not seem to work with ifort for some reason. close( out_unit ) inquire( file = filename , size = if_size ) inquire( file = repaired_filename , size = of_size ) write (terminal,fmt='( "Processing completed in " , f8.4 , " seconds." )') real( ce - cs ) / real( cps ) write (terminal,300) 100.0 * real( of_size ) / real( if_size ) 300 format( "New file is " , f6.2 , "% size of old file." ) !----- end program